# ***********************************************************************
#
# Project: sml/Tk: an Tk Toolkit for sml
# Author: Stefan Westmeier, University of Bremen
#
# $Date: 2001/03/30 13:39:03 $
# $Revision: 3.0 $
#
# Purpose of this file: Functions related to Canvas Items
#
# ***********************************************************************
# Compiled by:
# src/lib/tk/src/tk.sublibpackage canvas_item
: (weak) Canvas_Item # Canvas_Item is from src/lib/tk/src/canvas_item.api{
stipulate
include package basic_tk_types;
include package basic_utilities;
herein
exception CANVAS_ITEM String;
Widget_Pack_Fun = Bool -> Tcl_Path -> Int_Path -> Null_Or( Bool ) -> Widget ->
String;
Widget_Add_Fun = List( Widget ) -> Widget -> Widget_Path -> List( Widget );
Widget_Del_Fun = List( Widget ) -> Widget_Id -> Widget_Path -> List( Widget );
Widget_Upd_Fun = List( Widget ) -> Widget_Id -> Widget_Path -> Widget -> List( Widget );
Get_Val_Fun = String -> String;
Widget_Del_Func = Widget_Id -> Void;
Widget_Add_Func = Window_Id -> Widget_Path -> Widget -> Void;
fun sel_canvas_wid_id (CANVAS { widget_id, ... } ) => widget_id;
sel_canvas_wid_id _ =>
raise exception WIDGET "canvas_item::selCanvasId applied to non-Canvas Widget"; end;
fun get_canvas_scrollbars (CANVAS { scrollbars, ... } ) => scrollbars;
get_canvas_scrollbars _ =>
raise exception WIDGET "canvas_item::get_canvas_scrollbars applied to non-Canvas Widget"; end;
fun get_canvas_items (CANVAS { citems, ... } ) => citems;
get_canvas_items _ =>
raise exception WIDGET "canvas_item::get_canvas_items applied to non-Canvas Widget"; end;
fun sel_canvas_pack (CANVAS { packing_hints, ... } ) => packing_hints;
sel_canvas_pack _ =>
raise exception WIDGET "canvas_item::selCanvasPack applied to non-Canvas Widget"; end;
fun sel_canvas_configure (CANVAS { traits, ... } ) => traits;
sel_canvas_configure _ =>
raise exception WIDGET "canvas_item::selCanvasConfigure applied to non-Canvas Widget"; end;
fun sel_canvas_naming (CANVAS { event_callbacks, ... } ) => event_callbacks;
sel_canvas_naming _ =>
raise exception WIDGET "canvas_item::selCanvasNaming applied to non-Canvas Widget"; end;
fun upd_canvas_wid_id (CANVAS { widget_id, scrollbars, citems,
packing_hints, traits, event_callbacks } ) wid =>
CANVAS { widget_id=>wid, scrollbars, citems,
packing_hints, traits, event_callbacks };
upd_canvas_wid_id _ _ =>
raise exception WIDGET "canvas_item::updCanvasWidId applied to non-Canvas Widget"; end;
fun update_canvas_scrollbars (CANVAS { widget_id, scrollbars, citems,
packing_hints, traits, event_callbacks } ) st =>
CANVAS { widget_id, scrollbars=>st, citems,
packing_hints, traits, event_callbacks };
update_canvas_scrollbars _ _ =>
raise exception WIDGET "canvas_item::update_canvas_scrollbars applied to non-Canvas Widget"; end;
fun update_canvas_items (CANVAS { widget_id, scrollbars, citems,
packing_hints, traits, event_callbacks } ) its =>
CANVAS { widget_id, scrollbars, citems=>its,
packing_hints, traits, event_callbacks };
update_canvas_items _ _ =>
raise exception WIDGET "canvas_item::update_canvas_items applied to non-Canvas Widget"; end;
fun upd_canvas_pack (CANVAS { widget_id, scrollbars, citems,
packing_hints, traits, event_callbacks } ) p =>
CANVAS { widget_id, scrollbars, citems,
packing_hints=>p, traits, event_callbacks };
upd_canvas_pack _ _ =>
raise exception WIDGET "canvas_item::updCanvasPack applied to non-Canvas Widget"; end;
fun upd_canvas_configure (CANVAS { widget_id, scrollbars, citems,
packing_hints, traits, event_callbacks } ) c =>
CANVAS { widget_id, scrollbars, citems,
packing_hints, traits=>c, event_callbacks };
upd_canvas_configure _ _ =>
raise exception WIDGET "canvas_item::updCanvasConfigure applied to non-Canvas Widget"; end;
fun upd_canvas_naming (CANVAS { widget_id, scrollbars, citems,
packing_hints, traits, event_callbacks } ) b =>
CANVAS { widget_id, scrollbars, citems,
packing_hints, traits, event_callbacks=>b };
upd_canvas_naming _ _ =>
raise exception WIDGET "canvas_item::updCanvasNaming applied to non-Canvas Widget"; end;
fun sel_item_type (CANVAS_BOX cr) => CANVAS_BOX_TYPE;
sel_item_type (CANVAS_OVAL co) => CANVAS_OVAL_TYPE;
sel_item_type (CANVAS_LINE cl) => CANVAS_LINE_TYPE;
sel_item_type (CANVAS_POLYGON cp) => CANVAS_POLYGON_TYPE;
sel_item_type (CANVAS_TEXT ct) => CANVAS_TEXT_TYPE;
sel_item_type (CANVAS_ICON ci) => CANVAS_ICON_TYPE;
sel_item_type (CANVAS_WIDGET cw) => CANVAS_WIDGET_TYPE;
sel_item_type (CANVAS_TAG ct) => CANVAS_TAG_TYPE; end;
fun get_canvas_item_id (CANVAS_BOX { citem_id, ... } ) => citem_id;
get_canvas_item_id (CANVAS_OVAL { citem_id, ... } ) => citem_id;
get_canvas_item_id (CANVAS_LINE { citem_id, ... } ) => citem_id;
get_canvas_item_id (CANVAS_POLYGON { citem_id, ... } ) => citem_id;
get_canvas_item_id (CANVAS_TEXT { citem_id, ... } ) => citem_id;
get_canvas_item_id (CANVAS_ICON { citem_id, ... } ) => citem_id;
get_canvas_item_id (CANVAS_WIDGET { citem_id, ... } ) => citem_id;
get_canvas_item_id (CANVAS_TAG { citem_id, ... } ) => citem_id; end;
/*
| get_canvas_item_ID _ =
raise exception CANVAS_ITEM ("canvas_item::get_canvas_item_ID not yet fully implemented")
*/
fun sel_item_configure (CANVAS_BOX { traits, ... } ) => traits;
sel_item_configure (CANVAS_OVAL { traits, ... } ) => traits;
sel_item_configure (CANVAS_LINE { traits, ... } ) => traits;
sel_item_configure (CANVAS_POLYGON { traits, ... } ) => traits;
sel_item_configure (CANVAS_TEXT { traits, ... } ) => traits;
sel_item_configure (CANVAS_ICON { traits, ... } ) => traits;
sel_item_configure (CANVAS_WIDGET { traits, ... } ) => traits;
sel_item_configure (CANVAS_TAG _) =>
raise exception CANVAS_ITEM ("canvas_item::selItemConfigure: CANVAS_TAG has no Trait"); end;
/*
| selItemConfigure _ =
raise exception CANVAS_ITEM ("canvas_item::selItemConfigure not yet fully implemented")
*/
fun sel_item_naming (CANVAS_BOX { event_callbacks, ... } ) => event_callbacks;
sel_item_naming (CANVAS_OVAL { event_callbacks, ... } ) => event_callbacks;
sel_item_naming (CANVAS_LINE { event_callbacks, ... } ) => event_callbacks;
sel_item_naming (CANVAS_POLYGON { event_callbacks, ... } ) => event_callbacks;
sel_item_naming (CANVAS_TEXT { event_callbacks, ... } ) => event_callbacks;
sel_item_naming (CANVAS_ICON { event_callbacks, ... } ) => event_callbacks;
sel_item_naming (CANVAS_WIDGET { event_callbacks, ... } ) => event_callbacks;
sel_item_naming (CANVAS_TAG _) =>
raise exception CANVAS_ITEM ("canvas_item::selItemNaming: CANVAS_TAG has no Event_Callback"); end;
/*
| selItemNaming _ =
raise exception CANVAS_ITEM ("canvas_item::selItemNaming not yet fully implemented")
*/
fun get_canvas_item_coordinates (CANVAS_BOX { coord1, coord2, ... } ) => [coord1, coord2];
get_canvas_item_coordinates (CANVAS_OVAL { coord1, coord2, ... } ) => [coord1, coord2];
get_canvas_item_coordinates (CANVAS_LINE { coords, event_callbacks, ... } ) => coords;
get_canvas_item_coordinates (CANVAS_POLYGON { coords, event_callbacks, ... } ) => coords;
get_canvas_item_coordinates (CANVAS_TEXT { coord, event_callbacks, ... } ) => [coord];
get_canvas_item_coordinates (CANVAS_ICON { coord, event_callbacks, ... } ) => [coord];
get_canvas_item_coordinates (CANVAS_WIDGET { coord, ... } ) => [coord];
get_canvas_item_coordinates (CANVAS_TAG _) =>
raise exception CANVAS_ITEM ("canvas_item::get_canvas_item_coordinates: CANVAS_TAG has no Coords"); end;
/*
| get_canvas_item_coordinates _ =
raise exception CANVAS_ITEM ("canvas_item::get_canvas_item_coordinates not yet fully implemented")
*/
fun get_canvas_item_subwidgets (CANVAS_WIDGET { subwidgets, ... } ) => get_raw_widgets subwidgets;
get_canvas_item_subwidgets _ =>
raise exception CANVAS_ITEM ("canvas_item::get_canvas_item_subwidgets applied to non CANVAS_WIDGET"); end;
fun get_canvas_item_canvas_items (CANVAS_TAG { citem_ids, ... } ) => citem_ids;
get_canvas_item_canvas_items _ =>
raise exception CANVAS_ITEM ("canvas_item::get_canvas_item_canvas_items applied to non CANVAS_TAG"); end;
fun get_canvas_item_icon (CANVAS_ICON { icon_variety, ... } ) => icon_variety;
get_canvas_item_icon _ =>
raise exception CANVAS_ITEM ("canvas_item::get_canvas_item_icon applied to non CANVAS_ICON"); end;
fun upd_item_configure (CANVAS_BOX { citem_id, coord1, coord2, event_callbacks, ... } ) cf =>
CANVAS_BOX { citem_id, coord1, coord2,
traits=>cf, event_callbacks };
upd_item_configure (CANVAS_OVAL { citem_id, coord1, coord2, event_callbacks, ... } ) cf =>
CANVAS_OVAL { citem_id, coord1, coord2,
traits=>cf, event_callbacks };
upd_item_configure (CANVAS_LINE { citem_id, coords, event_callbacks, ... } ) cf =>
CANVAS_LINE { citem_id, coords, traits=>cf, event_callbacks };
upd_item_configure (CANVAS_POLYGON { citem_id, coords, event_callbacks, ... } ) cf =>
CANVAS_POLYGON { citem_id, coords, traits=>cf, event_callbacks };
upd_item_configure (CANVAS_TEXT { citem_id, coord, event_callbacks, ... } ) cf =>
CANVAS_TEXT { citem_id, coord, traits=>cf, event_callbacks };
upd_item_configure (CANVAS_ICON { citem_id, coord, icon_variety, event_callbacks, ... } )cf =>
CANVAS_ICON { citem_id, coord, icon_variety,
traits=>cf, event_callbacks };
upd_item_configure (CANVAS_WIDGET { citem_id, coord, subwidgets, traits,
event_callbacks, ... } ) cf =>
CANVAS_WIDGET { citem_id, coord, subwidgets, traits => cf,
event_callbacks };
upd_item_configure (CANVAS_TAG _) cf =>
raise exception CANVAS_ITEM ("canvas_item::updItemConfigure: CANVAS_TAG has no Trait"); end;
/*
| updItemConfigure _ _ =
raise exception CANVAS_ITEM ("canvas_item::updItemConfigure not yet fully implemented")
*/
fun upd_item_naming (CANVAS_BOX { citem_id, coord1, coord2, traits, ... } ) b =>
CANVAS_BOX { citem_id, coord1,
coord2, traits, event_callbacks=>b };
upd_item_naming (CANVAS_OVAL { citem_id, coord1, coord2, traits, ... } ) b =>
CANVAS_OVAL { citem_id, coord1,
coord2, traits, event_callbacks=>b };
upd_item_naming (CANVAS_LINE { citem_id, coords, traits, ... } ) b =>
CANVAS_LINE { citem_id, coords,
traits, event_callbacks=>b };
upd_item_naming (CANVAS_POLYGON { citem_id, coords, traits, ... } ) b =>
CANVAS_POLYGON { citem_id, coords,
traits, event_callbacks=>b };
upd_item_naming (CANVAS_TEXT { citem_id, coord, traits, ... } ) b =>
CANVAS_TEXT { citem_id, coord,
traits, event_callbacks=>b };
upd_item_naming (CANVAS_ICON { citem_id, coord, icon_variety, traits, ... } ) b =>
CANVAS_ICON { citem_id, coord,
icon_variety, traits, event_callbacks=>b };
upd_item_naming (CANVAS_WIDGET { citem_id, coord, subwidgets, traits, ... } ) b =>
CANVAS_WIDGET { citem_id, coord, subwidgets,
traits, event_callbacks => b };
upd_item_naming (CANVAS_TAG _) b =>
raise exception CANVAS_ITEM ("canvas_item::updItemNaming: CANVAS_TAG has no Event_Callback"); end;
/*
| updItemNaming _ _ =
raise exception CANVAS_ITEM ("canvas_item::updItemNaming not yet fully implemented")
*/
fun update_canvas_item_coordinates (CANVAS_BOX { citem_id, traits, event_callbacks, ... } ) c =>
CANVAS_BOX { citem_id, coord1=>(hd c), coord2=>(hd (tl c)),
traits, event_callbacks };
update_canvas_item_coordinates (CANVAS_OVAL { citem_id, traits, event_callbacks, ... } ) c =>
CANVAS_OVAL { citem_id, coord1=>(hd c), coord2=>(hd (tl c)),
traits, event_callbacks };
update_canvas_item_coordinates (CANVAS_LINE { citem_id, traits, event_callbacks, ... } ) c =>
CANVAS_LINE { citem_id, coords=>c,
traits, event_callbacks };
update_canvas_item_coordinates (CANVAS_POLYGON { citem_id, traits, event_callbacks, ... } ) c =>
CANVAS_POLYGON { citem_id, coords=>c,
traits, event_callbacks };
update_canvas_item_coordinates (CANVAS_TEXT { citem_id, traits, event_callbacks, ... } ) c =>
CANVAS_TEXT { citem_id, coord=>hd c,
traits, event_callbacks };
update_canvas_item_coordinates (CANVAS_ICON { citem_id, icon_variety, traits, event_callbacks, ... } )c =>
CANVAS_ICON { citem_id, coord=>hd c, icon_variety,
traits, event_callbacks };
update_canvas_item_coordinates (CANVAS_WIDGET { citem_id, subwidgets, traits, event_callbacks, ... } ) c =>
CANVAS_WIDGET { citem_id, coord=>(hd c), subwidgets,
traits, event_callbacks };
update_canvas_item_coordinates (CANVAS_TAG _) c =>
raise exception CANVAS_ITEM ("canvas_item::update_canvas_item_coordinates: CANVAS_TAG has no Coords"); end;
/*
| update_canvas_item_coordinates _ _ =
raise exception CANVAS_ITEM ("canvas_item::update_canvas_item_coordinates not yet fully implemented")
*/
fun update_canvas_item_subwidgets (CANVAS_WIDGET { citem_id, coord, traits, event_callbacks,
subwidgets } ) newwids
=>
{
wids = case subwidgets PACKED _ => PACKED newwids;
GRIDDED _ => GRIDDED newwids; esac;
CANVAS_WIDGET { citem_id, coord, subwidgets => wids,
traits, event_callbacks };
};
update_canvas_item_subwidgets _ _
=>
raise exception CANVAS_ITEM ("canvas_item::update_canvas_item_subwidgets applied to non CANVAS_WIDGET"); end;
fun update_canvas_item_canvas_items (CANVAS_TAG { citem_id, ... } ) cids
=>
CANVAS_TAG { citem_id, citem_ids=>cids };
update_canvas_item_canvas_items _ cids
=>
raise exception CANVAS_ITEM ("canvas_item::update_canvas_item_canvas_items applied to non CANVAS_TAG"); end;
fun update_canvas_item_icon (CANVAS_ICON { citem_id, coord, traits, event_callbacks, ... } ) ic
=>
CANVAS_ICON {
citem_id,
coord,
icon_variety => ic,
traits,
event_callbacks
};
update_canvas_item_icon _ ic
=>
raise exception CANVAS_ITEM ("canvas_item::update_canvas_item_icon applied to non CANVAS_ICON"); end;
# ### muss noch implementiert werden
fun check (_: Canvas_Item) = TRUE;
fun get wid cid =
{
cits = get_canvas_items wid;
item = list_util::getx
(\\ it => ((get_canvas_item_id it) == cid); end ) cits
(CANVAS_ITEM ("canvas_item::get: " + cid + " not found"));
item;
};
fun get_naming_by_name wid cid name
=
{
item = get wid cid;
bis = sel_item_naming item;
bi = bind::get_action_by_name name bis;
bi;
};
fun upd widg cid ncit
=
{
cits = get_canvas_items widg;
cit = list_util::getx
(\\ cit => ((get_canvas_item_id cit) == cid); end )
cits
(CANVAS_ITEM ("item: " + cid + " not found"));
ncits = list_util::update_val (\\ cit => ((get_canvas_item_id cit) == cid); end )
ncit
cits;
nwidg = update_canvas_items widg ncits;
nwidg;
};
fun get_canvas_widgets (CANVAS { widget_id, scrollbars, citems, packing_hints,
traits, event_callbacks } )
=>
{
widits = list::filter (\\ cit => (sel_item_type cit == CANVAS_WIDGET_TYPE); end ) citems;
wids = map get_canvas_item_subwidgets widits;
wids' = list::cat wids;
wids';
};
get_canvas_widgets _ =>
raise exception WIDGET "canvas_item::getCanvasWidgets applied to non-Canvas Widget"; end;
fun get_canvas_citem_widget_ass_list (CANVAS { widget_id, scrollbars,
citems, packing_hints, traits, event_callbacks } )
=>
{
widits = list::filter (\\ cit => (sel_item_type cit == CANVAS_WIDGET_TYPE); end ) citems;
wids = map get_canvas_item_subwidgets widits;
paired_lists::zip (widits, wids);
};
get_canvas_citem_widget_ass_list _ =>
raise exception WIDGET "canvas_item::getCanvasCItemWidgetAssList applied to non-Canvas Widget"; end;
fun add_canvas_widget af (w as (CANVAS _)) widg wp =>
{
debug::print 3 ("addCanvasWidget " + (get_widget_id w) + " " + (get_widget_id widg) + " " + wp);
my (w_id, nwp) = paths::fst_wid_path wp; # strip ".cnv"
my (w_id', nwp') = paths::fst_wid_path nwp; # strip ".cfr"
if ( nwp' == "" )
raise exception CANVAS_ITEM "canvas_item::addCanvasWidgets called for CANVAS_WIDGET-Toplevel";
else
{
my (w_id'', nwp'') = paths::fst_wid_path nwp';
citwidass = get_canvas_citem_widget_ass_list w;
my (cit, swidgs) = list_util::getx
(\\ (c, (ws: List( Widget ))) =>
fold_backward
(\\ (w, t) => ((get_widget_id w) == w_id'') or t; end )
FALSE ws; end )
citwidass
(CANVAS_ITEM ("canvas_item::addCanvasWidget: subwidget " + w_id'' + " not found" ));
debug::print 3 ("addCanvasWidget (ass): " + (get_canvas_item_id cit) + " [" +
(cat (map (get_widget_id) swidgs)) + "]");
nswidgs = af swidgs widg nwp';
ncit = update_canvas_item_subwidgets cit nswidgs;
nwidg = upd w (get_canvas_item_id ncit) ncit;
nwidg;
};fi;
};
add_canvas_widget _ _ _ _ =>
raise exception WIDGET "canvas_item::addCanvasWidgets applied to non-Canvas Widget"; end;
fun delete_canvas_widget df (w as (CANVAS _)) wid wp =>
{
debug::print 3 ("deleteCanvasWidget " + (get_widget_id w) + " " + wp);
my (w_id, nwp) = paths::fst_wid_path wp; # strip ".cfr"
my (w_id', nwp') = paths::fst_wid_path nwp;
citwidass = get_canvas_citem_widget_ass_list w;
my (cit, swidgs) = list_util::getx
(\\ (c, (ws: List( Widget ))) =>
fold_backward
(\\ (w, t) => ((get_widget_id w) == w_id') or t; end )
FALSE ws; end )
citwidass
(CANVAS_ITEM ("canvas_item::deleteCanvasWidget: subwidget " + w_id' + " not found"));
nswidgs = df swidgs w_id' nwp';
ncit = update_canvas_item_subwidgets cit nswidgs;
nwidg = upd w (get_canvas_item_id ncit) ncit;
nwidg;
};
delete_canvas_widget _ _ _ _ =>
raise exception WIDGET "canvas_item::deleteCanvasWidgets applied to non-Canvas Widget"; end;
fun upd_canvas_widget uf (w as (CANVAS _)) wid wp neww
=>
{
debug::print 3 ("updCanvasWidget " + (get_widget_id w) + " " + wp);
my (w_id, nwp) = paths::fst_wid_path wp; # strip ".cfr"
my (w_id', nwp') = paths::fst_wid_path nwp;
citwidass = get_canvas_citem_widget_ass_list w;
my (cit, swidgs) = list_util::getx
(\\ (c, (ws: List( Widget ))) =>
fold_backward
(\\ (w, t) => ((get_widget_id w) == w_id') or t; end )
FALSE ws; end )
citwidass
(CANVAS_ITEM ("canvas_item::updCanvasWidget did not find Subwidget " + w_id'));
nswidgs = uf swidgs w_id' nwp' neww;
ncit = update_canvas_item_subwidgets cit nswidgs;
nwidg = upd w (get_canvas_item_id ncit) ncit;
nwidg;
};
upd_canvas_widget _ _ _ _ _ =>
raise exception WIDGET "canvas_item::updCanvasWidgets applied to non-Canvas Widget"; end;
fun print_canvas_widget canvas_id config_list =
{
ctp = "." + canvas_id + ".cnv";
(com::put_tcl_cmd (ctp + " postscript " +
(config::show_all_print_conf config_list)));
};
fun pack pf tp (ip as (window, pt))
(CANVAS_OVAL { citem_id, coord1, coord2, traits, event_callbacks } ) =>
{
coords = coordinate::show [coord1, coord2];
conf = config::pack ip traits;
(tp + " create oval " + coords + " " + conf + " -tags " +
citem_id + "\n" +
cat (bind::pack_canvas tp ip citem_id event_callbacks));
};
pack pf tp (ip as (window, pt))
(CANVAS_BOX { citem_id, coord1, coord2, traits, event_callbacks } ) =>
{
coords = coordinate::show [coord1, coord2];
conf = config::pack ip traits;
(tp + " create box " + coords + " " + conf + " -tags " +
citem_id + "\n" +
cat (bind::pack_canvas tp ip citem_id event_callbacks));
};
pack pf tp (ip as (window, pt)) (CANVAS_LINE { citem_id, coords, traits, event_callbacks } ) =>
{
coords = coordinate::show coords;
conf = config::pack ip traits;
(tp + " create line " + coords + " " + conf + " -tags " +
citem_id + "\n" +
cat (bind::pack_canvas tp ip citem_id event_callbacks));
};
pack pf tp (ip as (window, pt)) (CANVAS_ICON { citem_id, coord, icon_variety, traits,
event_callbacks } ) =>
{
coords = coordinate::show [coord];
conf = config::pack ip traits;
icon = config::show_icon_kind icon_variety;
ictype =
case icon_variety
NO_ICON => "bitmap";
TK_BITMAP _ => "bitmap";
FILE_BITMAP _ => "bitmap";
# | FILE_PIXMAP _ => "bitmap"
FILE_IMAGE _ => "image"; esac;
(tp + " create " + ictype + " " + coords + " " +
icon + " " + conf + " -tags " + citem_id + "\n" +
cat (bind::pack_canvas tp ip citem_id event_callbacks));
};
pack pf tp (ip as (window, pt))
(CANVAS_WIDGET { citem_id, coord, subwidgets, traits, event_callbacks } ) =>
{
widget_id = citem_id;
coords = coordinate::show [coord];
conf = config::pack ip traits;
frw = FRAME { widget_id, subwidgets,
packing_hints => [], traits => [], event_callbacks => [] };
frtp = tp + "." + widget_id;
(pf FALSE tp ip NULL frw +
tp + " create window " + coords + " " + conf +
" -window " + frtp + " -tags " + citem_id + "\n" +
cat (bind::pack_canvas tp ip citem_id event_callbacks));
};
pack pf tp (ip as (window, pt)) (CANVAS_TAG _) => "";
# Added by E.L.Gunter 14 July 1998
pack pf tp (ip as (window, pt)) (CANVAS_POLYGON { citem_id, coords, traits, event_callbacks } )
=>
{
coords = coordinate::show coords;
conf = config::pack ip traits;
(tp + " create polygon " + coords + " " + conf + " -tags " +
citem_id + "\n" +
cat (bind::pack_canvas tp ip citem_id event_callbacks));
};
pack pf tp (ip as (window, pt)) (CANVAS_TEXT { citem_id, coord, traits, event_callbacks } )
=>
{
coords = coordinate::show [coord];
conf = config::pack ip traits;
(tp + " create text " + coords + " " + conf + " -tags " +
citem_id + "\n" +
cat (bind::pack_canvas tp ip citem_id event_callbacks));
}; end;
/* | pack _ _ _ _ =
raise exception CANVAS_ITEM ("canvas_item::pack not yet fully implemented")
*/
fun add pf widg cit
=
{
my ip as (window, pt) = paths::get_int_path_gui (get_widget_id widg);
tp = paths::get_tcl_path_gui ip;
nip = (window, pt + ".cnv");
ntp = tp + ".cnv";
cits = get_canvas_items widg;
ncits = cits @ [cit];
nwidg = update_canvas_items widg ncits;
{ com::put_tcl_cmd (pack pf ntp nip cit);
nwidg;};
};
fun delete dwf widg cid
=
{
fun delete' dwf widg (cit as (CANVAS_WIDGET { citem_id, subwidgets, ... } ))
=>
{
my ip as (window, pt) = paths::get_int_path_gui (get_widget_id widg);
tp = paths::get_tcl_path_gui ip;
nip = (window, pt + ".cnv");
ntp = tp + ".cnv";
cits = get_canvas_items widg;
ncits = list::filter (\\ cit => not ((get_canvas_item_id cit) == citem_id); end ) cits;
nwidg = update_canvas_items widg ncits;
{ apply (dwf o get_widget_id) (get_raw_widgets subwidgets);
com::put_tcl_cmd ("destroy " + ntp + "." + citem_id);
com::put_tcl_cmd (ntp + " delete " + citem_id);
nwidg;};
};
delete' dwf widg cit
=>
{
my ip as (window, pt) = paths::get_int_path_gui (get_widget_id widg);
tp = paths::get_tcl_path_gui ip;
nip = (window, pt + ".cnv");
ntp = tp + ".cnv";
cits = get_canvas_items widg;
ncits = list::filter (\\ cit => not ((get_canvas_item_id cit) == cid); end ) cits;
nwidg = update_canvas_items widg ncits;
{ com::put_tcl_cmd (ntp + " delete " + cid);
nwidg;};
};
end;
cit = get widg cid;
delete' dwf widg cit;
};
fun add_item_configure widg cid cf
=
{
my ip as (window, pt) = paths::get_int_path_gui (get_widget_id widg);
tp = paths::get_tcl_path_gui ip;
nip = (window, pt + ".cnv");
ntp = tp + ".cnv";
cits = get_canvas_items widg;
cit = list_util::getx (\\ cit => ((get_canvas_item_id cit) == cid); end )
cits
(CANVAS_ITEM ("item: " + cid + " not found"));
conf = sel_item_configure cit;
nconf = config::add conf cf;
ncit = upd_item_configure cit nconf;
ncits = list_util::update_val (\\ cit => ((get_canvas_item_id cit) == cid); end )
ncit
cits;
nwidg = update_canvas_items widg ncits;
{ com::put_tcl_cmd (ntp + " itemconfigure " + cid + " " +
config::pack nip cf);
nwidg;};
};
fun add_item_naming widg cid bi
=
{
my ip as (window, pt) = paths::get_int_path_gui (get_widget_id widg);
tp = paths::get_tcl_path_gui ip;
nip = (window, pt + ".cnv");
ntp = tp + ".cnv";
cits = get_canvas_items widg;
cit = list_util::getx (\\ cit => ((get_canvas_item_id cit) == cid); end )
cits
(CANVAS_ITEM ("item: " + cid + " not found"));
bind = sel_item_naming cit;
nbind = bind::add bind bi;
ncit = upd_item_naming cit nbind;
ncits = list_util::update_val (\\ cit => ((get_canvas_item_id cit) == cid); end )
ncit
cits;
nwidg = update_canvas_items widg ncits;
{ com::put_tcl_cmd (cat (bind::pack_canvas ntp nip cid bi));
nwidg;};
};
fun get_coords wid cid
=
{
cit = get wid cid;
case cit
CANVAS_TAG { citem_ids => [], ... }
=>
raise exception CANVAS_ITEM ("canvas_item::getCoords: CANVAS_TAG(_, [])");
CANVAS_TAG { citem_ids => x . _, ... }
=>
get_coords wid x;
_ => {
ip = paths::get_int_path_gui (get_widget_id wid);
tp = paths::get_tcl_path_gui ip;
cid' = get_canvas_item_id cit;
cos = com::read_tcl_val (tp + ".cnv coords " + cid');
coordinate::read cos;
};
esac;
};
fun set_coords wid cid cos
=
{
fun set_coords' wid (CANVAS_TAG _) cos
=>
raise exception CANVAS_ITEM ("canvas_item::setCoords is not to be used for CANVAS_TAG");
set_coords' wid cit cos
=>
{
ip = paths::get_int_path_gui (get_widget_id wid);
tp = paths::get_tcl_path_gui ip;
cid' = get_canvas_item_id cit;
com::put_tcl_cmd (tp + ".cnv coords " + cid' + " " + (coordinate::show cos));
};
end;
cit = get wid cid;
set_coords' wid cit cos;
};
fun get_icon_width (NO_ICON)
=>
0;
get_icon_width (TK_BITMAP _)
=>
raise exception CANVAS_ITEM ("canvas_item::getIconWidth: don't know how to get width of TkBitmaps");
get_icon_width (FILE_BITMAP _)
=>
raise exception CANVAS_ITEM ("canvas_item::getIconWidth: don't know how to get width of FileBitmaps");
get_icon_width (FILE_IMAGE (f, imid))
=>
string_util::to_int (com::read_tcl_val ("image width " + imid));
end;
fun get_width wid cid
=
{
fun min xs = fold_forward int::min (hd xs) xs;
fun max xs = fold_forward int::max (hd xs) xs;
fun get_width' wid (CANVAS_BOX _) ((x1, _) . (x2, _) . NIL)
=>
x2-x1;
get_width' wid (CANVAS_OVAL _) ((x1, _) . (x2, _) . NIL)
=>
x2-x1;
get_width' wid (CANVAS_LINE _) (cos as (co . cos'))
=>
{
xs = map fst cos;
ma = max xs;
mi = min xs;
ma-mi;
};
get_width' wid (CANVAS_POLYGON _) (cos as (co . cos'))
=>
{
xs = map fst cos;
ma = max xs;
mi = min xs;
ma-mi;
};
get_width' wid (CANVAS_TEXT _) _
=>
raise exception CANVAS_ITEM ("canvas_item::get_width not yet implemented for CANVAS_TEXT");
get_width' wid (CANVAS_ICON { icon_variety, ... } ) _
=>
get_icon_width icon_variety;
get_width' wid (CANVAS_WIDGET _) _
=>
raise exception CANVAS_ITEM ("canvas_item::get_width not yet implemented for CANVAS_WIDGET");
get_width' wid (CANVAS_TAG _) _
=>
raise exception CANVAS_ITEM ("canvas_item::get_width not yet implemented for CANVAS_TAG");
end;
cit = get wid cid;
cos = get_coords wid cid;
get_width' wid cit cos;
};
fun get_icon_height (NO_ICON)
=>
0;
get_icon_height (TK_BITMAP _)
=>
raise exception CANVAS_ITEM ("canvas_item::getIconHeight: don't know how to get width of TkBitmaps");
get_icon_height (FILE_BITMAP _)
=>
raise exception CANVAS_ITEM ("canvas_item::getIconHeight: don't know how to get width of FileBitmaps");
get_icon_height (FILE_IMAGE (f, imid))
=>
string_util::to_int (com::read_tcl_val ("image height " + imid));
end;
fun get_height wid cid
=
{
fun min xs = fold_forward int::min (hd xs) xs;
fun max xs = fold_forward int::max (hd xs) xs;
fun get_height' wid (CANVAS_BOX _) ((_, y1) . (_, y2) . NIL)
=>
y2-y1;
get_height' wid (CANVAS_OVAL _) ((_, y1) . (_, y2) . NIL)
=>
y2-y1;
get_height' wid (CANVAS_LINE _) (cos as (co . cos'))
=>
{
ys = map basic_utilities::snd cos;
ma = max ys;
mi = min ys;
ma-mi;
};
get_height' wid (CANVAS_POLYGON _) (cos as (co . cos'))
=>
{
ys = map basic_utilities::snd cos;
ma = max ys;
mi = min ys;
ma-mi;
};
get_height' wid (CANVAS_TEXT _) _
=>
raise exception CANVAS_ITEM ("canvas_item::get_height not yet implemented for CANVAS_TEXT");
get_height' wid (CANVAS_ICON { icon_variety, ... } ) _
=>
get_icon_height icon_variety;
get_height' wid (CANVAS_WIDGET _) _
=>
raise exception CANVAS_ITEM ("canvas_item::get_height not yet implemented for CANVAS_WIDGET");
get_height' wid (CANVAS_TAG _) _
=>
raise exception CANVAS_ITEM ("canvas_item::get_height not yet implemented for CANVAS_TAG");
end;
cit = get wid cid;
cos = get_coords wid cid;
get_height' wid cit cos;
};
fun move wid cid co
=
{
fun move' wid (CANVAS_TAG { citem_id, citem_ids } ) co
=>
apply (\\ cid => move wid cid co; end ) citem_ids;
move' wid cit (co as (x, y))
=>
{
ip = paths::get_int_path_gui (get_widget_id wid);
tp = paths::get_tcl_path_gui ip;
cid' = get_canvas_item_id cit;
com::put_tcl_cmd (tp + ".cnv move " + cid' + " " + (coordinate::show [co]));
};
end;
cit = get wid cid;
move' wid cit co;
};
# **************************************************************************
#
# Anonymous CItemId Manager
# Purpose: Creates anonymous names for Canvas items, starting
# with "anocid" and a unique number
#
# **************************************************************************
my
anocid_nr = REF (0);
fun new_id ()
=
{ inc (anocid_nr);
"anocid" + int::to_string *anocid_nr;
};
my
anofrid_nr = REF (0);
fun new_fr_id ()
=
{ inc (anofrid_nr);
"cfr" + int::to_string *anofrid_nr;
};
end;
};