## toggleswitch-behavior-g.pkg
#
# Implement behavior of buttons which toggle
# between ON and OFF states.
#
# The visual appearance of these toggles is
# specified separately, by the Button_Look
# argument to the generic.
# Compiled by:
# src/lib/x-kit/widget/xkit-widget.sublib# TODO: Allow disabling of highlighting
# "GOTO statement considered harmful"
#
# - C.A.R. Hoare supplied
# title to the famous
# E. W. Dijkstra letter in
# CACM 11, 3 (March, 1968)
stipulate
include package threadkit; # threadkit is from src/lib/src/lib/thread-kit/src/core-thread-kit/threadkit.pkg #
package bb = button_base; # button_base is from src/lib/x-kit/widget/old/leaf/button-base.pkg package tt = toggle_type; # toggle_type is from src/lib/x-kit/widget/old/leaf/toggle-type.pkg package wg = widget; # widget is from src/lib/x-kit/widget/old/basic/widget.pkg package wa = widget_attribute_old; # widget_attribute_old is from src/lib/x-kit/widget/old/lib/widget-attribute-old.pkg package g2d= geometry2d; # geometry2d is from src/lib/std/2d/geometry2d.pkg #
package xc = xclient; # xclient is from src/lib/x-kit/xclient/xclient.pkgherein
# This generic is referenced (only) four times, in
#
# src/lib/x-kit/widget/old/leaf/toggleswitches.pkg #
generic package toggleswitch_behavior_g (
# =======================
#
button_look: Button_Look # Button_Look is from src/lib/x-kit/widget/old/leaf/button-look.api )
: (weak) Toggleswitch_Factory # Toggleswitch_Factory is from src/lib/x-kit/widget/old/leaf/toggleswitch-factory.api {
attributes
=
[ (wa::is_active, wa::BOOL, wa::BOOL_VAL TRUE),
(wa::is_set, wa::BOOL, wa::BOOL_VAL FALSE)
];
fun realize { kidplug, window, window_size } (state, (plea_slot, event_slot, bv))
=
{ (xc::ignore_keyboard kidplug)
->
xc::KIDPLUG { from_mouse', from_other', ... };
mouse_slot = make_mailslot ();
receive_mouse' = take_from_mailslot' mouse_slot;
drawf = button_look::make_button_drawfn (bv, window, window_size);
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, button_look::bounds bv);
#
state;
};
do_plea (bb::GET_ARGS reply_1shot, state)
=>
{ put_in_oneshot (reply_1shot, button_look::window_args bv);
#
state;
};
do_plea (bb::GET_STATE reply_1shot, state)
=>
{ put_in_oneshot (reply_1shot, bb::get_state state);
#
state;
};
do_plea (bb::SET_STATE arg, state)
=>
bb::set_state (arg, 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, button_look::make_button_drawfn (bv, 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 ?? tt::TOGGLE_READY
:: tt::TOGGLE_NORMAL
);
(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 bttn, ({ button_state, ... }, drawf))
=>
{ state' = { button_state, has_mouse_focus => TRUE, mousebutton_is_down => TRUE };
#
drawf state';
(state', drawf);
};
do_mouse (bb::mouse::UP bttn, (state, drawf))
=>
if state.has_mouse_focus
#
state' = { button_state => bb::flip state.button_state, has_mouse_focus => TRUE, mousebutton_is_down => FALSE };
drawf state';
put_in_mailslot (event_slot, tt::TOGGLE_SET (bb::get_state state'));
(state', drawf);
else
state' = { button_state => state.button_state, has_mouse_focus => FALSE, mousebutton_is_down => FALSE };
drawf state';
put_in_mailslot (event_slot, tt::TOGGLE_NORMAL);
(state', drawf);
fi;
end;
fun active_cmd_p (me as (state, drawf))
=
do_one_mailop [
take_from_mailslot' plea_slot
==>
(\\ mailop
=
{ state' = do_plea (mailop, state);
#
if (state' == state)
#
active_cmd_p me;
else
drawf state';
#
if (bb::get_button_active_flag state')
#
put_in_mailslot (event_slot, tt::TOGGLE_SET (bb::get_state state'));
#
active_cmd_p (state', drawf);
else
if (state.has_mouse_focus or state.mousebutton_is_down)
#
put_in_mailslot (event_slot, tt::TOGGLE_NORMAL);
fi;
inactive_cmd_p (state', drawf);
fi;
fi;
}),
receive_mouse' ==> (\\ m = active_cmd_p (do_mouse (m, me))),
from_other' ==> (\\ mailop = 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;
else
drawf state';
#
if (bb::get_button_active_flag state')
#
active_cmd_p (state', drawf);
else
put_in_mailslot (event_slot, tt::TOGGLE_SET (bb::get_state state'));
#
inactive_cmd_p (state', drawf);
fi;
fi;
}),
receive_mouse'
==>
\\ 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);
_ => inactive_cmd_p me;
end,
from_other' ==>
(\\ mailop = inactive_cmd_p (do_mom (xc::get_contents_of_envelope mailop, me)))
];
make_thread "toggle_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 init (dictionary as (plea_slot, event_slot, bv)) state
=
loop state
where
fun loop state
=
case (take_from_mailslot plea_slot)
#
bb::GET_BUTTON_ACTIVE_FLAG reply_1shot => { put_in_oneshot (reply_1shot, bb::get_button_active_flag state); loop state; };
bb::GET_STATE reply_1shot => { put_in_oneshot (reply_1shot, bb::get_state state); loop state; };
bb::GET_SIZE_CONSTRAINT reply_1shot => { put_in_oneshot (reply_1shot, button_look::bounds bv); loop state; };
bb::GET_ARGS reply_1shot => { put_in_oneshot (reply_1shot, button_look::window_args bv); loop state; };
bb::SET_BUTTON_ACTIVE_FLAG arg => loop (bb::set_button_active_flag (arg, state));
bb::SET_STATE arg => loop (bb::set_state (arg, state));
bb::DO_REALIZE arg => realize arg (state, dictionary);
esac;
end;
fun make_toggleswitchxxx (root_window, view, args)
=
{ attributes
=
wg::find_attribute (wg::attributes (view, attributes, args));
plea_slot = make_mailslot ();
event_slot = make_mailslot ();
button_state
=
bb::make_button_state
( wa::get_bool (attributes wa::is_active),
wa::get_bool (attributes wa::is_set )
);
bv = button_look::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 "toggle_control" {.
#
init (plea_slot, event_slot, bv)
{ button_state, has_mouse_focus => FALSE, mousebutton_is_down => FALSE };
};
tt::TOGGLE
{
plea_slot,
#
mailop => 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_toggleswitch_with_click_callback (root_window, view, args) click_callback
=
{ (make_toggleswitchxxx (root_window, view, args))
->
tt::TOGGLE { widget, plea_slot, mailop };
fun listener ()
=
listener
case (block_until_mailop_fires mailop)
#
tt::TOGGLE_SET b => click_callback b;
_ => ();
esac;
make_thread "toggle_control command" listener;
tt::TOGGLE
{
widget,
#
plea_slot,
#
mailop => get_from_oneshot' (make_oneshot_maildrop ())
};
};
}; # generic package toggle_control_g
end;
## COPYRIGHT (c) 1991, 1994 by AT&T Bell Laboratories. See SMLNJ-COPYRIGHT file for details.
## Subsequent changes by Jeff Prothero Copyright (c) 2010-2015,
## released per terms of SMLNJ-COPYRIGHT.