## scrollbar.pkg
# Compiled by:
# src/lib/x-kit/widget/xkit-widget.sublib# Scrollbar widget.
#
# CHANGE LOG
#
# 12 Mar 02 - Allen Stoughton - Changed widget so that, when it's
# trying to communicate a value to the application on the scroll_event
# channel, it's still willing to process the application's set_scrollbar_thumb
# operations. (This was necessary to avoid deadlock.) Also modified
# widget to cope with resize events during SCREEN_START, ..., SCREEN_MOVE, ...,
# SCREEN_END, sequences. (Previously, the user would lose control of the
# mouse, and a SCREEN_END event wouldn't be generated.)
### "The most important fundamental laws
### and facts of physical science have all
### been discovered, and these are now so
### firmly established that the possibility
### of their ever being supplemented by new
### discoveries is exceedingly remote."
###
### -- Albert Michelson, 1903
stipulate
include package threadkit; # threadkit is from src/lib/src/lib/thread-kit/src/core-thread-kit/threadkit.pkg #
include package widget; # widget is from src/lib/x-kit/widget/old/basic/widget.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 sa = scrollbar_look; # scrollbar_look is from src/lib/x-kit/widget/old/leaf/scrollbar-look.pkg #
package g2d = geometry2d; # geometry2d is from src/lib/std/2d/geometry2d.pkg #
include package geometry2d; # geometry2d is from src/lib/std/2d/geometry2d.pkgherein
package scrollbar
: (weak) Scrollbar # Scrollbar is from src/lib/x-kit/widget/old/leaf/scrollbar.api {
min = int::min;
max = int::max;
Scroll_Event
= SCROLL_UP Float
| SCROLL_DOWN Float
| SCROLL_START Float
| SCROLL_MOVE Float
| SCROLL_END Float
;
Scrollbar
=
SCROLLBAR { widget: widget::Widget,
scrollbar_change': Mailop( Scroll_Event ),
set_thumb:
{ top: Null_Or( Float ),
size: Null_Or( Float )
}
->
Void
};
Mouse_Mail
= GRAB Point
| MOVE Point
| UNGRAB Point
| UP_GRAB Point
| UP_UNGRAB Point
| DOWN_GRAB Point
| DOWN_UNGRAB Point
;
Plea_Mail
= SET_THUMB
{ top: Null_Or( Float ),
size: Null_Or( Float )
}
| DO_REALIZE {
kidplug: xc::Kidplug,
window: xc::Window,
window_size: Size
};
# The variable "me" ranges over this type:
#
Scroll = { curx: Int,
swid: Int
};
init_size = 1000;
min_swid = 8;
fun new_vals (me as { curx, swid }, my_size, arg)
=
case arg
#
{ top=>NULL, size=>NULL }
=>
me;
{ top=>THE top, size=>NULL }
=>
{ curx => min (my_size-swid, max (0, floor (top * (float my_size)))),
swid
};
{ top=>NULL, size=> THE size }
=>
{ curx,
swid=>min (my_size-curx, max (min_swid, ceil (size * (float my_size))))
};
{ top=>THE top, size=>THE size }
=>
{ size' = min (my_size, max (min_swid, ceil (size * (float my_size))));
top' = min (my_size-size', max (0, floor (top * (float my_size))));
{ curx=>top', swid=>size'};
};
esac;
fun make_scroll (root_window, dim, color, bg, { size_preference_thunk_of, realize }: sa::Scrollbar_Look)
=
{ if (dim < 4)
lib_base::failure { module=>"Scrollbar", fn=>"mkScroll", msg=>"dim < 4"};
fi;
screen = screen_of root_window;
mouse_slot = make_mailslot (); # mouse to scrollbar
val_slot = make_mailslot (); # scrollbar to user
plea_slot = make_mailslot (); # user to scrollbar
mouse' = take_from_mailslot' mouse_slot;
plea' = take_from_mailslot' plea_slot;
# Mouse reader
#
fun mse_proc m
=
loop ()
where
fun down_loop (movef, upf)
=
loop ()
where
fun loop ()
=
case (xc::get_contents_of_envelope (block_until_mailop_fires m))
#
xc::MOUSE_LAST_UP { window_point, ... } => upf window_point;
xc::MOUSE_MOTION { window_point, ... } => { movef window_point; loop (); };
_ => loop ();
esac;
end;
fun loop ()
=
case (xc::get_contents_of_envelope (block_until_mailop_fires m))
#
xc::MOUSE_FIRST_DOWN { mouse_button=>btn as xc::MOUSEBUTTON 1, window_point, ... }
=>
{ put_in_mailslot (mouse_slot, UP_GRAB window_point);
down_loop (\\ _ = (), \\ p = put_in_mailslot (mouse_slot, UP_UNGRAB p));
loop ();
};
xc::MOUSE_FIRST_DOWN { mouse_button=>btn as (xc::MOUSEBUTTON 2), window_point, ... }
=>
{ put_in_mailslot (mouse_slot, GRAB window_point);
down_loop ( \\ p = put_in_mailslot (mouse_slot, MOVE p),
\\ p = put_in_mailslot (mouse_slot, UNGRAB p)
);
loop ();
};
xc::MOUSE_FIRST_DOWN { mouse_button=>btn as xc::MOUSEBUTTON 3, window_point, ... }
=>
{ put_in_mailslot (mouse_slot, DOWN_GRAB window_point);
down_loop (\\ _ = (), \\ p = put_in_mailslot (mouse_slot, DOWN_UNGRAB p));
loop ();
};
_ => loop ();
esac;
end;
config = realize (root_window, color);
fun realize_scroll { kidplug, window, window_size=>winsz } me
=
{ (xc::ignore_keyboard kidplug)
->
xc::KIDPLUG { from_mouse', from_other', ... };
config = config (xc::drawable_of_window window);
# Returns (me, data)
#
fun reconfig ( { curx, swid }, my_size, size, redraw)
=
{ (config size)
->
data as { size=>size', draw, ... };
scale = 1.0 / float my_size;
size' = float size';
curx' = floor ((scale * float curx) * size');
swid' = ceil ((scale * float swid) * size');
if redraw draw (curx', swid'); fi;
( { curx=>curx', swid=>swid'}, data);
};
# Returns (b, me', data'), where b is TRUE
# iff scrollbar has been reconfigured
#
fun handle_cievt (mailop, me: Scroll, data as { size, draw, ... }: sa::Scrollbar_State)
=
case (xc::get_contents_of_envelope mailop)
#
xc::ETC_OWN_DEATH
=>
(FALSE, me, data);
xc::ETC_REDRAW _
=>
{ draw (me.curx, me.swid);
(FALSE, me, data);
};
xc::ETC_RESIZE ({ wide, high, ... }: g2d::Box)
=>
{ my (me', data')
=
reconfig (me, size, { wide, high }, TRUE);
(TRUE, me', data');
};
_ => (FALSE, me, data);
esac;
fun do_plea
( SET_THUMB arg,
me as { curx, swid }, # Application's version.
me' as { curx => curx', swid => swid'}, # Scrollbar's version.
{ size, move, ... }: sa::Scrollbar_State
)
=>
{ my me'' as { curx=>curx'', swid=>swid'' }
=
new_vals (me, size, arg);
if (curx' != curx'' or swid' != swid'')
move (curx', swid', curx'', swid'');
fi;
me'';
};
do_plea (DO_REALIZE _, _, me, _)
=>
me;
end;
fun give_val_abort_on_req (v, f, me, data as { size, ... }: sa::Scrollbar_State)
=
{ v = min (size - 1, max (0, v));
val' = put_in_mailslot' (val_slot, f (float v / float size));
do_one_mailop [
val' ==> (\\ () = me),
plea' ==> (\\ mailop = do_plea (mailop, me, me, data))
];
};
# xoff, me is widget's view.
# x is new position of mouse pointer,
# relative to beginning of widget's window.
# Return (xoff', me').
#
fun move_slide (xoff, me as { curx, swid }, { size, move, ... }: sa::Scrollbar_State, x)
=
{ curx' = x - xoff;
maxx = size - swid;
my (xoff', curx'')
=
if (curx' < 0) (x - curx, 0);
elif (curx' > maxx) (x - curx, maxx);
else (xoff, curx');
fi;
if (curx'' != curx)
#
move (curx, swid, curx'', swid);
#
(xoff', { curx=>curx'', swid } );
else
(xoff', me );
fi;
};
# Return (me', data')
#
fun do_mouse (GRAB p, me as { curx, swid }, data as { size, coord, ... } )
=>
{ x = coord p;
#
maxx = size - swid;
my (xoff, me')
=
if (curx <= x and x < curx + swid)
#
(x - curx, me);
else
curx' = min (maxx, max (0, x - (swid / 2)));
(x - curx', #2 (move_slide (0 /* irrelevant */, me, data, curx')));
fi;
# xoff, me are scrollbar's view, and tell us where mouse pointer was;
# me' is what application has asked that scroll be;
# returns xoff relative to me'
#
fun newxoff (xoff, me: Scroll, me' : Scroll)
=
me.curx + xoff - me'.curx;
# me is application's view;
# xoff, me' are scrollbar's view;
# force is TRUE iff insist on communication with application, even if
# it makes request;
# returns (xoff', me''), shared by application and scrollbar
#
fun give_val (me, xoff, me', f, force, data as { size, ... } )
=
loop (me, xoff, me', val')
where
v = me'.curx;
val' = put_in_mailslot' (val_slot, f (float v / float size));
fun loop (me, xoff, me', val')
=
do_one_mailop [
val'
==>
(\\ () = (xoff, me')),
plea'
==>
(\\ mailop
=
{ me'' = do_plea (mailop, me, me', data);
xoff' = newxoff (xoff, me', me'');
if force
#
v' = me''.curx;
#
val'' = put_in_mailslot' (val_slot, f (float v' / float size));
#
loop (me'', xoff', me'', val'');
else
(xoff', me'');
fi;
})
];
end;
# xoff_opt is NULL when we've lost track
# of where mouse was - which is
# when a ETC_RESIZE has been processed;
# returns (b, (xoffOpt', me')),
# where b is TRUE iff an UNGRAB has been processed
#
fun do_mouse' (UNGRAB x, xoff_opt, me, data)
=>
case xoff_opt
NULL => ( FALSE,
{ my (_, me')
=
give_val (me, 0 /* irrelevant */, me, SCROLL_END, TRUE, data);
(NULL /* irrelevant */, me');
}
);
THE xoff
=>
{ me' = #2 (move_slide (xoff, me, data, coord x));
( FALSE,
{ my (_, me'')
=
give_val (me, 0 /* irrelevant */, me', SCROLL_END, TRUE, data);
(NULL /* irrelevant */, me'');
}
);
};
esac;
do_mouse' (MOVE x, xoff_opt, me, data)
=>
case xoff_opt
#
NULL => (TRUE, (THE (coord x - me.curx), me));
THE xoff
=>
{ my (xoff', me')
=
move_slide (xoff, me, data, coord x);
if (me.curx != me'.curx)
my (xoff'', me'')
=
give_val (me, xoff', me', SCROLL_MOVE, FALSE, data);
(TRUE, (THE xoff'', me''));
else (TRUE, (THE xoff' , me' ));
fi;
};
esac;
do_mouse' (_, xoff_opt, me, _)
=>
(TRUE, (xoff_opt, me)); # protocol error
end;
# xoffOpt is NULL when we've lost track of where mouse was - which is
# when a ETC_RESIZE has been processed;
# returns (me', data')
#
fun loop (xoff_opt, me, data)
=
do_one_mailop [
plea'
==>
(\\ mailop
=
{ me' = do_plea (mailop, me, me, data);
case xoff_opt
THE xoff => loop (THE (newxoff (xoff, me, me')), me', data);
NULL => loop (NULL, me, data);
esac;
}),
from_other' ==>
(\\ mailop
=
{ my (reconf, me', data')
=
handle_cievt (mailop, me, data);
reconf ?? loop (NULL, me', data')
:: loop (xoff_opt, me', data');
}),
mouse' ==>
(\\ mailop
=
case (do_mouse' (mailop, xoff_opt, me, data))
#
(TRUE, (xoff_opt, me)) => loop (xoff_opt, me, data);
(FALSE, (_, me)) => (me, data);
esac)
];
my (xoff', me'')
=
give_val (me, xoff, me', SCROLL_START, TRUE, data);
loop (THE xoff', me'', data);
};
do_mouse (UP_GRAB _, me, data)
=>
loop (me, data)
where
fun do_mouse' (UP_UNGRAB x, me, data as { coord, ... } )
=>
(FALSE, give_val_abort_on_req (coord x, SCROLL_UP, me, data));
do_mouse' (_, me, _)
=>
(TRUE, me); # protocol error
end;
fun loop (me, data)
=
do_one_mailop [
plea'
==>
(\\ mailop
=
loop (do_plea (mailop, me, me, data), data)),
from_other' ==>
(\\ mailop
=
{ my (_, me', data')
=
handle_cievt (mailop, me, data);
loop (me', data');
}),
mouse' ==>
(\\ mailop
=
case (do_mouse' (mailop, me, data))
#
(TRUE, me) => loop (me, data);
(FALSE, me) => (me, data);
esac)
];
end;
do_mouse (DOWN_GRAB p, me, data)
=>
loop (me, data)
where
fun do_mouse' (DOWN_UNGRAB x, me, data as { coord, ... } )
=>
(FALSE, give_val_abort_on_req (coord x, SCROLL_DOWN, me, data));
do_mouse' (_, me, _)
=>
(TRUE, me); # protocol error
end;
fun loop (me, data)
=
do_one_mailop [
plea'
==>
(\\ mailop
=
loop (do_plea (mailop, me, me, data), data)),
from_other' ==>
(\\ mailop
=
{ my (_, me', data')
=
handle_cievt (mailop, me, data);
loop (me', data');
}),
mouse' ==>
(\\ mail
=
case (do_mouse' (mail, me, data))
#
(TRUE, me) => loop (me, data);
(FALSE, me) => (me, data);
esac)
];
end;
do_mouse (_, me, data)
=>
(me, data); # protocol error
end; # fun do_mouse
fun cmd_proc (me, data)
=
cmd_proc (
do_one_mailop [
plea' ==> (\\ mailop = (do_plea (mailop, me, me, data), data)),
mouse' ==> (\\ mailop = do_mouse (mailop, me, data)),
from_other' ==>
(\\ mailop
=
{ my (_, me', data')
=
handle_cievt (mailop, me, data);
(me', data');
})
]
);
make_thread "scrollbar from_mouse" {.
#
mse_proc from_mouse';
};
make_thread "scrollbar command" {.
#
cmd_proc (reconfig (me, init_size, winsz, FALSE));
();
};
();
}; # fun realize_scroll
fun init_loop vals
=
case (take_from_mailslot plea_slot)
#
SET_THUMB arg => init_loop (new_vals (vals, init_size, arg));
DO_REALIZE arg => realize_scroll arg vals;
esac;
make_thread "scrollbar" {.
#
init_loop { curx=>0, swid=>init_size };
};
SCROLLBAR
{
scrollbar_change' => take_from_mailslot' val_slot,
#
set_thumb => (\\ arg = put_in_mailslot (plea_slot, SET_THUMB arg)),
#
widget => make_widget { root_window,
args => (\\ () = { background => bg }),
size_preference_thunk_of => size_preference_thunk_of dim,
realize_widget => (\\ arg = put_in_mailslot (plea_slot, DO_REALIZE arg))
}
};
}; # fun make_scroll
attributes
=
[ (wa::width, wa::INT, wa::INT_VAL 12),
(wa::background, wa::COLOR, wa::STRING_VAL "gray"),
(wa::color, wa::COLOR, wa::NO_VAL)
];
fun scrollbar scroll_view (root_window, view, args)
=
{ attributes
=
wg::find_attribute
(wg::attributes (view, attributes, args));
size = wa::get_int (attributes wa::width);
bg = wa::get_color (attributes wa::background);
color = case (wa::get_color_opt (attributes wa::color))
#
THE c => c;
NULL => bg;
esac;
make_scroll (root_window, size, color, THE bg, scroll_view);
};
make_horizontal_scrollbar' = scrollbar sa::horizontal_scrollbar;
make_vertical_scrollbar' = scrollbar sa::vertical_scrollbar;
fun make scroll_view root_window { size, color }
=
{ color = case color
THE c => c;
NULL => xc::get_color (xc::CMS_NAME "gray");
esac;
make_scroll (root_window, size, color, NULL, scroll_view);
};
make_horizontal_scrollbar = make sa::horizontal_scrollbar;
make_vertical_scrollbar = make sa::vertical_scrollbar;
fun as_widget (SCROLLBAR { widget, ... } ) = widget;
fun scrollbar_change'_of (SCROLLBAR { scrollbar_change', ... } )
=
scrollbar_change'; # Return the mailop which reports
# scrollbar changes, typically via 'do_one_mailop'.
fun set_scrollbar_thumb
(SCROLLBAR { set_thumb, ... } )
arg
=
set_thumb arg;
}; # package scrollbar
end;