## label.pkg
#
# Label widget.
#
# TODO: XXX SUCKO FIXME
# allow user control over maxc, either in pixels or as character
# Compiled by:
# src/lib/x-kit/widget/xkit-widget.sublib### "I think computer viruses should count as life.
### I think it says something about human nature
### that the only form of life we have created
### so far is purely destructive.
### We've created life in our own image."
###
### -- Stephen Hawking (1942 - )
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 fil = file__premicrothread; # file__premicrothread is from src/lib/std/src/posix/file--premicrothread.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 wt = widget_types; # widget_types is from src/lib/x-kit/widget/old/basic/widget-types.pkgherein
package label
: (weak) Label # Label is from src/lib/x-kit/widget/old/leaf/label.api {
Label_Type = TEXT String
| ICON xc::Ro_Pixmap
;
Plea_Mail
= SET_LABEL Label_Type
#
| SET_BC xc::Rgb
| SET_FC xc::Rgb
#
| GET_SIZE_CONSTRAINT Oneshot_Maildrop( wg::Widget_Size_Preference )
#
| DO_REALIZE
{
kidplug: xc::Kidplug,
window: xc::Window,
window_size: g2d::Size
};
Label_Data
= TEXT_DATA { s: String, rb: Int, lb: Int }
| ICON_DATA xc::Ro_Pixmap
;
Font_Info = FONT_INFO
{
font: xc::Font,
fonta: Int, # font ascent
fontd: Int, # font descent
maxc: Int # max. char width
};
fun make_font_info font
=
{ (xc::font_high font) -> { ascent, descent };
(xc::font_info_of font) -> { max_bounds, ... };
max_bounds -> xc::CHAR_INFO { char_width, ... };
FONT_INFO { font, fonta=>ascent, fontd=>descent, maxc => char_width };
};
fun make_text_label (s, font)
=
{ ((xc::text_extents font s).overall_info )
->
xc::CHAR_INFO { left_bearing=>lb, right_bearing=>rb, ... };
TEXT_DATA { s, lb, rb };
};
Label_View
=
LABEL_VIEW
{
label: Ref( Label_Data ),
fg: Ref( xc::Rgb ),
bg: Ref( xc::Rgb ),
shades: Ref( wg::Shades ),
#
relief: wg::Relief,
border_thickness: Int,
font: Font_Info,
align: wt::Horizontal_Alignment,
#
width: Int,
height: Int,
padx: Int,
pady: Int
};
default_font = "-Adobe-Helvetica-Bold-R-Normal--*-120-*";
attributes
=
[ (wa::halign, wa::HALIGN, wa::HALIGN_VAL wt::HCENTER),
(wa::tile, wa::TILE, wa::NO_VAL),
(wa::label, wa::STRING, wa::STRING_VAL ""),
(wa::border_thickness, wa::INT, wa::INT_VAL 2),
(wa::height, wa::INT, wa::INT_VAL 0),
(wa::width, wa::INT, wa::INT_VAL 0),
(wa::padx, wa::INT, wa::INT_VAL 1),
(wa::pady, wa::INT, wa::INT_VAL 1),
(wa::font, wa::FONT, wa::STRING_VAL default_font),
(wa::relief, wa::RELIEF, wa::RELIEF_VAL wg::FLAT),
(wa::foreground, wa::COLOR, wa::STRING_VAL "black"),
(wa::background, wa::COLOR, wa::STRING_VAL "white")
];
fun label_view (root_window, view, args)
=
{
attributes = wg::find_attribute (wg::attributes (view, attributes, args));
#
align = wa::get_halign (attributes wa::halign);
bw = wa::get_int (attributes wa::border_thickness);
height = wa::get_int (attributes wa::height);
width = wa::get_int (attributes wa::width);
padx = wa::get_int (attributes wa::padx);
pady = wa::get_int (attributes wa::pady);
(make_font_info (wa::get_font (attributes wa::font)))
->
fifi as FONT_INFO { font=>f, ... };
label = ICON_DATA (wa::get_tile (attributes wa::tile))
except
_ = make_text_label (wa::get_string (attributes wa::label), f);
relief = wa::get_relief (attributes wa::relief);
lab = wa::get_string (attributes wa::label);
fg = wa::get_color (attributes wa::foreground);
bg = wa::get_color (attributes wa::background);
shades = wg::shades root_window bg;
LABEL_VIEW {
label => REF label,
fg => REF fg,
bg => REF bg,
shades => REF shades,
relief,
border_thickness => int::max (0, bw),
font => fifi,
align,
width => int::max (0, width),
height => int::max (0, height),
padx => int::max (0, padx),
pady => int::max (0, pady)
};
};
Label = LABEL { widget: wg::Widget,
plea_slot: Mailslot( Plea_Mail )
};
fun bounds lview
=
{ lview -> LABEL_VIEW { border_thickness, width, height, padx, pady, font, ... };
#
fun compute_size (LABEL_VIEW { label => REF (ICON_DATA ro_pixmap), ... } )
=>
{ (xc::size_of_ro_pixmap ro_pixmap)
->
{ wide, high };
w = (width > 0) ?? width :: wide;
h = (height > 0) ?? height :: high;
{ wide=>w, high=>h };
};
compute_size (LABEL_VIEW { label => REF (TEXT_DATA { rb, lb, s } ), ... } )
=>
{ font -> FONT_INFO { fonta, fontd, maxc, ... };
wide = rb - lb;
line_high = fonta + fontd;
w = if (width == 0) wide;
else width*maxc;
fi;
h = if (height > 0) height*line_high;
else line_high;
fi;
{ wide=>w, high=>h };
};
end;
(compute_size lview) -> { wide, high };
col_preference = wg::tight_preference (wide + 2*(border_thickness+padx+1));
row_preference = wg::tight_preference (high + 2*(border_thickness+pady+1));
{ col_preference,
row_preference
};
};
fun update_label (lv as LABEL_VIEW { label, ... }, ICON t)
=>
{ label := ICON_DATA t;
lv;
};
update_label (lv as LABEL_VIEW { label, font=>FONT_INFO { font, ... }, ... }, TEXT s)
=>
{ label := make_text_label (s, font);
lv;
};
end;
fun update_fg (lv as LABEL_VIEW { fg, ... }, c)
=
{ fg := c;
lv;
};
fun update_bg root_window (lv as LABEL_VIEW { bg, shades, ... }, c)
=
{ bg := c;
shades := wg::shades root_window c;
lv;
};
fun draw
(dr, { wide, high } )
(LABEL_VIEW lv)
=
{
lv -> { shades, relief, label, border_thickness, fg, bg, ... };
#
box = { col=>0, row=>0, wide, high };
xoff = border_thickness + lv.padx;
xc::fill_box dr (xc::make_pen [xc::p::FOREGROUND (xc::rgb8_from_rgb *bg)]) box;
case *label
#
ICON_DATA ro_pixmap
=>
{ pen = xc::make_pen [ xc::p::FOREGROUND (xc::rgb8_from_rgb *fg),
xc::p::BACKGROUND (xc::rgb8_from_rgb *bg)
];
(xc::size_of_ro_pixmap ro_pixmap)
->
{ wide=>twid, high=>tht };
sr = { col=>0, row=>0, wide=>twid, high=>tht };
x = case lv.align
#
wt::HLEFT => xoff;
wt::HRIGHT => wide - xoff - twid;
wt::HCENTER => (wide - twid) / 2;
esac;
y = (high - tht) / 2;
pos = { col=>x, row=>y };
xc::bitblt dr pen { from => xc::FROM_RO_PIXMAP ro_pixmap,
from_box => sr,
to_pos => pos
};
();
};
TEXT_DATA { s, lb, rb }
=>
{ lv.font -> FONT_INFO { font, fonta, fontd, ... };
#
pen = xc::make_pen [xc::p::FOREGROUND (xc::rgb8_from_rgb *fg)];
col = case lv.align
#
wt::HLEFT => xoff - lb + 1;
wt::HRIGHT => wide - xoff - rb - 1;
wt::HCENTER => (wide - lb - rb) / 2;
esac;
row = (high + fonta - fontd) / 2;
xc::draw_transparent_string dr pen font ({ col, row }, s);
};
esac;
d3::draw_box dr { box, relief, width=>border_thickness }
*shades;
};
fun realize { kidplug, window, window_size } (root_window, plea_slot, lv)
=
{ (xc::ignore_mouse_and_keyboard kidplug)
->
xc::KIDPLUG { from_other', to_mom, ... };
dr = xc::drawable_of_window window;
fun check_size (label, label', wide, high)
=
case (label, label')
#
(TEXT_DATA { lb, rb, ... }, TEXT_DATA { lb=>lb', rb=>rb', ... } )
=>
if (wide == 0 and rb' - lb' != rb - lb)
#
block_until_mailop_fires (to_mom xc::REQ_RESIZE);
fi;
(ICON_DATA t, ICON_DATA t')
=>
{ size = xc::size_of_ro_pixmap t ;
size' = xc::size_of_ro_pixmap t';
if ((wide == 0 or high == 0) and size != size' )
#
fil::print "resize2\n";
block_until_mailop_fires (to_mom xc::REQ_RESIZE);
fi;
};
_ =>
{ fil::print "resize3\n";
block_until_mailop_fires (to_mom xc::REQ_RESIZE);
};
esac;
fun do_plea (SET_LABEL v, lv)
=>
{ lv -> LABEL_VIEW { label=> REF l, width, height, ... };
#
(update_label (lv, v))
->
lv' as LABEL_VIEW { label => REF l', ... };
check_size (l, l', width, height);
THE lv';
};
do_plea (SET_BC c, lv)
=>
THE (update_bg root_window (lv, c));
do_plea (SET_FC c, lv)
=>
{ update_fg (lv, c);
THE lv;
};
do_plea (GET_SIZE_CONSTRAINT reply_1shot, lv)
=>
{ put_in_oneshot (reply_1shot, bounds lv);
NULL;
};
do_plea _
=>
NULL;
end;
fun do_mom (xc::ETC_REDRAW _, me as (lv, drawf))
=>
{ drawf lv;
me;
};
do_mom (xc::ETC_RESIZE ({ wide, high, ... }: g2d::Box), (lv, _))
=>
(lv, draw (dr, { wide, high } ));
do_mom (_, me)
=>
me;
end;
fun loop (lv, drawf)
=
do_one_mailop [
#
take_from_mailslot' plea_slot
==>
(\\ event = case (do_plea (event, lv))
#
NULL => loop (lv, drawf);
#
THE lv' => { drawf lv';
loop (lv', drawf);
};
esac),
from_other'
==>
(\\ envelope
=
loop (do_mom (xc::get_contents_of_envelope envelope, (lv, drawf))))
];
loop (lv, draw (dr, window_size));
};
fun init (root_window, plea_slot, lv)
=
loop lv
where
fun loop lv
=
case (take_from_mailslot plea_slot)
#
SET_LABEL l => loop (update_label (lv, l));
SET_BC c => loop (update_bg root_window (lv, c));
SET_FC c => loop (update_fg (lv, c));
DO_REALIZE arg => realize arg (root_window, plea_slot, lv);
GET_SIZE_CONSTRAINT reply_1shot => { put_in_oneshot (reply_1shot, bounds lv); loop lv; };
esac;
end;
fun make_label' (args as (root_window, _, _))
=
{ lv = label_view args;
#
plea_slot = make_mailslot ();
fun get_bounds ()
=
{ reply_1shot = make_oneshot_maildrop ();
#
put_in_mailslot (plea_slot, GET_SIZE_CONSTRAINT reply_1shot);
get_from_oneshot reply_1shot;
};
make_thread "label" {.
#
init (root_window, plea_slot, lv);
};
LABEL
{
plea_slot,
widget => wg::make_widget
{ root_window,
args => \\ () = { background => NULL },
size_preference_thunk_of => get_bounds,
realize_widget => \\ arg = put_in_mailslot (plea_slot, DO_REALIZE arg)
}
};
};
fun make_label root_window { label=>caption, font, foreground, background, align }
=
{ name = wy::make_view
{ name => wy::style_name ["label"],
aliases => []
};
args = [ (wa::halign, wa::HALIGN_VAL align),
(wa::label, wa::STRING_VAL caption)
];
args = case font
#
THE f => (wa::font, wa::STRING_VAL f) ! args;
NULL => args;
esac;
args = case foreground
#
THE fc => (wa::foreground, wa::COLOR_VAL fc) ! args;
NULL => args;
esac;
args = case background
#
THE bc => (wa::background, wa::COLOR_VAL bc) ! args;
NULL => args;
esac;
make_label' (root_window, (name, wg::style_of root_window), args);
};
fun as_widget (LABEL { widget, ... } ) = widget;
fun set msg (LABEL { plea_slot, ... } ) arg = put_in_mailslot (plea_slot, msg arg);
set_label = set SET_LABEL;
set_background = set SET_BC;
set_foreground = set SET_FC;
}; # Label
end;