## iconifiable-widget.pkg
#
# Widget for "iconizing" another widget.
# Compiled by:
# src/lib/x-kit/widget/xkit-widget.sublib### "The true mystery of the world
### is the visible, not the invisible."
###
### -- Oscar Wilde
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 d3 = three_d; # three_d is from src/lib/x-kit/widget/old/lib/three-d.pkg package mr = xevent_mail_router; # xevent_mail_router is from src/lib/x-kit/widget/old/basic/xevent-mail-router.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.pkgherein
package iconifiable_widget
: (weak) Iconifiable_Widget # Iconifiable_Widget is from src/lib/x-kit/widget/old/wrapper/iconifiable-widget.api {
Plea_Mail
#
= GET_SIZE_CONSTRAINT Oneshot_Maildrop( wg::Widget_Size_Preference )
#
| DO_REALIZE { kidplug: xc::Kidplug,
window: xc::Window,
window_size: g2d::Size
}
;
Iconifiable_Widget
=
ICONIFIABLE_WIDGET
{ widget: wg::Widget,
plea_slot: Mailslot( Plea_Mail )
};
default_font = "-Adobe-Helvetica-Bold-R-Normal--*-120-*";
min_border_thickness = 4;
light_border_thickness = 2;
pady = 2; # Padding above and below label.
space = 10; # Spacing between light and label.
attributes
=
[ (wa::border_thickness, wa::INT, wa::INT_VAL 10),
(wa::label, wa::STRING, wa::STRING_VAL ""),
(wa::font, wa::FONT, wa::STRING_VAL default_font),
(wa::color, wa::COLOR, wa::NO_VAL),
(wa::background, wa::COLOR, wa::STRING_VAL "white"),
(wa::foreground, wa::COLOR, wa::STRING_VAL "black"),
(wa::select_color, wa::COLOR, wa::STRING_VAL "black")
];
fun make_font_info font
=
{ my { ascent => font_ascent,
descent => font_descent
}
=
xc::font_high font;
(font, font_ascent, font_descent);
};
fun make_text_label (s, font)
=
{ my xc::CHAR_INFO { left_bearing, right_bearing, ... }
=
.overall_info (xc::text_extents font s);
(s, left_bearing, right_bearing);
};
fun size_of_label ((s, lb, rb), (_, fa, fd))
=
{ wide => rb - lb + 2,
high => fa + fd
};
fun set_light_width (_, fonta, fontd)
=
(80 * (fonta+fontd)) / 100;
Result = { child: wg::Widget,
shades: wg::Shades,
fontinfo: (xc::Font, Int, Int),
label: (String, Int, Int),
fg: xc::Rgb,
bg: xc::Rgb,
on_color: xc::Rgb,
light_size: Int,
pady: Int,
border_thickness: Int
};
fun make_result (root, view, args) child
=
{ attributes = wg::find_attribute (wg::attributes (view, attributes, args));
#
(make_font_info (wa::get_font (attributes wa::font)))
->
fontinfo as (f, _, _);
label = make_text_label (wa::get_string (attributes wa::label), f);
border_thickness = wa::get_int (attributes wa::border_thickness);
foreground_color = wa::get_color (attributes wa::foreground);
background_color = wa::get_color (attributes wa::background);
select_color = wa::get_color (attributes wa::select_color);
color = case (wa::get_color_opt (attributes wa::color))
#
THE color => color;
_ => background_color;
esac;
light_size = set_light_width fontinfo;
{ child,
fontinfo,
label,
fg => foreground_color,
bg => background_color,
pady,
shades => wg::shades root color,
light_size,
border_thickness => int::max (border_thickness, min_border_thickness),
on_color => select_color
};
};
fun drawfn (dr, { wide, high }, v: Result)
=
{ v.fontinfo -> (font, font_ascent, font_descent);
#
font_high = font_ascent + font_descent;
txt_pen = xc::make_pen [ xc::p::FOREGROUND (xc::rgb8_from_rgb v.fg ) ];
on_pen = xc::make_pen [ xc::p::FOREGROUND (xc::rgb8_from_rgb v.on_color) ];
fun draw_light (is_on, relief)
=
{ light_size = v.light_size;
#
col = v.border_thickness;
row = v.pady + (font_high - light_size) / 2;
box = { col, row,
wide => light_size,
high => light_size
};
arg = { box, relief, width => light_border_thickness };
shades = v.shades;
if is_on
#
xc::fill_box dr on_pen box;
d3::draw_box dr arg shades;
else
d3::draw_filled_box dr arg shades;
fi;
};
fun draw_groove ()
=
{ bw = v.border_thickness;
my { wide => label_wide, ... }
=
size_of_label (v.label, v.fontinfo);
light_size = v.light_size;
y = v.pady + (font_high / 2);
rht = high - y - (bw / 2);
box = { col=>bw / 2, row=>y, wide=>wide-bw, high=>rht };
clr_box
=
{ col => bw + light_size,
row => v.pady,
wide => space + label_wide,
high => font_high
};
arg = { box, width=>2, relief=>wg::GROOVE };
d3::draw_box dr arg v.shades;
xc::clear_box dr clr_box;
};
fun draw_label ()
=
{ light_size = v.light_size;
v.fontinfo -> (font, font_ascent, _);
v.label -> (s, lb, _);
col = v.border_thickness + light_size + space - lb + 1;
row = v.pady + font_ascent + 1;
xc::draw_transparent_string
dr
txt_pen
font
({ col, row }, s);
};
fun init ()
=
{ xc::clear_drawable dr;
draw_groove ();
draw_label ();
};
fun draw (do_init, is_open, down)
=
{ if do_init init(); fi;
#
draw_light
( is_open,
down ?? wg::SUNKEN :: wg::RAISED
);
};
draw;
};
Mouse_Event = MOUSE_EVENT_DOWN
| MOUSE_EVENT_UP Bool
;
fun mouse_p (m, m_slot)
=
loop ()
where
fun down_loop is_in
=
case (xc::get_contents_of_envelope (block_until_mailop_fires m))
#
xc::MOUSE_LAST_UP _ => put_in_mailslot (m_slot, MOUSE_EVENT_UP is_in);
xc::MOUSE_LEAVE _ => down_loop FALSE;
xc::MOUSE_ENTER _ => down_loop TRUE;
_ => down_loop is_in;
esac;
fun loop ()
=
for (;;) {
#
case (xc::get_contents_of_envelope (block_until_mailop_fires m))
#
xc::MOUSE_FIRST_DOWN { mouse_button, ... }
=>
{ put_in_mailslot (m_slot, MOUSE_EVENT_DOWN);
#
down_loop TRUE;
};
_ => ();
esac;
};
end;
fun adjust (wg::INT_PREFERENCE { start_at, step_by, min_steps, best_steps, max_steps }, low)
=
{ fun adj (l, mn)
=
if (l >= low) mn;
else adj (l+step_by, mn+1);
fi;
min_steps = adj (start_at+min_steps*step_by, min_steps);
best_steps = int::max (best_steps, min_steps);
max_steps
=
case max_steps
#
THE m => THE (int::max (m, best_steps));
NULL => NULL;
esac;
wg::INT_PREFERENCE { start_at, step_by, min_steps, best_steps, max_steps };
};
fun bounds (result: Result, is_open)
=
{
fun inc_base (wg::INT_PREFERENCE { start_at, step_by, min_steps, best_steps, max_steps }, extra)
=
wg::INT_PREFERENCE { start_at=>start_at+extra, step_by, min_steps, best_steps, max_steps };
(size_of_label (result.label, result.fontinfo ))
->
{ wide, high };
(wg::size_preference_of result.child)
->
{ col_preference, row_preference };
xextra = 2*result.border_thickness;
topwid = xextra + result.light_size + wide + space;
col_preference
=
if (wg::minimum_length col_preference >= topwid) col_preference;
else adjust (col_preference, topwid);
fi;
yextra = 2*result.pady + result.border_thickness + high;
row_preference
=
if is_open inc_base (row_preference, yextra);
else wg::tight_preference yextra;
fi;
{ col_preference => inc_base (col_preference, xextra),
row_preference
};
};
fun realize ( { kidplug, window, window_size }, result: Result, plea')
=
{ mslot = make_mailslot ();
#
rcvm = take_from_mailslot' mslot;
kidplug -> xc::KIDPLUG { to_mom=>myco, ... };
(xc::make_widget_cable ())
->
{ kidplug, momplug };
(xc::ignore_keyboard kidplug)
->
xc::KIDPLUG { from_other', from_mouse', ... };
fun child_box ({ wide, high } )
=
{ bw = result.border_thickness;
#
result.fontinfo -> (_, font_ascent, font_descent);
yoff = result.pady + font_ascent + font_descent;
{ col => bw,
row => yoff,
#
wide => int::max (1, wide-bw-bw),
high => int::max (1, high-yoff-bw)
};
};
crect = child_box window_size;
cwin = wg::make_child_window (window, crect, wg::args_of result.child);
(xc::make_widget_cable ())
->
{ kidplug => ckidplug,
momplug => cmomplug
};
cmomplug -> xc::MOMPLUG { from_kid'=>childco, ... };
dr = xc::drawable_of_window window;
fun handle_co (xc::REQ_RESIZE, is_open)
=>
if is_open block_until_mailop_fires (myco xc::REQ_RESIZE); fi;
handle_co (xc::REQ_DESTRUCTION, _)
=>
{ xc::destroy_window cwin;
#
block_until_mailop_fires (myco xc::REQ_DESTRUCTION);
};
end;
fun do_mom (xc::ETC_RESIZE ({ wide, high, ... }: g2d::Box), me)
=>
{ size = { wide, high };
#
if (#1 me)
#
xc::move_and_resize_window cwin (child_box size);
fi;
(#1 me, #2 me, drawfn (dr, size, result));
};
do_mom (xc::ETC_REDRAW _, me as (is_open, down, drawfn))
=>
{ drawfn (TRUE, is_open, down); me;};
do_mom (_, me)
=>
me;
end;
fun do_plea (GET_SIZE_CONSTRAINT reply_1shot, is_open)
=>
put_in_oneshot (reply_1shot, bounds (result, is_open));
do_plea _ => ();
end;
fun handle_mouse_event (MOUSE_EVENT_DOWN, (is_open, _, drawfn))
=>
{ drawfn (FALSE, is_open, TRUE);
#
(is_open, TRUE, drawfn);
};
handle_mouse_event (MOUSE_EVENT_UP TRUE, (is_open, _, drawfn))
=>
{ if is_open xc::hide_window cwin;
else xc::show_window cwin;
fi;
block_until_mailop_fires (myco xc::REQ_RESIZE);
drawfn (FALSE, not is_open, FALSE);
(not is_open, FALSE, drawfn);
};
handle_mouse_event (MOUSE_EVENT_UP FALSE, (is_open, _, drawfn))
=>
{ drawfn (FALSE, is_open, FALSE);
(is_open, FALSE, drawfn);
};
end;
fun main me
=
do_one_mailop [
plea' ==> (\\ r = { do_plea (r,#1 me); main me;}),
from_other' ==> (\\ envelope = main (do_mom (xc::get_contents_of_envelope envelope, me))),
rcvm ==> (\\ m = main (handle_mouse_event (m, me))),
childco ==> (\\ c = { handle_co (c,#1 me); main me;})
];
make_thread "iconifiable_widget" {.
#
mouse_p (from_mouse', mslot);
};
mr::route_pair (kidplug, momplug, cmomplug);
wg::realize_widget
result.child
{ kidplug => ckidplug,
window => cwin,
window_size => g2d::box::size crect
};
main (FALSE, FALSE, drawfn (dr, window_size, result));
};
fun init (result: Result, plea')
=
loop ()
where
fun do_plea (GET_SIZE_CONSTRAINT reply_1shot) => put_in_oneshot (reply_1shot, bounds (result, FALSE));
do_plea (DO_REALIZE arg ) => realize (arg, result, plea');
end;
fun loop ()
=
for (;;) {
do_plea (block_until_mailop_fires plea');
};
end;
fun make_iconifiable_widget (root_window, view, args) widget
=
{ plea_slot = make_mailslot ();
result = make_result (root_window, view, args) widget;
fun size_preference_thunk_of ()
=
{ reply_1shot = make_oneshot_maildrop ();
#
put_in_mailslot (plea_slot, GET_SIZE_CONSTRAINT reply_1shot);
get_from_oneshot reply_1shot;
};
w = wg::make_widget {
root_window,
size_preference_thunk_of,
args => \\ () = { background => THE result.bg },
realize_widget => \\ arg = put_in_mailslot (plea_slot, DO_REALIZE arg)
};
make_thread "iconifiable_widget init" {.
#
init (result, take_from_mailslot' plea_slot);
};
ICONIFIABLE_WIDGET { widget=>w, plea_slot };
};
fun as_widget (ICONIFIABLE_WIDGET { widget, ... } )
=
widget;
}; # package iconifiable_widget
end;