## pushbutton-behavior-g.pkg
#
# Protocol for buttons.
#
# TODO: Allow disabling of highlighting XXX SUCKO FIXME
# Compiled by:
# src/lib/x-kit/widget/xkit-widget.sublib# This generic is compile-invoked in:
#
# src/lib/x-kit/widget/old/leaf/pushbuttons.pkgstipulate
include package threadkit; # threadkit is from src/lib/src/lib/thread-kit/src/core-thread-kit/threadkit.pkg #
package g2d = geometry2d; # geometry2d is from src/lib/std/2d/geometry2d.pkg include package geometry2d; # geometry2d is from src/lib/std/2d/geometry2d.pkg #
package f8 = eight_byte_float; # eight_byte_float is from src/lib/std/eight-byte-float.pkg package xc = xclient; # xclient is from src/lib/x-kit/xclient/xclient.pkg #
package wg = widget; # widget is from src/lib/x-kit/widget/old/basic/widget.pkg package wb = widget_base; # widget_base is from src/lib/x-kit/widget/old/basic/widget-base.pkg package bb = button_base; # button_base is from src/lib/x-kit/widget/old/leaf/button-base.pkg package bt = button_type; # button_type is from src/lib/x-kit/widget/old/leaf/button-type.pkg package wa = widget_attribute_old; # widget_attribute_old is from src/lib/x-kit/widget/old/lib/widget-attribute-old.pkg #
pushbutton_tracing = logger::make_logtree_leaf { parent => xlogger::lib_logging, name => "xlogger::pushbutton_tracing" , default => FALSE };
trace = xlogger::log_if pushbutton_tracing 0; # Conditionally write strings to tracing.log or whatever.
herein
# This generic is invoked (only) three times in:
#
# src/lib/x-kit/widget/old/leaf/pushbuttons.pkg #
generic package pushbutton_behavior_g (
ba: Button_Look # Button_Look is from src/lib/x-kit/widget/old/leaf/button-look.api # arrowbutton_look is from src/lib/x-kit/widget/old/leaf/arrowbutton-look.pkg # textbutton_look is from src/lib/x-kit/widget/old/leaf/textbutton-look.pkg # labelbutton_look is from src/lib/x-kit/widget/old/leaf/labelbutton-look.pkg ): (weak) Pushbutton_Factory # Pushbutton_Factory is from src/lib/x-kit/widget/old/leaf/pushbutton-factory.api {
attributes = [
(wa::repeat_delay, wa::INT, wa::NO_VAL ),
(wa::repeat_interval, wa::INT, wa::INT_VAL 100 ),
(wa::is_active, wa::BOOL, wa::BOOL_VAL TRUE ),
(wa::is_set, wa::BOOL, wa::BOOL_VAL FALSE)
];
# We've just seen a mouse::DOWN on in_slot; here we wait
# for the matching upclick from in_slot, meanwhile
# writing a stream of BUTTON_DOWN events to out_slot.
#
# We wait 'repeat_delay' before writing the first BUTTON_DOWN
# to out_slot, after which we write on every 'repeat_interval'.
#
# Thus, if the upclick arrives before 'repeat_delay' has passed,
# we write no BUTTON_DOWN events at all to out_slot.
#
fun autorepeat_timer (button, out_slot, in_slot, repeat_delay, repeat_interval) ()
=
wait (timeout_in' repeat_delay)
where
fun signal ()
=
do_one_mailop [
put_in_mailslot' (out_slot, bt::BUTTON_DOWN button) ==> {. wait (timeout_in' repeat_interval); },
take_from_mailslot' in_slot ==> {. thread_exit { success => TRUE }; }
]
also
fun wait timeout'
=
do_one_mailop [
timeout' ==> signal,
take_from_mailslot' in_slot ==> {. thread_exit { success => TRUE }; }
];
end;
fun realize
#
{ kidplug, window, window_size }
#
( state,
( quanta,
plea_slot,
event_slot: Mailslot( bt::Button_Transition ),
button_look
)
)
=
{ (xc::ignore_keyboard kidplug)
->
xc::KIDPLUG { from_mouse', from_other', ... };
mouse_slot = make_mailslot ();
timer_slot = make_mailslot ();
from_mouseslot' = take_from_mailslot' mouse_slot;
drawf = ba::make_button_drawfn (button_look, window, window_size);
q = case quanta
#
THE (repeat_delay, repeat_interval)
=>
THE (repeat_delay, repeat_interval, make_mailslot ());
NULL => NULL;
esac;
fun do_plea (bb::GET_BUTTON_ACTIVE_FLAG reply_1shot, state)
=>
{ put_in_oneshot (reply_1shot, bb::get_button_active_flag state);
state;
};
do_plea (bb::SET_BUTTON_ACTIVE_FLAG arg, state)
=>
{
bb::set_button_active_flag (arg, state);
};
do_plea (bb::GET_SIZE_CONSTRAINT reply_1shot, state)
=>
{ put_in_oneshot (reply_1shot, ba::bounds button_look);
state;
};
do_plea (bb::GET_ARGS reply_1shot, state)
=>
{ put_in_oneshot (reply_1shot, ba::window_args button_look);
state;
};
do_plea (_, state)
=>
{
state;
};
end;
fun do_mom (xc::ETC_REDRAW _, me as (state, drawf))
=>
{ drawf state;
me;
};
do_mom (xc::ETC_RESIZE ({ wide, high, ... }: g2d::Box), (state, _))
=>
{
(state, ba::make_button_drawfn (button_look, window, { wide, high } ));
};
do_mom (_, me)
=>
{
me;
};
end;
fun do_mouse (bb::mouse::FOCUS v, me as ({ button_state, has_mouse_focus, mousebutton_is_down => FALSE }, drawf))
=>
if (v == has_mouse_focus)
#
me;
else
state' = { button_state, has_mouse_focus => v, mousebutton_is_down => FALSE };
#
drawf state';
put_in_mailslot (event_slot, v ?? bt::BUTTON_IS_UNDER_MOUSE :: bt::BUTTON_IS_NOT_UNDER_MOUSE);
(state', drawf);
fi;
do_mouse (bb::mouse::FOCUS v, ({ button_state, has_mouse_focus, mousebutton_is_down => TRUE }, drawf))
=>
{ state' = { button_state, has_mouse_focus => v, mousebutton_is_down => TRUE };
#
drawf state';
(state', drawf);
};
do_mouse (bb::mouse::DOWN button, ({ button_state, has_mouse_focus, mousebutton_is_down }, drawf))
=>
{ state' = { button_state, has_mouse_focus => TRUE, mousebutton_is_down => TRUE };
#
drawf state';
put_in_mailslot (event_slot, bt::BUTTON_DOWN button);
case q # 'q' is for 'quantum'
#
THE (repeat_delay, repeat_interval, tc) # 'tc' might have been 'time_channel' or 'timer_channel' or 'time_conditionvar' or ...?
=>
{ make_thread "button_control mse_down" (autorepeat_timer (button, timer_slot, tc, repeat_delay, repeat_interval));
();
};
NULL =>
{
();
};
esac;
(state', drawf);
};
do_mouse (bb::mouse::UP button, ({ button_state, has_mouse_focus, mousebutton_is_down }, drawf))
=>
{ state' = { button_state, has_mouse_focus, mousebutton_is_down => FALSE };
#
drawf state';
put_in_mailslot
(
event_slot,
#
has_mouse_focus ?? bt::BUTTON_UP button
:: bt::BUTTON_IS_NOT_UNDER_MOUSE
);
case q
#
# NULL => ();
# THE (_, _, tc) => put_in_mailslot (tc, ());
NULL =>
{
();
};
THE (_, _, tc) =>
{
put_in_mailslot (tc, ());
};
esac;
(state', drawf);
};
end;
fun active_cmd_p (me as (state, drawf))
=
do_one_mailop [
take_from_mailslot' plea_slot
==>
(\\ plea
=
{ state' = do_plea (plea, state);
#
if (state' == state)
#
active_cmd_p me; # State didn't change, so no need to redraw.
else
drawf state'; # Redraw button to reflect changed state.
if (state'.has_mouse_focus or state'.mousebutton_is_down)
#
put_in_mailslot (event_slot, bt::BUTTON_IS_NOT_UNDER_MOUSE);
fi;
inactive_cmd_p (state', drawf);
fi;
}),
# from_mouseslot' ==> (\\ m = active_cmd_p (do_mouse (m, me))),
# take_from_mailslot' timer_slot ==> (\\ m = { put_in_mailslot (event_slot, m); active_cmd_p me; }),
# from_other' ==> (\\ mailop = active_cmd_p (do_mom (get_contents_of_envelope mailop, me)))
from_mouseslot' ==> (\\ m = {
active_cmd_p (do_mouse (m, me));
}),
take_from_mailslot' timer_slot ==> (\\ m = {
put_in_mailslot (event_slot, m); active_cmd_p me;
}),
from_other' ==> (\\ mailop = { # Handle redraw and resize requests.
active_cmd_p (do_mom (xc::get_contents_of_envelope mailop, me));
})
]
also
fun inactive_cmd_p (me as (state, drawf))
=
do_one_mailop [
take_from_mailslot' plea_slot
==>
(\\ mailop
=
{ state' = do_plea (mailop, state);
#
if (state' == state)
#
inactive_cmd_p me; # Button state is unchanged, so no need to redraw.
else
drawf state'; # Redraw button to reflect changed button state.
#
if (state'.has_mouse_focus)
#
put_in_mailslot (event_slot, bt::BUTTON_IS_UNDER_MOUSE);
fi;
active_cmd_p (state', drawf);
fi;
}),
from_mouseslot'
==>
\\ (bb::mouse::FOCUS has_mouse_focus) => inactive_cmd_p ( { button_state => state.button_state, has_mouse_focus, mousebutton_is_down => state.mousebutton_is_down }, drawf); # Remember whether mouse is on us.
_ => inactive_cmd_p me; # Otherwise ignore mouse.
end,
from_other' ==>
(\\ mailop
=
{
inactive_cmd_p (do_mom (xc::get_contents_of_envelope mailop, me));
}
)
];
make_thread "button_control from_mouse" {.
#
bb::mse_p (from_mouse', mouse_slot);
};
if (bb::get_button_active_flag state) active_cmd_p (state, drawf);
else inactive_cmd_p (state, drawf);
fi;
}; # fun realize
fun pushbutton_imp (settings as (quanta, plea_slot, event_slot, button_look)) state
=
loop state
where
fun loop state
=
case (take_from_mailslot plea_slot)
#
bb::GET_SIZE_CONSTRAINT reply_1shot => { put_in_oneshot (reply_1shot, ba::bounds button_look); loop state; };
bb::GET_ARGS reply_1shot => { put_in_oneshot (reply_1shot, ba::window_args button_look); loop state; };
bb::GET_BUTTON_ACTIVE_FLAG reply_1shot => { put_in_oneshot (reply_1shot, bb::get_button_active_flag state); loop state; };
#
bb::SET_BUTTON_ACTIVE_FLAG arg => loop (bb::set_button_active_flag (arg, state));
bb::DO_REALIZE arg => realize arg (state, settings);
_ => loop state;
esac;
end;
fun make_pushbutton (root_window, view, args)
=
{ attributes
=
wg::find_attribute (wg::attributes (view, attributes, args));
event_slot = make_mailslot ();
plea_slot = make_mailslot ();
quanta = case (wa::get_int_opt (attributes wa::repeat_delay))
#
THE repeat_delay
=>
{ repeat_interval = wa::get_int (attributes wa::repeat_interval);
#
THE (f8::from_int repeat_delay, f8::from_int repeat_interval);
};
NULL => NULL;
esac;
button_state = bb::make_button_state
( wa::get_bool (attributes wa::is_active),
wa::get_bool (attributes wa::is_set)
);
button_look
=
ba::make_button_look (root_window, view, args);
fun getval msg ()
=
{ reply_1shot = make_oneshot_maildrop ();
#
put_in_mailslot (plea_slot, msg reply_1shot);
get_from_oneshot reply_1shot;
};
make_thread "pushbutton imp" {.
#
pushbutton_imp
(quanta, plea_slot, event_slot, button_look)
{ button_state,
has_mouse_focus => FALSE, # Mouse is not currently on pushbutton.
mousebutton_is_down => FALSE # Mouse button is not currently pressed on us.
};
};
bt::BUTTON {
#
plea_slot,
#
button_transition'
=>
wb::wrap_queue (take_from_mailslot' event_slot),
#
widget => wg::make_widget
{
root_window,
#
args => getval bb::GET_ARGS,
size_preference_thunk_of => getval bb::GET_SIZE_CONSTRAINT,
#
realize_widget => (\\ arg = put_in_mailslot (plea_slot, bb::DO_REALIZE arg))
}
};
}; # fun make_pushbutton
fun make_pushbutton_with_click_callback args callback # Called (only) from src/lib/x-kit/widget/old/leaf/pushbuttons.pkg =
{ (make_pushbutton args)
->
bt::BUTTON { widget, plea_slot, button_transition' };
trace {. "make_pushbutton_with_click_callback called..."; };
fun listener ()
=
listener
case (block_until_mailop_fires button_transition')
#
bt::BUTTON_UP button => callback ();
_ => ();
esac;
make_thread "button_control command" listener;
bt::BUTTON {
widget,
plea_slot,
#
button_transition'
=>
get_from_oneshot' (make_oneshot_maildrop ())
};
};
}; # generic package pushbutton_behavior_g
end;