## scrolled-widget.pkg
#
# Compare with:
# widget_with_scrollbars, designed to be harder to use but more flexible:
# src/lib/x-kit/widget/old/layout/widget-with-scrollbars.pkg#
# See also:
# viewport, which provides a window onto a larger widget,
# typically panned using scrollbars:
# src/lib/x-kit/widget/old/layout/viewport.pkg# Compiled by:
# src/lib/x-kit/widget/xkit-widget.sublib# scrolled_widget widget, for panning over a child widget
# using scrollbars.
#
# TODO:
# granularity XXX BUGGO FIXME
### "Life obliges me to do something, so I paint."
###
### -- Rene Magritte
stipulate
include package threadkit; # threadkit is from src/lib/src/lib/thread-kit/src/core-thread-kit/threadkit.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 wy = widget_style_old; # widget_style_old is from src/lib/x-kit/widget/old/lib/widget-style-old.pkg #
package bdr = border; # border is from src/lib/x-kit/widget/old/wrapper/border.pkg package lw = line_of_widgets; # line_of_widgets is from src/lib/x-kit/widget/old/layout/line-of-widgets.pkg package vp = viewport; # viewport is from src/lib/x-kit/widget/old/layout/viewport.pkg package sb = scrollbar; # scrollbar is from src/lib/x-kit/widget/old/leaf/scrollbar.pkg package qk = quark; # quark is from src/lib/x-kit/style/quark.pkg #
package g2d = geometry2d; # geometry2d is from src/lib/std/2d/geometry2d.pkgherein
package scrolled_widget
: (weak) Scrolled_Widget # Scrolled_Widget is from src/lib/x-kit/widget/old/layout/scrolled-widget.api {
Scrolled_Widget
=
SCROLLED_WIDGET { scrolled_widget: wg::Widget };
fun monitor (continuous, scrollbar, sw, setview, geometry_mailop) ()
=
{ set = sb::set_scrollbar_thumb scrollbar;
scrollbar_change'
=
sb::scrollbar_change'_of
scrollbar;
fun init is_on (origin, size, total)
=
{ r_total = float total;
r_size = float size;
maxo = total - size;
fun shift_up (r, y)
=
{ y' = y + int::min (maxo-y, trunc((1.0-r)*r_size));
if (y == y')
y;
else
{ setview y';
set { top => THE((float y')/r_total), size => NULL };
y';
}
except _ = y;
fi;
};
fun shift_down (r, y)
=
{ y' = int::max (0, y-trunc (r*r_size));
if (y == y')
y;
else
{ setview y';
set { top => THE((float y')/r_total), size => NULL };
y';
}
except _ = y;
fi;
};
fun adjust (r, y)
=
{ y' = trunc (r*r_total);
if (y == y')
y;
else
{ setview y';
y';
}
except _ = y;
fi;
};
fun do_scrollbar_change adjust_fn arg
=
case arg
#
(sb::SCROLL_START r, y) => adjust_fn (r, y);
(sb::SCROLL_UP r, y) => shift_up (r, y);
(sb::SCROLL_DOWN r, y) => shift_down (r, y);
(sb::SCROLL_MOVE r, y) => adjust_fn (r, y);
(sb::SCROLL_END r, y) => adjust (r, y);
esac;
do_scrollbar_change
=
continuous ?? do_scrollbar_change adjust
:: do_scrollbar_change (\\ (_, y) = y);
fun onloop origin
=
do_one_mailop [
#
scrollbar_change' ==> (\\ adjust_fn = onloop (do_scrollbar_change (adjust_fn, origin))),
geometry_mailop ==> init TRUE
];
fun offloop ()
=
init FALSE (block_until_mailop_fires geometry_mailop);
if (maxo <= 0)
if is_on sw FALSE; fi;
offloop ();
else
size = r_size/r_total;
top = (float origin)/r_total;
set { size => THE size, top => THE top };
if (not is_on) sw TRUE; fi;
onloop origin;
fi;
}; # fun init
init FALSE (0, 1, 1);
}; # fun monitor
fun main (viewport, vf, hf)
=
loop ()
where
viewport_configuration_change'
=
vp::get_viewport_configuration_change_mailop
viewport;
fun loop ()
=
for (;;) {
#
my { box => { col, row, wide, high },
child_size => size
}
=
block_until_mailop_fires viewport_configuration_change';
vf (row, high, size.high);
hf (col, wide, size.wide);
};
end; # fun main
attribute_continuous = qk::quark "continuous";
attribute_hsb = qk::quark "hsb";
attribute_vsb = qk::quark "vsb";
attributes
=
[ (wa::background, wa::COLOR, wa::STRING_VAL "white"),
(attribute_continuous, wa::BOOL, wa::BOOL_VAL FALSE),
(attribute_hsb, wa::BOOL, wa::NO_VAL),
(attribute_vsb, wa::BOOL, wa::NO_VAL)
];
fun do_layout (w, THE top, THE left, view as (name, style))
=>
(b, THE (hsb, hsw), THE (vsb, vsw))
where
root_window = wg::root_window_of w;
hview = (wy::extend_view (name, "hscrollbar"), style);
hsb = sb::make_horizontal_scrollbar' (root_window, hview,[]);
hfr = bdr::border (root_window, hview,[]) (sb::as_widget hsb);
b1 = top ?? lw::line_of_widgets (root_window, view, []) (lw::VT_CENTER [lw::WIDGET (bdr::as_widget hfr), lw::WIDGET w])
:: lw::line_of_widgets (root_window, view, []) (lw::VT_CENTER [lw::WIDGET w, lw::WIDGET (bdr::as_widget hfr)]);
vview = (wy::extend_view (name, "vscrollbar"), style);
vsb = sb::make_vertical_scrollbar' (root_window, vview,[]);
vfr = bdr::border (root_window, vview,[]) (sb::as_widget vsb);
(wg::size_preference_of (bdr::as_widget hfr))
->
{ row_preference => wg::INT_PREFERENCE { start_at, step_by, min_steps, best_steps, max_steps }, ... };
g = lw::SPACER
{ min_size => start_at + step_by*min_steps,
best_size => start_at + step_by*best_steps,
#
max_size => case max_steps
#
THE mx => THE (start_at + step_by*mx);
NULL => NULL;
esac
};
b2 = top ?? lw::line_of_widgets (root_window, view,[]) (lw::VT_CENTER [g, lw::WIDGET (bdr::as_widget vfr) ])
:: lw::line_of_widgets (root_window, view,[]) (lw::VT_CENTER [lw::WIDGET (bdr::as_widget vfr), g]);
hnum = top ?? 0 :: 1;
vnum = left ?? 0 :: 1;
b = if left
lw::line_of_widgets
(root_window, view, [])
(lw::HZ_CENTER [ lw::WIDGET (lw::as_widget b2),
lw::WIDGET (lw::as_widget b1)
]
);
else
lw::line_of_widgets
(root_window, view, [])
(lw::HZ_CENTER [ lw::WIDGET (lw::as_widget b1),
lw::WIDGET (lw::as_widget b2)
]
);
fi;
fun vsw TRUE => lw::show b [vnum];
vsw FALSE => lw::hide b [vnum];
end;
fun hsw TRUE => { lw::show b1 [hnum]; lw::show b2 [hnum]; };
hsw FALSE => { lw::hide b1 [hnum]; lw::hide b2 [hnum]; };
end;
hsw FALSE;
vsw FALSE;
end;
do_layout (w, THE top, NULL, view as (name, style))
=>
(box, THE (hsb, hsw), NULL)
where
root_window = wg::root_window_of w;
hview = (wy::extend_view (name, "hscrollbar"), style);
hsb = sb::make_horizontal_scrollbar' (root_window, hview,[]);
fr = bdr::border (root_window, hview,[]) (sb::as_widget hsb);
box = top ?? lw::line_of_widgets (root_window, view,[]) (lw::VT_CENTER [lw::WIDGET (bdr::as_widget fr), lw::WIDGET w])
:: lw::line_of_widgets (root_window, view,[]) (lw::VT_CENTER [lw::WIDGET w, lw::WIDGET (bdr::as_widget fr)]);
hnum = top ?? 0 :: 1;
fun hsw TRUE => lw::show box [hnum];
hsw FALSE => lw::hide box [hnum];
end;
hsw FALSE;
end;
do_layout (w, NULL, THE left, view as (name, style))
=>
(box, NULL, THE (vsb, vsw))
where
root_window = wg::root_window_of w;
vview = (wy::extend_view (name, "vscrollbar"), style);
vsb = sb::make_vertical_scrollbar' (root_window, vview,[]);
fr = bdr::border (root_window, vview,[]) (sb::as_widget vsb);
box = left ?? lw::line_of_widgets (root_window, view,[]) (lw::HZ_CENTER [lw::WIDGET (bdr::as_widget fr), lw::WIDGET w])
:: lw::line_of_widgets (root_window, view,[]) (lw::HZ_CENTER [lw::WIDGET w, lw::WIDGET (bdr::as_widget fr)]);
vnum = left ?? 0 :: 1;
fun vsw TRUE => lw::show box [vnum];
vsw FALSE => lw::hide box [vnum];
end;
vsw FALSE;
end;
do_layout (w, NULL, NULL, view)
=>
(lw::line_of_widgets (wg::root_window_of w, view,[]) (lw::WIDGET w), NULL, NULL);
end;
fun scrolled_widget (root_window, view as (name, style), args) widget
=
{ attributes
=
wg::find_attribute
(wg::attributes (view, attributes, args));
color = wa::get_color (attributes wa::background);
continuous = wa::get_bool (attributes attribute_continuous);
hsb = wa::get_bool_opt (attributes attribute_hsb);
vsb = wa::get_bool_opt (attributes attribute_vsb);
vview = (wy::extend_view (name, "viewport"), style);
viewport = vp::viewport (root_window, vview, args) widget;
fr = bdr::border (root_window, vview, args) (vp::as_widget viewport);
my (box, hsb, vsb)
=
do_layout (bdr::as_widget fr, hsb, vsb, view);
fun realize_widget arg
=
{ fun do_monitor (_, NULL)
=>
(\\ _ = ());
do_monitor (sv, THE (sb, sw))
=>
{ slot = make_mailslot ();
#
make_thread "scrollport monitor" (monitor (continuous, sb, sw, sv, take_from_mailslot' slot));
\\ arg = put_in_mailslot (slot, arg);
};
end;
vf = do_monitor (vp::set_vertical_position viewport, vsb);
hf = do_monitor (vp::set_horizontal_position viewport, hsb);
make_thread "scrolled-widget" {.
#
main (viewport, vf, hf);
};
wg::realize_widget (lw::as_widget box) arg;
};
SCROLLED_WIDGET
{
scrolled_widget
=>
wg::make_widget
{
root_window => wg::root_window_of widget,
#
args => \\ () = { background => THE color },
realize_widget,
size_preference_thunk_of
=>
wg::size_preference_thunk_of
#
(lw::as_widget box)
}
};
};
fun make_scrolled_widget { scrolled_widget=>scrolled_widget', smooth_scrolling, color, horizontal_scrollbar, vertical_scrollbar }
=
{ root_window = wg::root_window_of scrolled_widget';
#
name = wy::make_view { name => wy::style_name ["scrollport"],
aliases => []
};
horizontal_scrollbar = case horizontal_scrollbar NULL => NULL; THE { top } => THE top; esac;
vertical_scrollbar = case vertical_scrollbar NULL => NULL; THE { left } => THE left; esac;
fun add (label, THE b, l) => (label, wa::BOOL_VAL b) ! l;
add (_, NULL, l) => l;
end;
args = add (attribute_hsb, horizontal_scrollbar,
add (attribute_vsb, vertical_scrollbar,
add (attribute_continuous, THE smooth_scrolling,
[])));
args = case color
#
THE c => (wa::background, wa::COLOR_VAL c) ! args;
NULL => args;
esac;
scrolled_widget
#
( root_window,
(name, wg::style_of root_window),
args
)
#
scrolled_widget';
};
fun as_widget (SCROLLED_WIDGET { scrolled_widget, ... } )
=
scrolled_widget;
}; # scrolled_widget
end;