## textlist.pkg
#
# See also: The Selectable List from Appendix C of
# Revitalizing eXene
# http://mythryl.org/pub/exene/matt-thesis.pdf
#
# Compiled by:
# src/lib/x-kit/widget/xkit-widget.sublib# List widget, for text lists.
#
# NOTE: with the value restriction, it might be better to code this
# as a generic. XXX SUCKO FIXME
### "Since the invention of the microprocessor, the
### cost of moving a byte of information around has
### fallen on the order of 10-million-fold.
###
### "Never before in the human history has any product
### or service gotten 10 million times cheaper -- much
### less in the course of a couple decades.
###
### "That's as if a 747 plane, once at $150 million apiece,
### could now be bought for about the price of a large pizza."
###
### -- Michael Rothschild
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 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 wt = widget_types; # widget_types is from src/lib/x-kit/widget/old/basic/widget-types.pkg #
package d3 = three_d; # three_d is from src/lib/x-kit/widget/old/lib/three-d.pkg package ti = item_list; # item_list is from src/lib/x-kit/widget/old/leaf/item-list.pkg package li = list_indexing; # list_indexing is from src/lib/x-kit/widget/old/lib/list-indexing.pkg #
herein
package textlist
: (weak) Textlist # Textlist is from src/lib/x-kit/widget/old/leaf/textlist.api {
exception BAD_INDEX
=
ti::BAD_INDEX;
Textlist_Item(X)
=
( String, # String to display on this line of widget.
X, # Value to return when this line is clicked by user.
wt::Button_State # Initial state of line: (in/active, de/selected).
);
fun make_textlist_item x
=
x;
List_Event(X) = SET(X)
| UNSET(X);
Result = OKAY
| ERROR Exception
;
Input = BUTTON (xc::Mousebutton, g2d::Point);
# Input imp.
#
# At present it simply reports button down
# with which button and where.
#
fun input (m, in_slot)
=
loop ()
where
fun loop ()
=
case (xc::get_contents_of_envelope (block_until_mailop_fires m))
#
xc::MOUSE_FIRST_DOWN { mouse_button, window_point, ... }
=>
{ put_in_mailslot (in_slot, BUTTON (mouse_button, window_point));
wait_up ();
};
_ => loop ();
esac
also
fun wait_up ()
=
case (xc::get_contents_of_envelope (block_until_mailop_fires m))
#
xc::MOUSE_LAST_UP _ => loop ();
_ => wait_up ();
esac;
end;
Plea_Mail(X)
= GET_SIZE_CONSTRAINT Oneshot_Maildrop( wg::Widget_Size_Preference )
#
| SET_CHOSEN (List ((Int, Bool)), Oneshot_Maildrop( Result ))
| SET_ACTIVE (List ((Int, Bool)), Oneshot_Maildrop( Result ))
#
| INSERT ((Int, List ((String, X))), Oneshot_Maildrop( Result ))
| DELETE (List( Int ), Oneshot_Maildrop( Result ))
#
| GET_CHOSEN Oneshot_Maildrop( List( Int ) )
| GET_STATE Oneshot_Maildrop( List( wt::Button_State ) )
#
| DO_REALIZE { kidplug: xc::Kidplug,
window: xc::Window,
window_size: g2d::Size
}
;
Item(X)
=
{ label: String, # Label of item
lb: Int, # Left bearing of label.
wid: Int, # Width in pixels of label.
value: X # Value of item.
};
Textlist(X)
=
TEXTLIST
{ widget: wg::Widget,
plea_slot: Mailslot( Plea_Mail(X) ),
textlist_change': Mailop( List_Event(X) )
};
default_font = "-Adobe-Helvetica-Bold-R-Normal--*-120-*";
# Standard font information
#
fun make_font_info font
=
{ (xc::font_high font)
->
{ ascent => font_ascent,
descent => font_descent
};
(font, font_ascent, font_descent);
};
# x and y increments for scrolling and drawing
# x increment is nominally the width of "0", which doesn't
# work for non-constant width fonts.
# y increment is height of item
#
fun set_xincr font
=
xc::text_width font "0";
fun set_yincr ((_, font_ascent, font_descent), bw)
=
1 + font_ascent + font_descent + 2*bw;
attributes
=
[
# (wa::attribute_multiset, wa::BOOL, wa::BOOL_VAL FALSE),
# (wa::attribute_isVertical,wa::BOOL, wa::BOOL_VAL TRUE),
# (wa::halign, wa::HALIGN, wa::HALIGN_VAL wg::HLeft),
(wa::border_thickness, wa::INT, wa::INT_VAL 2),
(wa::font, wa::FONT, wa::STRING_VAL default_font),
(wa::color, wa::COLOR, wa::NO_VAL),
(wa::relief, wa::RELIEF, wa::RELIEF_VAL wg::FLAT),
(wa::width, wa::INT, wa::INT_VAL 0),
(wa::height, wa::INT, wa::INT_VAL 0),
(wa::background, wa::COLOR, wa::STRING_VAL "white"),
(wa::foreground, wa::COLOR, wa::STRING_VAL "black"),
(wa::select_border_thickness, wa::INT, wa::INT_VAL 1)
];
color_attributes
=
[ (wa::select_background, wa::COLOR, wa::STRING_VAL "gray"),
(wa::select_foreground, wa::COLOR, wa::STRING_VAL "black")
];
mono_attributes
=
[
(wa::select_background, wa::COLOR, wa::STRING_VAL "black"),
(wa::select_foreground, wa::COLOR, wa::STRING_VAL "white")
];
Result
=
{ multi: Bool,
shades: wg::Shades,
fontinfo: (xc::Font, Int, Int),
#
fg: xc::Rgb,
bg: xc::Rgb,
sel_fg: xc::Rgb,
#
relief: wg::Relief,
border_thickness: Int,
maxslen: Ref( Int ),
stipple: xc::Ro_Pixmap,
#
xincr: Int,
yincr: Int,
width: Int,
height: Int,
#
sel_shades: wg::Shades,
sel_border_thickness: Int
};
State(X)
=
{ items: ti::Items( Item(X) ),
top: Int,
line_count: Int
};
fun make_result (root, view, args)
=
{ attributes
=
(wg::is_monochrome root)
?? mono_attributes @ attributes
:: color_attributes @ attributes;
attributes
=
wg::find_attribute (wg::attributes (view, attributes, args));
(make_font_info (wa::get_font (attributes wa::font)))
->
fontinfo as (f, _, _);
relief = wa::get_relief (attributes wa::relief);
border_thickness = wa::get_int (attributes wa::border_thickness );
sborder_width = wa::get_int (attributes wa::select_border_thickness);
forec = wa::get_color (attributes wa::foreground);
backc = wa::get_color (attributes wa::background);
sforec = wa::get_color (attributes wa::select_foreground);
sbackc = wa::get_color (attributes wa::select_background);
{ multi => FALSE,
fontinfo,
height => int::max (0, wa::get_int (attributes wa::height)),
width => int::max (0, wa::get_int (attributes wa::width)),
maxslen => REF 0,
stipple => wg::ro_pixmap root "gray",
xincr => set_xincr (#1 fontinfo),
yincr => set_yincr (fontinfo, sborder_width),
fg => forec,
bg => backc,
shades => wg::shades root backc,
border_thickness => int::max (border_thickness, 0),
sel_shades => wg::shades root sbackc,
sel_fg => sforec,
sel_border_thickness => int::max (sborder_width, 0),
relief
};
};
fun make_item' (result: Result)
=
make_item
where
result.fontinfo -> (font, _, _);
fun make_item (str, v)
=
{ (.overall_info (xc::text_extents font str))
->
xc::CHAR_INFO { left_bearing=>lb, right_bearing=>rb, ... };
{ label => str, lb, wid => rb - lb, value => v };
};
end;
fun make_items
( result: Result,
event_slot,
items: List( Textlist_Item(X) )
)
=
{ fun make_item i
=
make_item' result i;
maxslen = list::fold_forward
(\\ ((s, _, _), m) = int::max (m, size s))
0
items;
fun mki (s, v, state)
=
(make_item (s, v), state);
fun pickfn ( { value, ... } : Item(X), TRUE) => put_in_mailslot (event_slot, SET value);
pickfn ( { value, ... } : Item(X), _) => put_in_mailslot (event_slot, UNSET value);
end;
result.maxslen := maxslen;
ti::items
{
items => map mki items,
multiple => result.multi,
pickfn
};
};
fun size_preference_thunk_of (result as { yincr, xincr, maxslen, ... } : Result, items)
=
{ count = ti::vals_count items;
#
xbase = 2*(result.border_thickness + result.sel_border_thickness);
my (xmin, xnat, xmax)
=
case result.width
#
0 => (1, *maxslen+1, NULL );
w => (w, w, THE w);
esac;
col_preference
=
wg::INT_PREFERENCE { start_at=>xbase, step_by=>xincr, min_steps=>xmin, best_steps=>xnat, max_steps=>xmax };
ybase = 2*result.border_thickness;
# This changes once we have scroll bars. XXX BUGGO FIXME
my (ymin, ynat, ymax)
=
case result.height
#
0 => (count, count, THE count );
height => (height, height, THE height);
esac;
row_preference
=
wg::INT_PREFERENCE { start_at=>ybase, step_by=>yincr, min_steps=>ymin, best_steps=>ynat, max_steps=>ymax };
{ col_preference, row_preference };
};
fun drawfns (result: Result, window)
=
(draw, update)
where
fun is_active (wt::ACTIVE _) => TRUE;
is_active _ => FALSE;
end;
fun is_on ( wt::ACTIVE v) => v;
is_on (wt::INACTIVE v) => v;
end;
dr = xc::drawable_of_window window;
bw = result.border_thickness;
txt_pen = xc::make_pen [xc::p::FOREGROUND (xc::rgb8_from_rgb result.fg)];
i_txt_pen = xc::clone_pen (txt_pen,
[xc::p::FILL_STYLE_STIPPLED, xc::p::STIPPLE result.stipple]);
sel_txt_pen = xc::make_pen [xc::p::FOREGROUND (xc::rgb8_from_rgb result.sel_fg)];
i_sel_txt_pen = xc::clone_pen (txt_pen,
[xc::p::FILL_STYLE_STIPPLED, xc::p::STIPPLE result.stipple]);
fun draw_item (clr, bw, { wide, high } )
=
d
where
sbw = result.sel_border_thickness;
row_incr = result.yincr;
result.sel_shades -> selshades as { base=>selbase, ... };
result.shades -> { base, ... };
result.fontinfo -> (font, font_ascent, _);
inset = bw + sbw + (result.xincr / 2);
iwid = wide - 2*bw;
fun d (( { label, lb, ... } : Item(X), st), row)
=
{ r = { col=>bw, row, wide=>iwid, high=>row_incr };
row_t = row + font_ascent + sbw;
col_t = inset - lb;
if (is_on st)
tpen = if (is_active st) sel_txt_pen;
else i_sel_txt_pen;
fi;
xc::fill_box dr selbase r;
xc::draw_transparent_string dr tpen font ({ col=>col_t, row=>row_t }, label);
d3::draw_box dr
{ box=>r, width=>sbw, relief=>d3::RAISED } selshades;
else
tpen = if (is_active st) txt_pen;
else i_txt_pen;
fi;
if clr xc::fill_box dr base r; fi;
xc::draw_transparent_string dr tpen font ({ col=>col_t, row=>row_t }, label);
fi;
row + row_incr;
};
end;
# Update items given by list of integers.
# Assume the list is sorted:
#
fun update (me: State(X), cl, size)
=
draw (strip cl)
where
me -> { items, top, line_count };
bot = top + line_count;
bw = result.border_thickness;
yincr = result.yincr;
draw_item = \\ i = draw_item (TRUE, bw, size) i;
fun strip [] => [];
strip (l as (i ! t)) => if (i < top) strip t; else l;fi;
end;
fun loop (_, _,[], _) => ();
loop([], _, _, _) => ();
loop (i ! t, j, l ! ls, y)
=>
if (i >= bot ) ();
elif (i > j) loop (i ! t, j+1, ls, y+yincr);
else draw_item (l, y);
loop (t, j+1, ls, y+yincr);
fi;
end;
fun draw []
=>
();
draw [i]
=>
if (i < bot)
draw_item (ti::item (items, i), bw+yincr*(i-top));
();
fi;
draw (l as (i ! t))
=>
if (i < bot)
loop (l, i, ti::vals_list (items, i, bot-i), bw+yincr*(i-top));
fi;
end;
end;
# Redraw entire widget:
#
fun draw ( { items, top, line_count } : State(X), size as { wide, high } )
=
{ box = { col=>0, row=>0, wide, high };
relief = result.relief;
bw = result.border_thickness;
result.shades -> shades as { base, ... };
il = ti::vals_list (items, top, line_count);
draw_item = \\ i = draw_item (FALSE, bw, size) i;
xc::fill_box dr base box;
list::fold_forward draw_item bw il;
d3::draw_box dr { box, relief, width=>bw } shades;
};
end;
# Returns whether to send a plea for size change.
# At present, we only do this if height attribute is 0,
# meaning the user has not specified a fixed height, so
# we try to fit the total number of items.
#
fun new_size ( { height, ... } : Result, _)
=
height == 0;
# Translate a point in window coordinates to
# the index of an item. The y value must actually lie
# within the item; we don't care about the x.
#
fun pt_to_index ({ col, row }, result: Result, top, vals_count)
=
{ row' = (row - result.border_thickness) / result.yincr;
index = row' + top;
if (row' < 0 or index >= vals_count) NULL;
else THE index;
fi;
};
# Given a window size, compute how many items can be displayed.
#
fun get_num_lines ({ border_thickness, yincr, ... }: Result, { high, ... }: g2d::Size)
=
int::max (0, (high - 2*border_thickness) / yincr);
# Generate a list of length len of consecutive integers
# starting at start.
#
fun genl (start, len)
=
loop (start, len,[])
where
fun loop (_, 0, l) => reverse l;
loop (i, len, l) => loop (i+1, len - 1, i ! l);
end;
end;
fun update_max (items: ti::Items (Item(X)), maxslen)
=
maxslen := ti::revfold (\\ ( { label, ... }, m) => int::max (m, size label); end ) 0 items;
# Given the current top, the number of lines in the window,
# the new number of items, and the list of items that have
# been deleted, compute the new top and also whether the
# window needs to be redisplayed.
#
fun top_on_delete (top, line_count, item_count, l)
=
{
l = li::check_sort l;
fun prei (count,[])
=>
(count, []);
prei (arg as (count, i ! t))
=>
if (i < top) prei (count+1, t);
else arg;
fi;
end;
my (count, dl) = prei (0, l);
top' = top - count;
case dl
[] => (top', FALSE);
(i ! _) => if (i >= top + line_count ) (top', FALSE);
elif (top' + line_count <= item_count ) (top', TRUE);
else (int::max (0, item_count - line_count), TRUE);
fi;
esac;
};
fun realize ( { kidplug, window, window_size => size' }, result, items, plea')
=
{ (xc::ignore_keyboard kidplug)
->
xc::KIDPLUG { from_other', to_mom, from_mouse', from_keyboard' };
in_slot = make_mailslot ();
in' = take_from_mailslot' in_slot;
(drawfns (result, window))
->
(draw, update);
size' = REF size';
fun set_chosen (l, { items, top, line_count } )
=
{ (ti::set_chosen (items, l))
->
(items', optp);
me' = { items=>items', top, line_count };
l = map (\\ (i, _) = i) l;
l = case optp
THE i => i ! l;
NULL => l;
esac;
update (me', li::check_usort l, *size');
me';
};
fun do_plea (GET_SIZE_CONSTRAINT reply_1shot, me as { items, top, line_count } )
=>
{ put_in_oneshot (reply_1shot, size_preference_thunk_of (result, items));
me;
};
do_plea (GET_CHOSEN reply_1shot, me)
=>
{ put_in_oneshot (reply_1shot, ti::get_chosen me.items);
me;
};
do_plea (GET_STATE reply_1shot, me)
=>
{ put_in_oneshot (reply_1shot, ti::get_state me.items);
me;
};
do_plea (SET_ACTIVE (l, reply_1shot), me)
=>
{ items' = ti::set_active (me.items, l);
#
me' = { items=>items', top => me.top, line_count => me.line_count };
put_in_oneshot (reply_1shot, OKAY);
update (me', li::check_usort (map (\\ (i, _) = i) l), *size');
me';
}
except e
=
{ put_in_oneshot (reply_1shot, ERROR e);
me;
};
do_plea (SET_CHOSEN (l, reply_1shot), me)
=>
{ me' = set_chosen (l, me);
put_in_oneshot (reply_1shot, OKAY); me';
}
except e
=
{ put_in_oneshot (reply_1shot, ERROR e);
me;
};
do_plea (INSERT((i, l), reply_1shot), me as { top, items, line_count } )
=>
{ maxslen = list::fold_forward (\\ ((s, _), m) = int::max (m, size s)) 0 l;
items' = ti::set (items, i, map (make_item' result) l);
item_count' = ti::vals_count items';
count = length l;
bot = top + line_count;
my (top', redraw)
=
if (i < top) (top + count, FALSE);
elif (i >= bot) (top, FALSE);
else (top, TRUE);
fi;
me' = { items=>items', top => top', line_count };
put_in_oneshot (reply_1shot, OKAY);
if (new_size (result, items') )
#
block_until_mailop_fires (to_mom xc::REQ_RESIZE);
fi;
if redraw
update (me', genl (i, int::min (bot-i, item_count'-i)),*size');
fi;
result.maxslen := maxslen;
me';
}
except e
=
{ put_in_oneshot (reply_1shot, ERROR e);
me;
};
do_plea (DELETE (arg, reply_1shot), me as { top, items, line_count } )
=>
{ items' = ti::delete (items, arg);
item_count' = ti::vals_count items';
(top_on_delete (top, line_count, item_count', arg))
->
(top', redraw);
me' = { items=>items', top => top', line_count };
put_in_oneshot (reply_1shot, OKAY);
if (new_size (result, items'))
#
block_until_mailop_fires (to_mom xc::REQ_RESIZE);
fi;
redraw ?: draw (me', *size');
update_max (items', result.maxslen);
me';
}
except e
=
{ put_in_oneshot (reply_1shot, ERROR e);
me;
};
do_plea (_, me)
=>
me;
end;
fun do_in (BUTTON (but, pt), me)
=
{ fun on_off (xc::MOUSEBUTTON 1) => TRUE;
on_off _ => FALSE;
end;
case (pt_to_index (pt, result, me.top, ti::vals_count me.items))
#
THE index => set_chosen ([(index, on_off but)], me);
NULL => me;
esac;
};
fun do_mom (xc::ETC_RESIZE ({ wide, high, ... }: g2d::Box), { items, top, line_count } )
=>
{ newsz = { wide, high };
#
line_count = get_num_lines (result, newsz);
size' := newsz;
{ items, top, line_count };
};
do_mom (xc::ETC_REDRAW _, me)
=>
{ draw (me,*size');
me;
};
do_mom (_, me)
=>
me;
end;
fun main me
=
do_one_mailop [
plea' ==> (\\ r = main (do_plea (r, me))),
from_other' ==> (\\ envelope = main (do_mom (xc::get_contents_of_envelope envelope, me))),
in' ==> (\\ i = main (do_in (i, me)))
];
make_thread "textlist from_mouse" {.
#
input (from_mouse', in_slot);
};
main { items, top=>0, line_count=>get_num_lines (result, *size') };
};
fun init (result, items, plea')
=
loop items
where
fun do_plea (GET_SIZE_CONSTRAINT reply_1shot, items)
=>
{ put_in_oneshot (reply_1shot, size_preference_thunk_of (result, items));
items;
};
do_plea (GET_CHOSEN reply_1shot, items)
=>
{ put_in_oneshot (reply_1shot, ti::get_chosen items);
items;
};
do_plea (GET_STATE reply_1shot, me)
=>
{ put_in_oneshot (reply_1shot, ti::get_state items);
items;
};
do_plea (SET_CHOSEN (l, reply_1shot), items)
=>
{ (ti::set_chosen (items, l))
->
(items', _);
put_in_oneshot (reply_1shot, OKAY);
items';
}
except e = { put_in_oneshot (reply_1shot, ERROR e); items; };
do_plea (SET_ACTIVE (l, reply_1shot), items)
=>
{ items' = ti::set_active (items, l);
#
put_in_oneshot (reply_1shot, OKAY);
items';
}
except e = { put_in_oneshot (reply_1shot, ERROR e);
items;
};
do_plea (INSERT ((i, il), reply_1shot), items)
=>
{ items' = ti::set (items, i, map (make_item' result) il);
maxslen = list::fold_forward
(\\ ((s, _), m) = int::max (m, size s))
0
il;
put_in_oneshot (reply_1shot, OKAY);
result.maxslen := maxslen;
items';
}
except e = { put_in_oneshot (reply_1shot, ERROR e);
items;
};
do_plea (DELETE (arg, reply_1shot), items)
=>
{ items' = ti::delete (items, arg);
#
update_max (items', result.maxslen);
put_in_oneshot (reply_1shot, OKAY);
items';
}
except e = { put_in_oneshot (reply_1shot, ERROR e);
items;
};
do_plea (DO_REALIZE arg, items)
=>
realize (arg, result, items, plea');
end;
fun loop items
=
loop (do_plea (block_until_mailop_fires plea', items));
end;
fun make_textlist (root_window, view, args) items
=
{ event_slot = make_mailslot ();
plea_slot = make_mailslot ();
result = make_result (root_window, view, args);
items = make_items (result, event_slot, items);
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 "textlist" {.
init ( result,
items,
take_from_mailslot' plea_slot
);
};
TEXTLIST
{ plea_slot,
#
widget => w,
textlist_change'
=>
take_from_mailslot' event_slot
};
};
fun textlist_change'_of (TEXTLIST { textlist_change', ... } )
=
textlist_change';
fun as_widget (TEXTLIST { widget, ... } )
=
widget;
fun set_f f (TEXTLIST { plea_slot, ... } ) arg
=
{ reply_1shot = make_oneshot_maildrop ();
put_in_mailslot (plea_slot, f (arg, reply_1shot));
case (get_from_oneshot reply_1shot)
#
OKAY => ();
ERROR e => raise exception e;
esac;
};
fun set_textlist_selections l
=
set_f SET_CHOSEN l;
fun set_textlist_active_items l
=
set_f SET_ACTIVE l;
fun insert l = set_f INSERT l;
fun delete l = set_f DELETE l;
fun append tl (i, items)
=
insert tl (i+1, items);
fun get_f f (TEXTLIST { plea_slot, ... } )
=
{ reply_1shot = make_oneshot_maildrop ();
#
put_in_mailslot (plea_slot, f reply_1shot);
get_from_oneshot reply_1shot;
};
fun get_textlist_selections l
=
get_f GET_CHOSEN l;
fun get_textlist_item_states l
=
get_f GET_STATE l;
}; # package textlist
end;