## slider.pkg
#
# Analog slider.
# Compiled by:
# src/lib/x-kit/widget/xkit-widget.sublib### "How does a project get to be a year late?
### One day at a time."
###
### -- Frederick Brooks, Jr.,
### The Mythical Man Month
stipulate
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 #
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 wa = widget_attribute_old; # widget_attribute_old is from src/lib/x-kit/widget/old/lib/widget-attribute-old.pkg #
package lk = slider_look; # slider_look is from src/lib/x-kit/widget/old/leaf/slider-look.pkgherein
package slider
: (weak) Slider # Slider is from src/lib/x-kit/widget/old/leaf/slider.api {
fun error (f, msg)
=
lib_base::failure { module=>"Slider", fn=>f, msg };
Range = { from: Int,
to: Int
};
Mouse_Message
#
= GRAB g2d::Point
| MOVE g2d::Point
| UNGRAB g2d::Point
| HAS_MOUSE_FOCUS Bool
;
Slider_Rep = { curx: Int,
curv: Int
};
# mouse reader
Reply_Mail = OKAY | ERROR;
Plea_Mail
= SET_VALUE (Int, Oneshot_Maildrop( Reply_Mail ))
| GET_VALUE Oneshot_Maildrop( Int )
| GET_RANGE Oneshot_Maildrop( Range )
| GET_ACTIVE Oneshot_Maildrop( Bool )
| SET_ACTIVE Bool
#
| DO_REALIZE { kidplug: xc::Kidplug,
window: xc::Window,
window_size: g2d::Size
}
;
Slider
=
SLIDER
{ widget: wg::Widget,
plea_slot: Mailslot( Plea_Mail ),
slider_motion': Mailop( Int )
};
/*
fun mseP (mseSlot, m) = let
use interact
fun downLoop () =
case msgBodyOf (block_until_mailop_fires m) of
MOUSE_LAST_UP { pt, ... } => put_in_mailslot (mseSlot, UNGRAB pt)
| MOUSE_MOTION { pt, ... } =>
(put_in_mailslot (mseSlot, Move pt);downLoop ())
| MOUSE_LEAVE _ => (put_in_mailslot (mseSlot, HAS_MOUSE_FOCUS FALSE);downLoop ())
| MOUSE_ENTER _ => (put_in_mailslot (mseSlot, HAS_MOUSE_FOCUS TRUE); downLoop ())
| _ => downLoop ()
fun loop () = (
case msgBodyOf (block_until_mailop_fires m) of
MOUSE_FIRST_DOWN { pt, ... } => (
put_in_mailslot (mseSlot, GRAB pt);
downLoop ()
)
| MOUSE_ENTER _ => put_in_mailslot (mseSlot, HAS_MOUSE_FOCUS TRUE)
| MOUSE_LEAVE _ => put_in_mailslot (mseSlot, HAS_MOUSE_FOCUS FALSE)
| _ => ();
loop ())
in
loop ()
end
*/
fun mouse_loop (mouse_slot, mouse_mailop)
=
loop ()
where
timeout' = timeout_in' 0.03;
#
filter_count = 5;
fun motion_loop (pt, 0)
=>
{ put_in_mailslot (mouse_slot, MOVE pt);
down_loop ();
};
motion_loop (pt, count)
=>
do_one_mailop [
timeout'
==>
{. put_in_mailslot (mouse_slot, MOVE pt);
#
down_loop ();
},
mouse_mailop
==>
(\\ mailop
=
case (xc::get_contents_of_envelope mailop)
#
xc::MOUSE_LAST_UP { window_point, ... } => put_in_mailslot (mouse_slot, UNGRAB window_point);
xc::MOUSE_MOTION { window_point, ... } => motion_loop (window_point, count - 1);
xc::MOUSE_LEAVE _
=>
{ put_in_mailslot (mouse_slot, HAS_MOUSE_FOCUS FALSE);
#
motion_loop (pt, count);
};
xc::MOUSE_ENTER _
=>
{ put_in_mailslot (mouse_slot, HAS_MOUSE_FOCUS TRUE);
#
motion_loop (pt, count);
};
_ => motion_loop (pt, count);
esac
)
];
end
also
fun down_loop ()
=
case (xc::get_contents_of_envelope (block_until_mailop_fires mouse_mailop))
#
xc::MOUSE_LAST_UP { window_point, ... } => put_in_mailslot (mouse_slot, UNGRAB window_point);
xc::MOUSE_MOTION { window_point, ... } => motion_loop (window_point, filter_count);
xc::MOUSE_LEAVE _ => { put_in_mailslot (mouse_slot, HAS_MOUSE_FOCUS FALSE); down_loop (); };
xc::MOUSE_ENTER _ => { put_in_mailslot (mouse_slot, HAS_MOUSE_FOCUS TRUE ); down_loop (); };
_ => down_loop ();
esac;
fun loop ()
=
for (;;) {
#
case (xc::get_contents_of_envelope (block_until_mailop_fires mouse_mailop))
#
xc::MOUSE_FIRST_DOWN { window_point, ... }
=>
{ put_in_mailslot (mouse_slot, GRAB window_point);
#
down_loop ();
};
xc::MOUSE_ENTER _
=>
put_in_mailslot (mouse_slot, HAS_MOUSE_FOCUS TRUE);
xc::MOUSE_LEAVE _
=>
put_in_mailslot (mouse_slot, HAS_MOUSE_FOCUS FALSE);
_ => ();
esac;
};
end;
fun plea_buffer_loop (new_plea', buffered_plea_slot)
=
loop ([],[])
where
fun loop ([],[])
=>
loop([],[block_until_mailop_fires new_plea']);
loop (q,[])
=>
loop([], reverse q);
loop (q, q' as (m ! rest))
=>
do_one_mailop [
new_plea'
==>
(\\ msg = loop (msg ! q, q')),
put_in_mailslot' (buffered_plea_slot, m)
==>
{. loop (q, rest); }
];
end;
end;
fun okay_val ( { from_v, to_v, ... } : lk::Slider_Look, v)
=
from_v <= to_v
##
?? (from_v <= v and v <= to_v)
:: (from_v >= v and v >= to_v);
fun realize ( { kidplug, window, window_size }, slider_look, active, v, client_plea_slot, val_slot)
=
config (state, window_size)
where
mouse_slot = make_mailslot ();
buffered_plea_slot = make_mailslot ();
buffered_plea' = take_from_mailslot' buffered_plea_slot;
mouse' = take_from_mailslot' mouse_slot;
my xc::KIDPLUG { from_mouse', from_other', ... }
=
xc::ignore_keyboard kidplug;
state = (v, active, FALSE, FALSE);
fun config (state, size)
=
{ drawf = lk::make_slider_drawfn (window, size, slider_look); # make_slider_drawfn is curried.
pt_to_val = lk::pt_to_val (size, slider_look);
fun do_mom (xc::ETC_REDRAW _, me)
=>
{ drawf (me, TRUE);
me;
};
do_mom (xc::ETC_RESIZE ({ wide, high, ... } ), me)
=>
config (me, { wide, high } );
do_mom (_, me)
=>
me;
end;
fun do_buffered_plea (SET_VALUE (v', reply_1shot), state as (v, a, r, d))
=>
if (okay_val (slider_look, v'))
#
put_in_oneshot (reply_1shot, OKAY);
if (v == v')
NULL;
else
put_in_mailslot (val_slot, v');
THE (v', a, r, d);
fi;
else
put_in_oneshot (reply_1shot, ERROR);
NULL;
fi;
do_buffered_plea (GET_VALUE reply_1shot, state)
=>
{ put_in_oneshot (reply_1shot, #1 state);
NULL;
};
do_buffered_plea (GET_RANGE reply_1shot, _)
=>
{ put_in_oneshot (reply_1shot, { from=> slider_look.from_v, to=> slider_look.to_v } );
#
NULL;
};
do_buffered_plea (GET_ACTIVE reply_1shot, state)
=>
{ put_in_oneshot (reply_1shot, #2 state);
#
NULL;
};
do_buffered_plea (SET_ACTIVE b', (v, b, r, d))
=>
if (b == b') NULL;
else THE (v, b', r, d);
fi;
do_buffered_plea (_, _)
=>
NULL;
end;
fun do_mouse (GRAB pt, (v, _, r, _))
=>
{ v' = (pt_to_val pt)
except _ = v;
state = (v', TRUE, r, TRUE);
drawf (state, FALSE);
if (v != v')
#
put_in_mailslot (val_slot, v');
fi;
state;
};
do_mouse (MOVE pt, (v, _, r, _))
=>
{ v' = (pt_to_val pt)
except _ = v;
state = (v', TRUE, r, TRUE);
if (v != v')
drawf (state, FALSE);
put_in_mailslot (val_slot, v');
fi;
state;
};
do_mouse (UNGRAB pt, (v, _, r, _))
=>
{ v' = (pt_to_val pt)
except _ = v;
state = (v', TRUE, r, FALSE);
drawf (state, FALSE);
if (v != v')
#
put_in_mailslot (val_slot, v');
fi;
state;
};
do_mouse (HAS_MOUSE_FOCUS r', me as (v, _, r, d))
=>
if (r' == r)
me;
else
state' = (v, TRUE, r', d);
drawf (state', FALSE); state';
fi;
end;
fun active_p (me as (v, a, r, d))
=
do_one_mailop [
mouse' ==>
(\\ m = active_p (do_mouse (m, me))),
buffered_plea'
==>
(\\ mailop
=
case (do_buffered_plea (mailop, me))
NULL => active_p me;
THE me' => if (#2 me')
drawf (me', FALSE);
active_p me';
else
drawf (me', TRUE);
inactive_p me';
fi;
esac),
from_other' ==>
(\\ mailop = active_p (do_mom (xc::get_contents_of_envelope mailop, me)))
]
also
fun inactive_p (me as (v, a, r, d))
=
do_one_mailop [
mouse' ==>
\\ (HAS_MOUSE_FOCUS r') => inactive_p (v, a, r', d);
_ => inactive_p me;
end,
buffered_plea' ==>
(\\ mailop
=
case (do_buffered_plea (mailop, me))
NULL => inactive_p me;
THE me' => if (#2 me')
drawf (me', TRUE);
active_p me';
else
drawf (me', FALSE);
inactive_p me';
fi;
esac),
from_other' ==>
(\\ mailop
=
inactive_p (do_mom (xc::get_contents_of_envelope mailop, me)))
];
if (#2 state) active_p state;
else inactive_p state;
fi;
}; # fun config
make_thread "slider plea" {.
#
plea_buffer_loop (take_from_mailslot' client_plea_slot, buffered_plea_slot);
};
make_thread "slider from_mouse" {.
#
mouse_loop (mouse_slot, from_mouse');
};
end; # fun realize
# Read and respond to pleas from client threads.
#
fun client_plea_loop
( slider_look,
is_active, # TRUE means respond to the mouse, FALSE means ignore the mouse.
v,
client_plea_slot, # We get client thread requests from this mailslot.
val_slot
)
=
loop (is_active, v)
where
fun do_client_plea (SET_VALUE (v, reply_1shot), state as (active, _))
=>
if (okay_val (slider_look, v))
#
put_in_oneshot (reply_1shot, OKAY);
(active, v);
else
put_in_oneshot (reply_1shot, ERROR);
state;
fi;
do_client_plea (GET_VALUE reply_1shot, state as (_, v))
=>
{ put_in_oneshot (reply_1shot, v);
state;
};
do_client_plea (GET_RANGE reply_1shot, state)
=>
{ put_in_oneshot (reply_1shot, { from=> slider_look.from_v, to=> slider_look.to_v } );
state;
};
do_client_plea (GET_ACTIVE reply_1shot, state)
=>
{ put_in_oneshot (reply_1shot, #1 state);
state;
};
do_client_plea (SET_ACTIVE b, (_, v))
=>
(b, v);
do_client_plea (DO_REALIZE arg, (active, v))
=>
{ realize (arg, slider_look, active, v, client_plea_slot, val_slot);
(active, v);
};
end;
fun loop state
=
loop (do_client_plea (take_from_mailslot client_plea_slot, state));
end;
fun get_current (NULL, slider_look)
=>
slider_look.from_v;
get_current (THE v, slider_look)
=>
if (okay_val (slider_look, v)) v;
else error ("slider", "current value out of range");
fi;
end;
attributes
=
[ (wa::is_active, wa::BOOL, wa::BOOL_VAL TRUE),
(wa::current, wa::INT, wa::NO_VAL)
];
fun make_slider (root_window, view, args)
=
{ attributes = wg::find_attribute (wg::attributes (view, attributes @ lk::widget_attributes, args));
#
slider_look = lk::make_slider_look (root_window, attributes);
is_active = wa::get_bool (attributes wa::is_active);
v = get_current (wa::get_int_opt (attributes wa::current), slider_look);
val_slot = make_mailslot ();
client_plea_slot = make_mailslot ();
make_thread "slider client_plea_loop" {.
#
client_plea_loop (slider_look, is_active, v, client_plea_slot, val_slot);
};
SLIDER { plea_slot => client_plea_slot,
#
slider_motion' => take_from_mailslot' val_slot,
#
widget => wg::make_widget { root_window,
#
args => \\ () = { background => THE slider_look.background_color },
realize_widget => \\ arg = put_in_mailslot (client_plea_slot, DO_REALIZE arg),
#
size_preference_thunk_of => lk::size_preference_thunk_of slider_look
}
};
};
fun as_widget (SLIDER { widget, ... } ) = widget;
fun slider_motion'_of (SLIDER { slider_motion', ... } ) = slider_motion';
fun set_slider_value (SLIDER { plea_slot, ... } ) v
=
{ reply_1shot = make_oneshot_maildrop ();
#
put_in_mailslot (plea_slot, SET_VALUE (v, reply_1shot));
case (get_from_oneshot reply_1shot)
#
OKAY => ();
ERROR => error("setValue", "improper value");
esac;
};
stipulate
fun get_plea_response msg (SLIDER { plea_slot, ... } )
=
{ reply_1shot = make_oneshot_maildrop ();
#
put_in_mailslot (plea_slot, msg reply_1shot);
get_from_oneshot reply_1shot;
};
herein
get_slider_range = get_plea_response GET_RANGE;
get_slider_value = get_plea_response GET_VALUE;
get_slider_active_flag = get_plea_response GET_ACTIVE;
end;
fun set_slider_active_flag (SLIDER { plea_slot, ... }, b)
=
put_in_mailslot (plea_slot, SET_ACTIVE b);
}; # package slider
end;