## border.pkg
#
# Border widget -- draws a border around its child.
# Compiled by:
# src/lib/x-kit/widget/xkit-widget.sublib### "Doubt is not a pleasant condition,
### but certainty is absurd."
### -- Voltaire
### "If users wanted a graphical interface,
### wouldn't the Macintosh dominate the market?"
###
### -- Bruce Tonkin, 1988
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.pkg package wy = widget_style_old; # widget_style_old is from src/lib/x-kit/widget/old/lib/widget-style-old.pkgherein
package border
: (weak) Border # Border is from src/lib/x-kit/widget/old/wrapper/border.api {
attributes
=
[ (wa::padx, wa::INT, wa::INT_VAL 0),
(wa::pady, wa::INT, wa::INT_VAL 0),
(wa::border_thickness, wa::INT, wa::INT_VAL 2),
(wa::relief, wa::RELIEF, wa::RELIEF_VAL (wg::SUNKEN)),
(wa::background, wa::COLOR, wa::NO_VAL)
];
Result = { padx: Int,
pady: Int,
border_thickness: Int,
relief: wg::Relief,
background: Null_Or( xc::Rgb )
};
Border
=
BORDER
{ widget: wg::Widget,
plea_slot: Mailslot( Null_Or( xc::Rgb ))
};
fun make_resources (view, args)
=
{ attributes = wg::find_attribute (wg::attributes (view, attributes, args));
{ padx => wa::get_int (attributes wa::padx),
pady => wa::get_int (attributes wa::pady),
border_thickness => wa::get_int (attributes wa::border_thickness),
relief => wa::get_relief (attributes wa::relief),
background => wa::get_color_opt (attributes wa::background)
};
};
fun border (root_window, view, args) child
=
{ result = make_resources (view, args);
plea_slot = make_mailslot ();
plea' = take_from_mailslot' plea_slot;
realize_1shot
=
make_oneshot_maildrop ();
fun fillfn wg::FLAT (d, r, c)
=>
{ p = xc::make_pen [xc::p::FOREGROUND (xc::rgb8_from_rgb c)];
\\ () = xc::fill_box d p r;
};
fillfn rel (d, r, c)
=>
{ my shades as { base, ... }
=
wg::shades root_window c;
arg1 = { box=>r, width=> result.border_thickness, relief=>rel };
fun fill ()
=
{ if (result.padx != 0 or result.pady != 0)
xc::fill_box d base r;
fi;
d3::draw_box d arg1 shades;
};
fill;
};
end;
fun size ()
=
{ 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 };
my { col_preference, row_preference }
=
wg::size_preference_of child;
xextra = 2*(result.padx + result.border_thickness);
yextra = 2*(result.pady + result.border_thickness);
{ col_preference => inc_base (col_preference, xextra),
row_preference => inc_base (row_preference, yextra)
};
};
fun realize_frame { kidplug as xc::KIDPLUG { to_mom=>myco, ... }, window, window_size } color
=
{ my { kidplug, momplug }
=
xc::make_widget_cable ();
my xc::KIDPLUG { from_other', ... }
=
xc::ignore_mouse_and_keyboard kidplug;
fun child_box ({ wide, high } )
=
{ xoff = result.padx + result.border_thickness;
yoff = result.pady + result.border_thickness;
{ col => xoff,
row => yoff,
wide => int::max (1, wide-(2*xoff)),
high => int::max (1, high-(2*yoff))
};
};
crect = child_box window_size;
cwin = wg::make_child_window (window, crect, wg::args_of child);
my { kidplug => ckidplug, momplug => cmomplug }
=
xc::make_widget_cable ();
cmomplug -> xc::MOMPLUG { from_kid'=>childco, ... };
drawable = xc::drawable_of_window window;
fun make_fill (_, NULL ) => (\\ _ = xc::clear_drawable drawable);
make_fill (r, THE c) => fillfn result.relief (drawable, r, c);
end;
fun main (box, color, update)
=
{ fill = make_fill (box, color);
fun handle_co xc::REQ_RESIZE => block_until_mailop_fires (myco xc::REQ_RESIZE);
handle_co xc::REQ_DESTRUCTION => xc::destroy_window cwin;
end;
fun do_mom (xc::ETC_RESIZE ({ col, row, wide, high } ))
=>
{ xc::move_and_resize_window cwin
(child_box ({ wide, high } ));
main ({ col=>0, row=>0, wide, high }, color, FALSE);
};
do_mom (xc::ETC_REDRAW _)
=>
fill ();
do_mom _ => ();
end;
fun loop ()
=
do_one_mailop [
plea' ==> (\\ c = main (box, c, TRUE)),
from_other' ==> loop o do_mom o xc::get_contents_of_envelope,
childco ==> loop o handle_co
];
loop (if update fill (); fi);
};
mr::route_pair (kidplug, momplug, cmomplug);
wg::realize_widget child
{
kidplug => ckidplug,
window => cwin,
window_size => g2d::box::size crect
};
xc::show_window cwin;
main (g2d::box::make (g2d::point::zero, window_size), color, FALSE);
};
fun init_loop color
=
do_one_mailop [
get_from_oneshot' realize_1shot
==>
{. realize_frame #arg color; },
take_from_mailslot' plea_slot
==>
{. init_loop #c; }
];
make_thread "frame" {.
#
init_loop result.background;
};
BORDER { plea_slot,
#
widget => wg::make_widget { root_window,
args => \\ () = { background => NULL },
size_preference_thunk_of => size,
realize_widget => \\ arg = put_in_oneshot (realize_1shot, arg)
}
};
};
fun as_widget (BORDER { widget, ... } )
=
widget;
fun set_color
(BORDER { plea_slot, ... } )
color
=
put_in_mailslot (plea_slot, color);
fun make_border { color, width, child }
=
{ root_window = wg::root_window_of child;
name = wy::make_view { name => wy::style_name ["frame"],
aliases => []
};
args = [ (wa::border_thickness, wa::INT_VAL width) ];
args = case color
#
THE c => (wa::background, wa::COLOR_VAL c) ! args;
NULL => args;
esac;
border (root_window, (name, wg::style_of root_window), args)
child;
};
};
end;