## choice-of-widgets.pkg
#
# Manage a list of widgets
# only one of which is visible
# at any given time.
# Compiled by:
# src/lib/x-kit/widget/xkit-widget.sublib### "The great mystery is not that we should have been
### thrown down here at random between the profusion
### of matter and that of the stars;
###
### it is that from our very prison we should draw,
### from our own selves, images powerful enough
### to deny our nothingness."
###
### -- Andre Malraux
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 li = list_indexing; # list_indexing is from src/lib/x-kit/widget/old/lib/list-indexing.pkg package mr = xevent_mail_router; # xevent_mail_router is from src/lib/x-kit/widget/old/basic/xevent-mail-router.pkgherein
package choice_of_widgets
: (weak) Choice_Of_Widgets # Choice_Of_Widgets is from src/lib/x-kit/widget/old/wrapper/choice-of-widgets.api {
exception NO_WIDGETS;
exception BAD_INDEX = li::BAD_INDEX;
Plea_Mail
#
= SIZE_PREFERENCE
#
| DO_REALIZE {
kidplug: xc::Kidplug,
window: xc::Window,
window_size: g2d::Size
}
| SHOWING Mailslot( Null_Or( Int ) )
| CHILD_COUNT Mailslot( Int )
| SHOW Int
| INSERT (Int, List( wg::Widget ))
| DELETE List( Int )
;
Reply_Mail
= OKAY
| ERROR Exception
;
Choice_Of_Widgets
=
CHOICE_OF_WIDGETS
{ widget: wg::Widget,
#
plea_slot: Mailslot( Plea_Mail ),
reply_slot: Mailslot( Reply_Mail )
};
Child_Widget
=
CHILD_WIDGET
{ widget: wg::Widget,
window: xc::Window,
to_mom: Mailop( xc::Mail_To_Mom )
};
Choice(X)
= EMPTY
| CHOICE {
top: Int,
widget: X,
wlist: List(X)
};
fun cloop co ()
=
{ block_until_mailop_fires co;
cloop co ();
};
fun is_valid (EMPTY, 0) => TRUE;
is_valid (EMPTY, _) => FALSE;
is_valid (CHOICE { wlist, ... }, i) => li::is_valid (wlist, i);
end;
fun top_index EMPTY => NULL;
top_index (CHOICE { top, ... } ) => THE top;
end;
fun topi EMPTY => raise exception lib_base::IMPOSSIBLE "choice_of_widgets::topi";
topi (CHOICE { top, ... } ) => top;
end;
fun top_widget EMPTY => raise exception lib_base::IMPOSSIBLE "choice_of_widgets::topWidget";
top_widget (CHOICE { widget, ... } ) => widget;
end;
fun top_window EMPTY => raise exception lib_base::IMPOSSIBLE "choice_of_widgets::topWin";
top_window (CHOICE { widget=>CHILD_WIDGET { window, ... }, ... } ) => window;
end;
fun child_count EMPTY => 0;
child_count (CHOICE { wlist, ... } ) => length wlist;
end;
stipulate
#
default_length_preference
=
wg::INT_PREFERENCE
{
start_at => 1,
step_by => 1,
#
min_steps => 0,
best_steps => 0,
max_steps => NULL
};
herein
#
default_size_preference
=
{ col_preference => default_length_preference,
row_preference => default_length_preference
};
end;
fun size_preference f (CHOICE { widget, ... } ) => f widget;
size_preference f EMPTY => default_size_preference;
end;
fun delete_w (EMPTY, _)
=>
raise exception BAD_INDEX;
delete_w (CHOICE { wlist, top, widget }, indices)
=>
{
indices = li::check_sort indices;
case (li::delete (wlist, indices))
([], dlist)
=>
(EMPTY, dlist);
(wlist', dlist)
=>
case (li::pre_indices (top, indices) )
#
NULL => (CHOICE { wlist=>wlist', top=> 0, widget => head wlist'}, dlist);
THE j => (CHOICE { wlist=>wlist', top=> top-j, widget }, dlist);
esac;
esac;
}
except
_ = raise exception BAD_INDEX;
end;
# insert_w:
# Assume wl != []
#
fun insert_w (EMPTY, 0, wl)
=>
CHOICE { wlist=>wl, top=>0, widget=> head wl };
insert_w (EMPTY, _, _)
=>
raise exception BAD_INDEX;
insert_w (CHOICE { wlist, top, widget }, index, wl)
=>
{ wlist' = li::set (wlist, index, wl);
top' = index <= top ?? top + (length wl)
:: top;
CHOICE { wlist=>wlist', top=>top', widget };
}
except
_ = raise exception BAD_INDEX;
end;
fun make_vis (EMPTY, _)
=>
raise exception BAD_INDEX;
make_vis (CHOICE { wlist, ... }, i)
=>
{ w = list::nth (wlist, i);
(CHOICE { wlist, top=>i, widget=>w }, w);
}
except
_ = raise exception BAD_INDEX;
end;
fun make_real (mkr, EMPTY)
=>
EMPTY;
make_real (mkr, CHOICE { top, widget, wlist } )
=>
{ wl = map mkr wlist;
CHOICE { top, wlist => wl, widget => list::nth (wl, top) };
};
end;
fun destroy (CHILD_WIDGET { window, to_mom, ... } )
=
{ xc::destroy_window window;
make_thread "choice_of_widgets destroy" (cloop to_mom);
();
};
fun make_choice_of_widgets root_window widgets
=
{ reply_slot = make_mailslot ();
plea_slot = make_mailslot ();
size_slot = make_mailslot ();
plea' = take_from_mailslot' plea_slot;
fun make_coevt EMPTY
=>
cat_mailops [];
make_coevt (CHOICE { wlist, ... } )
=>
cat_mailops (make_l (wlist, 0))
where
fun make_mailop (CHILD_WIDGET { to_mom, ... }, i)
=
to_mom ==> {. (i, #mailop); };
fun make_l ([], _) => [];
make_l (w ! wl, i) => (make_mailop (w, i)) ! (make_l (wl, i+1));
end;
end;
end;
fun realize
{ kidplug => kidplug as xc::KIDPLUG { to_mom, ... },
window,
window_size => given_size
}
widgets
=
{ me = make_real (make_real' given_size, widgets);
{ (top_widget me) # Dr David Benson's resize bugfix (SML/NJ 110.59).
->
CHILD_WIDGET { window, widget, ... };
xc::configure_window window
[
xc::c::STACK_MODE xc::ABOVE,
xc::c::SIZE given_size
];
if (not (wg::okay_size (widget, given_size)))
#
block_until_mailop_fires (to_mom xc::REQ_RESIZE);
fi;
};
main (given_size, me);
}
where
(xc::make_widget_cable ())
->
{ kidplug => my_kidplug,
momplug => my_momplug
};
my xc::KIDPLUG { from_other', ... }
=
xc::ignore_mouse_and_keyboard my_kidplug;
router = mr::make_xevent_mail_router (kidplug, my_momplug, []);
size_preference'
=
size_preference
(\\ CHILD_WIDGET { widget, ... }
=
wg::size_preference_of widget
);
fun make_real' window_size
=
{ box = g2d::box::make (g2d::point::zero, window_size);
\\ widget
=
{ cwin = wg::make_child_window (window, box, wg::args_of widget);
(xc::make_widget_cable ())
->
{ kidplug => ckidplug,
momplug => cmomplug as xc::MOMPLUG { from_kid', ... }
};
mr::add_child router (cwin, cmomplug);
xc::configure_window cwin [xc::c::STACK_MODE xc::BELOW];
wg::realize_widget widget { kidplug=>ckidplug, window=>cwin, window_size };
xc::show_window cwin;
CHILD_WIDGET {
widget,
window => cwin,
to_mom => from_kid'
};
};
};
fun zombie me
=
loop()
where
childco = make_coevt me;
fun do_plea (SHOWING rslot) => put_in_mailslot (rslot, top_index me);
do_plea (CHILD_COUNT rslot) => put_in_mailslot (rslot, child_count me);
do_plea SIZE_PREFERENCE => put_in_mailslot (size_slot, size_preference' me);
do_plea _ => ();
end;
fun loop ()
=
for (;;) {
do_one_mailop [
plea' ==> do_plea,
from_other' ==> (\\ _ = ()),
childco ==> (\\ _ = ())
];
};
end;
# FIX child pleads for own death XXX BUGGO FIXME
#
fun handle_co (me, i, xc::REQ_RESIZE)
=>
case (top_index me)
THE j => if (i == j) block_until_mailop_fires (to_mom xc::REQ_RESIZE); fi;
NULL => ();
esac;
handle_co (_, _, xc::REQ_DESTRUCTION)
=>
();
end;
fun do_mom (me, xc::ETC_RESIZE ({ col, row, wide, high } ))
=>
{ size = { wide, high };
{ window = top_window me;
xc::resize_window window size;
}
except
_ = ();
main (size, me);
};
do_mom (_, xc::ETC_CHILD_DEATH w) => mr::del_child router w;
do_mom (me, xc::ETC_OWN_DEATH) => zombie me;
do_mom _ => ();
end
also
fun main (given_size, me)
=
loop ()
where
childco = make_coevt me;
fun do_plea (SHOWING reply_slot) => put_in_mailslot (reply_slot, top_index me);
do_plea (CHILD_COUNT reply_slot) => put_in_mailslot (reply_slot, child_count me);
do_plea SIZE_PREFERENCE => put_in_mailslot ( size_slot, size_preference' me);
do_plea (SHOW i)
=>
{ my (me', CHILD_WIDGET { window, widget, ... } )
=
make_vis (me, i);
xc::configure_window window [xc::c::STACK_MODE xc::ABOVE, xc::c::SIZE given_size];
if (not (wg::okay_size (widget, given_size)))
#
block_until_mailop_fires (to_mom xc::REQ_RESIZE);
fi;
put_in_mailslot (reply_slot, OKAY);
main (given_size, me');
}
except e = put_in_mailslot (reply_slot, ERROR e);
do_plea (DELETE indices)
=>
{ my (me', dlist)
=
delete_w (me, indices);
my CHILD_WIDGET { window, ... }
=
top_widget me;
put_in_mailslot (reply_slot, OKAY);
{ my CHILD_WIDGET { window=>window', widget, ... }
=
top_widget me';
if (not (xc::same_window (window, window')))
xc::configure_window window' [xc::c::STACK_MODE xc::ABOVE, xc::c::SIZE given_size];
if (not (wg::okay_size (widget, given_size)))
#
block_until_mailop_fires (to_mom xc::REQ_RESIZE);
fi;
fi;
}
except _ = block_until_mailop_fires (to_mom xc::REQ_RESIZE);
apply destroy dlist;
main (given_size, me');
}
except e = put_in_mailslot (reply_slot, ERROR e);
do_plea (INSERT (index, wl))
=>
if (is_valid (me, index))
#
case (top_index me)
#
NULL =>
{ size' = wg::preferred_size (head wl);
me' = insert_w (me, index, map (make_real' size') wl);
put_in_mailslot (reply_slot, OKAY);
block_until_mailop_fires (to_mom xc::REQ_RESIZE);
main (size', me');
};
_ => { me' = insert_w (me, index, map (make_real' given_size) wl);
put_in_mailslot (reply_slot, OKAY);
main (given_size, me');
}
except e = put_in_mailslot (reply_slot, ERROR e);
esac;
else
put_in_mailslot (reply_slot, ERROR BAD_INDEX);
fi
except e = put_in_mailslot (reply_slot, ERROR e);
do_plea _ => ();
end;
fun loop ()
=
for (;;) {
do_one_mailop [
plea' ==> do_plea,
from_other' ==> (\\ mail = do_mom (me, xc::get_contents_of_envelope mail)),
childco ==> (\\ (child, cevt) = handle_co (me, child, cevt))
];
};
end;
end; # fun realize
size_preference'
=
size_preference
(\\ widget
=
wg::size_preference_of widget
);
fun init_loop me
=
{ case (take_from_mailslot plea_slot)
#
SHOWING reply_slot => put_in_mailslot (reply_slot, top_index me);
CHILD_COUNT reply_slot => put_in_mailslot (reply_slot, child_count me);
SIZE_PREFERENCE => put_in_mailslot ( size_slot, size_preference' me);
DO_REALIZE arg
=>
realize arg me;
SHOW i
=>
{ my (me', _) = make_vis (me, i);
put_in_mailslot (reply_slot, OKAY);
init_loop me';
}
except e = put_in_mailslot (reply_slot, ERROR e);
INSERT (index, wl)
=>
{ me' = insert_w (me, index, wl);
put_in_mailslot (reply_slot, OKAY);
init_loop me';
}
except e = put_in_mailslot (reply_slot, ERROR e);
DELETE indices
=>
{ me' = #1 (delete_w (me, indices));
put_in_mailslot (reply_slot, OKAY);
init_loop me';
}
except e = put_in_mailslot (reply_slot, ERROR e);
esac;
init_loop me;
};
case widgets
#
[] => make_thread "choice_of_widgets init 1" {. init_loop EMPTY; };
w ! _ => make_thread "choice_of_widgets init 2" {. init_loop (CHOICE { top=>0, widget=>w, wlist=>widgets } ); };
esac;
CHOICE_OF_WIDGETS
{
reply_slot,
plea_slot,
#
widget
=>
wg::make_widget {
root_window,
args => \\ () = { background => NULL },
size_preference_thunk_of => \\ () = { put_in_mailslot (plea_slot, SIZE_PREFERENCE); take_from_mailslot size_slot;},
realize_widget => \\ arg = put_in_mailslot (plea_slot, DO_REALIZE arg)
}
};
};
fun choice_of_widgets (root_window, view, _) widgets
=
make_choice_of_widgets root_window widgets;
fun as_widget (CHOICE_OF_WIDGETS { widget, ... } )
=
widget;
fun showing (CHOICE_OF_WIDGETS { plea_slot, ... } )
=
{ reply_slot = make_mailslot ();
#
put_in_mailslot (plea_slot, SHOWING reply_slot);
case (take_from_mailslot reply_slot)
#
THE i => i;
NULL => raise exception NO_WIDGETS;
esac;
};
fun child_count (CHOICE_OF_WIDGETS { plea_slot, ... } )
=
{ reply_slot = make_mailslot ();
#
put_in_mailslot (plea_slot, CHILD_COUNT reply_slot);
take_from_mailslot reply_slot;
};
stipulate
fun command wrapfn (CHOICE_OF_WIDGETS { plea_slot, reply_slot, ... } )
=
\\ arg = { put_in_mailslot (plea_slot, wrapfn arg);
#
case (take_from_mailslot reply_slot)
#
OKAY => ();
ERROR e => raise exception e;
esac;
};
herein
show = command SHOW;
insert' = command INSERT;
fun insert choice_of_widgets (i,[]) => ();
insert choice_of_widgets arg => insert' choice_of_widgets arg;
end;
fun append choice_of_widgets (i, bl)
=
insert choice_of_widgets (i+1, bl);
delete' = command DELETE;
fun delete choice_of_widgets [] => ();
delete choice_of_widgets arg => delete' choice_of_widgets arg;
end;
end;
}; # package choice_of_widgets
end;