## widget_tree.pkg
## Author: Burkhart Wolff
## (C) 1996, Bremen Institute for Safe Systems, Universitaet Bremen
# Compiled by:
# src/lib/tk/src/tk.sublib# **************************************************************************
# Functions related to Path-Management (and widgets).
# **************************************************************************
### "The grid is very peaceful.
### Nothing can go wrong.
### Everything is complete."
###
### -- Louise Bourgeois
package widget_tree
: (weak) Widget_Tree # Widget_Tree is from src/lib/tk/src/widget_tree.api{
stipulate
include package basic_tk_types;
include package gui_state;
include package basic_utilities;
herein
# ***********************************************************************
# CHECKING the INTEGRITY of WIDGETS
# ***********************************************************************
# yet implememed checks: widget_id of widgets /
# traits of widgets, mitems and citems
# other checks may be added
fun check_widget w
=
{
t = get_widget_type w;
if (not (check_widget_id (get_widget_id w)))
print("WidId " + get_widget_id w + " is not O.K.!");
raise exception WIDGET("WidId " + get_widget_id w + " is not O.K.!");
fi;
if (check_widget_configure t (get_the_widget_traits w) ) ();
else print("Configures of Widget " + get_widget_id w +
" are not O.K.!");
raise exception WIDGET("Configures of Widget " + get_widget_id w +
" are not O.K.!"); fi;
if (check_widget_naming t (get_the_widget_event_callbacks w) ) ();# NOT YET IMPL.
else print("Namings of Widget " + get_widget_id w +
" are not O.K.!");
raise exception WIDGET("Namings of Widget " + get_widget_id w +
" are not O.K.!"); fi;
case w
MENU_BUTTON { mitems, ... } =>
if (list::all check_mitem mitems ) ();
else print("Menu_Items of MENU_BUTTON " + get_widget_id w +
" are not O.K.!");
raise exception WIDGET("Menu_Items of MENU_BUTTON " + get_widget_id w +
" are not O.K.!"); fi;
POPUP { mitems, ... } =>
if (list::all check_mitem mitems ) ();
else print("Menu_Items of POPUP " + get_widget_id w +
" are not O.K.!");
raise exception WIDGET("Menu_Items of POPUP " + get_widget_id w +
" are not O.K.!"); fi;
CANVAS { citems, ... } =>
if (list::all check_citem citems ) ();
else print("CItems of CANVAS " + get_widget_id w +
" are not O.K.!");
raise exception WIDGET("CItems of CANVAS " + get_widget_id w +
" are not O.K.!"); fi;
_ => (); esac;
}
# Check on the widget-id. Currently only widget-ids that begin with
# lowercase, and further consist of alphanumerical characters allowed.
# Tcl allows a wider range of strings.
also
fun check_widget_id s
=
if (size s == 0)
#
FALSE;
else
char::is_lower (string::get_byte_as_char (s, 0))
and
string_util::all char::is_alpha_num s;
fi
also
fun check_one_mconfigure CHECKBOX_MENU_ITEM_TYPE c
=>
(case c
ACCELERATOR _ => TRUE;
BACKGROUND _ => TRUE;
FOREGROUND _ => TRUE;
CALLBACK _ => TRUE;
TEXT _ => TRUE;
FONT _ => TRUE;
VARIABLE _ => TRUE;
VALUE _ => TRUE;
MENU_UNDERLINE _ => TRUE;
_ =>
{ print("Wrong configure option:\n" + config::conf_name c +
" not allowed for MENU_CHECKBUTTON!\n");
FALSE;}; esac);
check_one_mconfigure RADIO_BUTTON_MENU_ITEM_TYPE c =>
(case c
ACCELERATOR _ => TRUE;
BACKGROUND _ => TRUE;
FOREGROUND _ => TRUE;
CALLBACK _ => TRUE;
TEXT _ => TRUE;
FONT _ => TRUE;
VARIABLE _ => TRUE;
VALUE _ => TRUE;
MENU_UNDERLINE _ => TRUE;
_ =>
{ print("Wrong configure option:\n" + config::conf_name c +
" not allowed for MENU_RADIOBUTTON!\n");
FALSE;}; esac);
check_one_mconfigure COMMAND_MENU_ITEM_TYPE c =>
(case c
ACCELERATOR _ => TRUE;
BACKGROUND _ => TRUE;
FOREGROUND _ => TRUE;
CALLBACK _ => TRUE;
TEXT _ => TRUE;
FONT _ => TRUE;
MENU_UNDERLINE _ => TRUE;
_ =>
{ print("Wrong configure option:\n" + config::conf_name c +
" not allowed for MENU_COMMAND!\n");
FALSE;}; esac);
check_one_mconfigure CASCADE_MENU_ITEM_TYPE c =>
(case c
CALLBACK _ => TRUE;
BACKGROUND _ => TRUE;
FOREGROUND _ => TRUE;
TEXT _ => TRUE;
FONT _ => TRUE;
MENU_UNDERLINE _ => TRUE;
TEAR_OFF _ => TRUE;
_ =>
{ print("Wrong configure option:\n" + config::conf_name c +
" not allowed for MENU_CASCADE!\n");
FALSE;}; esac); end
also
fun check_mitem MENU_SEPARATOR => TRUE;
check_mitem (MENU_CASCADE (ms, cs)) =>
config::no_dbl_p cs and list::all (check_one_mconfigure CASCADE_MENU_ITEM_TYPE) cs
and list::all check_mitem ms;
check_mitem mit =>
{
cs = get_menu_item_traits mit;
config::no_dbl_p cs and
list::all (check_one_mconfigure (get_the_menu_item_type mit)) cs;
}; end
also
fun check_one_cconfigure CANVAS_BOX_TYPE c =>
(case c
FILL_COLOR _ => TRUE;
OUTLINE _ => TRUE;
OUTLINE_WIDTH _ => TRUE;
WIDTH _ => TRUE;
_ =>
{ print("Wrong configure option:\n" + config::conf_name c +
" not allowed for CANVAS_BOX!\n");
FALSE;}; esac);
check_one_cconfigure CANVAS_OVAL_TYPE c =>
(case c
FILL_COLOR _ => TRUE;
OUTLINE _ => TRUE;
OUTLINE_WIDTH _ => TRUE;
WIDTH _ => TRUE;
_ =>
{ print("Wrong configure option:\n" + config::conf_name c +
" not allowed for CANVAS_OVAL!\n");
FALSE;}; esac);
check_one_cconfigure CANVAS_LINE_TYPE c =>
(case c
ARROW _ => TRUE;
CAP_STYLE _ => TRUE;
FILL_COLOR _ => TRUE;
JOIN_STYLE _ => TRUE;
SMOOTH _ => TRUE;
WIDTH _ => TRUE;
_ =>
{ print("Wrong configure option:\n" + config::conf_name c +
" not allowed for CANVAS_LINE!\n");
FALSE;}; esac);
check_one_cconfigure CANVAS_POLYGON_TYPE c =>
(case c
FILL_COLOR _ => TRUE;
OUTLINE _ => TRUE;
OUTLINE_WIDTH _ => TRUE;
SMOOTH _ => TRUE;
WIDTH _ => TRUE;
_ =>
{ print("Wrong configure option:\n" + config::conf_name c +
" not allowed for CANVAS_POLYGON!\n");
FALSE;}; esac);
check_one_cconfigure CANVAS_TEXT_TYPE c =>
(case c
ANCHOR _ => TRUE;
FILL_COLOR _ => TRUE;
FONT _ => TRUE;
JUSTIFY _ => TRUE;
TEXT _ => TRUE;
WIDTH _ => TRUE;
_ =>
{ print("Wrong configure option:\n" + config::conf_name c +
" not allowed for CANVAS_TEXT!\n");
FALSE;}; esac);
check_one_cconfigure CANVAS_WIDGET_TYPE c =>
(case c
ANCHOR _ => TRUE;
HEIGHT _ => TRUE;
WIDTH _ => TRUE;
_ =>
{ print("Wrong configure option:\n" + config::conf_name c +
" not allowed for CANVAS_WIDGET!\n");
FALSE;}; esac); end
also
fun check_one_cicon_configure TRUE c =>
(case c
ANCHOR _ => TRUE;
BACKGROUND _ => TRUE;
FOREGROUND _ => TRUE;
_ =>
{ print("Wrong configure option:\n" + config::conf_name c +
" not allowed for CANVAS_ICON with NoIcon, TkBitmap or " +
"FileBitmap!\n");
FALSE;}; esac);
check_one_cicon_configure FALSE c =>
(case c
ANCHOR _ => TRUE;
_ =>
{ print("Wrong configure option:\n" + config::conf_name c +
" not allowed for CANVAS_ICON with FileImage!\n");
FALSE;}; esac); end
also
fun check_citem (CANVAS_TAG _) => TRUE;
check_citem (CANVAS_ICON { icon_variety, traits, ... } ) =>
(if (config::no_dbl_p traits ) TRUE;
else { print "Double configure option in Widget definition!\n";
FALSE;}
and
case icon_variety
FILE_IMAGE _ => list::all (check_one_cicon_configure FALSE) traits;
_ => list::all (check_one_cicon_configure TRUE) traits; esac;fi);
check_citem cit =>
{
cs = canvas_item::sel_item_configure cit;
if (config::no_dbl_p cs ) TRUE;
else { print "Double configure option in Widget definition!";
FALSE;}
and
list::all (check_one_cconfigure (canvas_item::sel_item_type cit)) cs;fi;
}; end
also
fun check_one_widget_configure FRAME_TYPE c =>
(case c
BACKGROUND _ => TRUE;
BORDER_THICKNESS _ => TRUE;
COLOR_MAP _ => TRUE;
CURSOR _ => TRUE;
HEIGHT _ => TRUE;
RELIEF _ => TRUE;
WIDTH _ => TRUE;
_ =>
{ print("Wrong configure option:\n" + config::conf_name c +
" not allowed for FRAME!\n");
FALSE;}; esac);
check_one_widget_configure MESSAGE_TYPE c =>
(case c
ANCHOR _ => TRUE;
BACKGROUND _ => TRUE;
BORDER_THICKNESS _ => TRUE;
CURSOR _ => TRUE;
FONT _ => TRUE;
FOREGROUND _ => TRUE;
JUSTIFY _ => TRUE;
RELIEF _ => TRUE;
TEXT _ => TRUE;
WIDTH _ => TRUE;
INNER_PAD_X _ => TRUE;
INNER_PAD_Y _ => TRUE;
_ =>
{ print("Wrong configure option:\n" + config::conf_name c +
" not allowed for Message!\n");
FALSE;}; esac);
check_one_widget_configure LABEL_TYPE c =>
(case c
ANCHOR _ => TRUE;
BACKGROUND _ => TRUE;
ICON _ => TRUE;
BORDER_THICKNESS _ => TRUE;
CURSOR _ => TRUE;
FONT _ => TRUE;
FOREGROUND _ => TRUE;
HEIGHT _ => TRUE;
JUSTIFY _ => TRUE;
RELIEF _ => TRUE;
TEXT _ => TRUE;
UNDERLINE => TRUE;
MENU_UNDERLINE _ => TRUE;
WIDTH _ => TRUE;
INNER_PAD_X _ => TRUE;
INNER_PAD_Y _ => TRUE;
_ =>
{ print("Wrong configure option:\n" + config::conf_name c +
" not allowed for LABEL!\n");
FALSE;}; esac);
check_one_widget_configure LIST_BOX_TYPE c =>
(case c
BACKGROUND _ => TRUE;
BORDER_THICKNESS _ => TRUE;
CURSOR _ => TRUE;
FONT _ => TRUE;
FOREGROUND _ => TRUE;
HEIGHT _ => TRUE;
RELIEF _ => TRUE;
WIDTH _ => TRUE;
_ =>
{ print("Wrong configure option:\n" + config::conf_name c +
" not allowed for Listbox!\n");
FALSE;}; esac);
check_one_widget_configure BUTTON_TYPE c
=>
(case c
ANCHOR _ => TRUE;
BACKGROUND _ => TRUE;
BORDER_THICKNESS _ => TRUE;
CALLBACK _ => TRUE;
CURSOR _ => TRUE;
FONT _ => TRUE;
FOREGROUND _ => TRUE;
HEIGHT _ => TRUE;
ICON _ => TRUE;
JUSTIFY _ => TRUE;
RELIEF _ => TRUE;
TEXT _ => TRUE;
WIDTH _ => TRUE;
INNER_PAD_X _ => TRUE;
INNER_PAD_Y _ => TRUE;
ACTIVE _ => TRUE;
_ =>
{ print("Wrong configure option:\n" + config::conf_name c +
" not allowed for Button!\n");
FALSE;}; esac);
check_one_widget_configure RADIO_BUTTON_TYPE c =>
(case c
ANCHOR _ => TRUE;
BACKGROUND _ => TRUE;
BORDER_THICKNESS _ => TRUE;
CALLBACK _ => TRUE;
CURSOR _ => TRUE;
FONT _ => TRUE;
FOREGROUND _ => TRUE;
HEIGHT _ => TRUE;
ICON _ => TRUE;
JUSTIFY _ => TRUE;
RELIEF _ => TRUE;
TEXT _ => TRUE;
VARIABLE _ => TRUE;
VALUE _ => TRUE;
WIDTH _ => TRUE;
INNER_PAD_X _ => TRUE;
INNER_PAD_Y _ => TRUE;
ACTIVE _ => TRUE;
_ =>
{ print("Wrong configure option:\n" + config::conf_name c +
" not allowed for Radiobutton!\n");
FALSE;}; esac);
check_one_widget_configure CHECK_BUTTON_TYPE c =>
(case c
ANCHOR _ => TRUE;
BACKGROUND _ => TRUE;
BORDER_THICKNESS _ => TRUE;
CALLBACK _ => TRUE;
CURSOR _ => TRUE;
FONT _ => TRUE;
FOREGROUND _ => TRUE;
HEIGHT _ => TRUE;
ICON _ => TRUE;
JUSTIFY _ => TRUE;
RELIEF _ => TRUE;
TEXT _ => TRUE;
VARIABLE _ => TRUE;
WIDTH _ => TRUE;
INNER_PAD_X _ => TRUE;
INNER_PAD_Y _ => TRUE;
ACTIVE _ => TRUE;
_ =>
{ print("Wrong configure option:\n" + config::conf_name c +
" not allowed for CHECK_BUTTON!\n");
FALSE;}; esac);
check_one_widget_configure MENU_BUTTON_TYPE c =>
(case c
ANCHOR _ => TRUE;
BACKGROUND _ => TRUE;
BORDER_THICKNESS _ => TRUE;
CALLBACK _ => TRUE;
CURSOR _ => TRUE;
FONT _ => TRUE;
FOREGROUND _ => TRUE;
HEIGHT _ => TRUE;
ICON _ => TRUE;
JUSTIFY _ => TRUE;
RELIEF _ => TRUE;
TEXT _ => TRUE;
WIDTH _ => TRUE;
INNER_PAD_X _ => TRUE;
INNER_PAD_Y _ => TRUE;
ACTIVE _ => TRUE;
TEAR_OFF _ => TRUE;
MENU_UNDERLINE _ => TRUE;
_ =>
{ print("Wrong configure option:\n" + config::conf_name c +
" not allowed for MENU_BUTTON!\n");
FALSE;}; esac);
check_one_widget_configure SCALE_TYPE c =>
(case c
BACKGROUND _ => TRUE;
BIG_INCREMENT _ => TRUE;
BORDER_THICKNESS _ => TRUE;
REAL_CALLBACK _ => TRUE;
CURSOR _ => TRUE;
DIGITS _ => TRUE;
FROM _ => TRUE;
FONT _ => TRUE;
FOREGROUND _ => TRUE;
SLIDER_LABEL _ => TRUE;
LENGTH _ => TRUE;
ORIENT _ => TRUE;
RELIEF _ => TRUE;
RESOLUTION _ => TRUE;
SHOW_VALUE _ => TRUE;
SLIDER_LENGTH _ => TRUE;
SLIDER_RELIEF _ => TRUE;
ACTIVE _ => TRUE;
TICK_INTERVAL _ => TRUE;
TO _ => TRUE;
VARIABLE _ => TRUE;
WIDTH _ => TRUE;
REPEAT_DELAY _ => TRUE;
REPEAT_INTERVAL _ => TRUE;
THROUGH_COLOR _ => TRUE;
_ =>
{ print("Wrong configure option:\n" + config::conf_name c +
" not allowed for Scale!\n");
FALSE;}; esac);
check_one_widget_configure TEXT_ENTRY_TYPE c =>
(case c
BACKGROUND _ => TRUE;
BORDER_THICKNESS _ => TRUE;
CURSOR _ => TRUE;
FONT _ => TRUE;
TEXT _ => TRUE;
FOREGROUND _ => TRUE;
JUSTIFY _ => TRUE;
RELIEF _ => TRUE;
WIDTH _ => TRUE;
ACTIVE _ => TRUE;
SHOW _ => TRUE;
_ =>
{ print("Wrong configure option:\n" + config::conf_name c +
" not allowed for TEXT_ENTRY!\n");
FALSE;}; esac);
check_one_widget_configure CANVAS_TYPE c
=>
(case c
BACKGROUND _ => TRUE;
BORDER_THICKNESS _ => TRUE;
CURSOR _ => TRUE;
HEIGHT _ => TRUE;
RELIEF _ => TRUE;
SCROLL_REGION _ => TRUE;
WIDTH _ => TRUE;
_ =>
{ print("Wrong configure option:\n" + config::conf_name c +
" not allowed for Canvas!\n");
FALSE;}; esac);
check_one_widget_configure TEXT_WIDGET_TYPE c =>
(case c
BACKGROUND _ => TRUE;
BORDER_THICKNESS _ => TRUE;
CURSOR _ => TRUE;
FONT _ => TRUE;
FOREGROUND _ => TRUE;
HEIGHT _ => TRUE;
RELIEF _ => TRUE;
ACTIVE _ => TRUE;
WIDTH _ => TRUE;
WRAP _ => TRUE;
INNER_PAD_X _ => TRUE;
INNER_PAD_Y _ => TRUE;
_ =>
{ print("Wrong configure option:\n" + config::conf_name c +
" not allowed for TEXT_WIDGET!\n");
FALSE;}; esac);
check_one_widget_configure POPUP_TYPE c =>
(case c
BACKGROUND _ => TRUE;
BORDER_THICKNESS _ => TRUE;
CURSOR _ => TRUE;
FONT _ => TRUE;
FOREGROUND _ => TRUE;
TEAR_OFF _ => TRUE;
_ =>
{ print("Wrong configure option:\n" + config::conf_name c +
" not allowed for POPUP!\n");
FALSE;}; esac); end
also
fun check_widget_configure wt cs =
(if (config::no_dbl_p cs ) TRUE;
else { print "Double configure option in Widget definition!";
FALSE;};fi)
and
list::all (check_one_widget_configure wt) cs
also
fun check_one_widget_naming _ _ = TRUE # NOT YET IMPLEMENTED
also
fun check_widget_naming wt bs
=
bind::no_dbl_p bs
and
list::all ((check_one_widget_naming wt) o bind::sel_event) bs;
# ***********************************************************************
# SELECTING WIDGETS from the internal GUI state
# ***********************************************************************
# on the toplevel, widgets must be FRAMEs
# getWidgetGUIPath is a variant that has the internal path as argument
# is needed for use with the event loop
fun get_widget_guipath (window, p)
=
{ # my selWid: Widget -> String -> Widget
fun sel_wid w ""
=>
w;
sel_wid (w as LIST_BOX _) p
=>
if (p==".box")
w;
else raise exception WIDGET "Error occurred in function selWid 1";fi;
sel_wid (w as CANVAS _) p
=>
if (p == ".cnv")
w;
elif (list_util::prefix
(explode ".cnv.cfr" | reverse)
(explode p | reverse))
raise exception WIDGET ("widget_tree::getWidgetGUIPath: \"cfr\" should not appear");
else
debug::print 2 ("selWid (Canv) " + (get_widget_id w) + " " + p);
my (wid, np) = paths::fst_wid_path p; # strip ".cnv"
my (wid', np') = paths::fst_wid_path np; # strip ".cfr"
my (wid'', np'') = paths::fst_wid_path np';
debug::print 2 ("selWid (Canv) " + wid'' + " " + np'');
sel_wids (canvas_item::get_canvas_widgets w) wid'' np'';
fi;
sel_wid (w as TEXT_WIDGET _) p
=>
if (p==".txt")
w;
else
if (list_util::prefix
(explode ".cnv.tfr" | reverse)
(explode p | reverse))
raise exception WIDGET ("widget_tree::getWidgetGUIPath: \"tfr\" should not appear");
else
debug::print 2 ("selWid (Canv) " + (get_widget_id w) + " " + p);
my (wid, np) = paths::fst_wid_path p; # strip ".txt"
my (wid', np') = paths::fst_wid_path np; # strip ".tfr"
my (wid'', np'') = paths::fst_wid_path np';
debug::print 2 ("selWid (Canv) " + wid'' + " " + np'');
sel_wids (text_item::get_text_wid_widgets w) wid'' np'';
fi;
fi;
sel_wid (FRAME { subwidgets, ... } ) p
=>
{ my (wid, np) = paths::fst_wid_path p;
sel_wids (get_raw_widgets subwidgets) wid np;
};
sel_wid _ s
=>
raise exception WIDGET ("Error occurred in function selWid 3 " + s);
end
# my selWids: Widget List -> Widget_ID -> Widget_Path -> Widget
also
fun sel_wids wids w p
=
sel_wid (list_util::getx ((\\ x = w == x) o get_widget_id) wids
(WIDGET ("selWids with widgetId \"" + w + "\""))) p;
my (w, np) = paths::fst_wid_path p; # <-- w hier ""
sel_wids (get_window_subwidgets (get_window_gui window)) w np;
};
fun get_widget_gui w_id
=
get_widget_guipath (paths::get_int_path_gui w_id);
# ***********************************************************************
# ADDING WIDGETS to the internal GUI state
# ***********************************************************************
# my addWidgetPathAssGUI: Window_ID -> Widget_Path -> Widget -> Void
fun add_widget_path_ass_gui window p wid
=
if (paths::occurs_widget_gui (get_widget_id wid))
raise exception WIDGET("Two identical widget names not allowed: " +
(get_widget_id wid));
else
np = p + ("." + (get_widget_id wid));
ass = get_path_ass_gui();
nass = paths::add_widget (get_widget_id wid) window np ass;
upd_path_ass_gui nass;
case wid
FRAME { widget_id, subwidgets, ... }
=>
add_widgets_path_ass_gui window np
(get_raw_widgets subwidgets);
CANVAS _
=>
{ fun add_one (cit, ws)
=
{ np' = np + ".cnv." + (canvas_item::get_canvas_item_id cit);
add_widgets_path_ass_gui window np' ws;
};
assl = canvas_item::get_canvas_citem_widget_ass_list wid;
apply add_one assl;
};
TEXT_WIDGET _
=>
{ fun add_one (an, ws)
=
{ np' = np + ".txt." + (text_item::get_text_item_id an);
add_widgets_path_ass_gui window np' ws;
};
my
assl = text_item::get_text_wid_annotation_widget_ass_list wid;
apply add_one assl;
};
_ => ();
esac;
fi
# my addWidgetsPathAssGUI: Window_ID -> Widget_Path -> List( Widget ) -> Void
also
fun add_widgets_path_ass_gui w p wids
=
apply (add_widget_path_ass_gui w p) wids;
# my addWidgetGUI: Window_ID -> Widget_Path -> Widget -> Void
fun add_widget_gui window p wid
=
{ # my addWids: List( Widget ) -> Widget -> Widget_Path -> WidgetList
fun add_wids widgs widg ""
=>
{ debug::print 2 ("addWids (final)");
widgs @ [widg];
};
add_wids widgs widg wp
=>
{ my (w_id, nwp)
=
paths::fst_wid_path wp;
nwidg = list_util::getx ((\\ x => x==w_id; end ) o get_widget_id) widgs
(WIDGET ("addWids with widgetId \"" + w_id + "\""));
newwidg = add_wid nwidg widg nwp;
list_util::update_val
((\\ x = x == w_id) o get_widget_id) newwidg widgs;
};
end
# my addWid: Widget -> Widget -> Widget_Path -> Widget
also
fun add_wid (FRAME { widget_id, subwidgets, packing_hints, traits, event_callbacks } ) widg wp
=>
FRAME {
widget_id,
packing_hints,
traits,
event_callbacks,
subwidgets => case subwidgets
PACKED widgets
=>
PACKED (add_wids widgets widg wp);
GRIDDED widgets
=>
GRIDDED (add_wids widgets widg wp);
esac
};
add_wid (w as (CANVAS _)) widg wp
=>
{ debug::print 2 ("addWid (canv) " + " " + (get_widget_id w) + " " +
(get_widget_id widg) + " " + wp);
canvas_item::add_canvas_widget add_wids w widg wp;};
add_wid (w as (TEXT_WIDGET _)) widg wp
=>
{ debug::print 2 ("addWid (textw) " + " " + (get_widget_id w) + " " +
(get_widget_id widg) + " " + wp);
text_item::add_text_wid_widget add_wids w widg wp;};
add_wid _ _ _
=>
raise exception WIDGET
"addWidgetGUI: attempt to add widget to non-container widget";
end;
check_widget wid;
window = get_window_gui window;
newwids = add_wids (get_window_subwidgets window) wid p;
newwindow
=
( window,
get_window_traits window,
if (window_is_gridded window ) GRIDDED newwids;
else PACKED newwids; fi,
get_window_event_callbacks window,
get_window_callback window
);
debug::print 2 ("addWidgetGUI: done");
add_widget_path_ass_gui window p wid;
upd_window_gui window newwindow;
}
also
fun add_widgets_gui w p wids
=
apply (add_widget_gui w p) wids;
# ***********************************************************************
# DELETING WIDGETS from the internal GUI state
# ***********************************************************************
fun delete_widget_gui w_id
=
{
# my deleteWidgetPathAss: (Widget * PathAssList) -> PathAssList
fun delete_widget_path_ass ((widg as FRAME { widget_id, subwidgets, ... } ), ass)
=>
{ nass = delete_widgets_path_ass (get_raw_widgets subwidgets, ass);
paths::delete_widget widget_id nass;
};
delete_widget_path_ass ((widg as CANVAS { widget_id, ... } ), ass)
=>
{ widgs = canvas_item::get_canvas_widgets widg;
nass = delete_widgets_path_ass (widgs, ass);
paths::delete_widget widget_id nass;
};
delete_widget_path_ass ((widg as TEXT_WIDGET { widget_id, ... } ), ass)
=>
{ widgs = text_item::get_text_wid_widgets widg;
nass = delete_widgets_path_ass (widgs, ass);
paths::delete_widget widget_id nass;
};
delete_widget_path_ass (widg, ass)
=>
paths::delete_widget (get_widget_id widg) ass; end
# my deleteWidgetPathAss: (List( Widget ) * PathAssList) -> PathAssList
also
fun delete_widgets_path_ass (widgs, ass)
=
fold_backward delete_widget_path_ass ass widgs;
# my delWid: Widget -> Widget_ID -> Widget_Path -> Widget
fun del_wid (FRAME { widget_id, subwidgets, packing_hints, traits, event_callbacks } ) w p
=>
FRAME {
widget_id,
subwidgets => case subwidgets
PACKED widgets => PACKED (del_wids widgets w p);
GRIDDED widgets => GRIDDED (del_wids widgets w p); esac,
packing_hints,
traits,
event_callbacks
};
del_wid (widg as (CANVAS _)) w p
=>
canvas_item::delete_canvas_widget del_wids widg w p;
del_wid (widg as (TEXT_WIDGET _)) w p
=>
text_item::delete_text_wid_widget del_wids widg w p;
del_wid _ _ _
=>
raise exception WIDGET "Error occurred in function delWid"; end
# my delWids: List( Widget ) -> Widget_ID -> Widget_Path -> List( Widget )
also
fun del_wids wids w ""
=>
list::filter ((\\ x=> not (w == x); end )o get_widget_id) wids;
del_wids wids w p
=>
{ debug::print 2 ("delWids (Canv) " + w + " " + p);
wid = list_util::getx ((\\ x => w==x; end )o get_widget_id) wids
(WIDGET ("delWids with widgetId \"" + w + "\""));
my (nw, np) = paths::fst_wid_path p;
newwid = del_wid wid nw np;
list_util::update_val ((\\ x => w==x; end ) o get_widget_id) newwid wids;
}; end;
debug::print 2 ("deleteWidgetGUI " + w_id);
widg = get_widget_gui w_id;
my (ip as (window, p)) = paths::get_int_path_gui w_id;
ass = get_path_ass_gui();
nass = delete_widget_path_ass (widg, ass);
debug::print 2 ("deleteWidgetGUI (after nass) " + w_id);
my (nw, np) = paths::fst_wid_path p;
window = get_window_gui window;
newwids = del_wids (get_window_subwidgets window) nw np;
newwindow
=
( window,
get_window_traits window,
if (window_is_gridded window ) GRIDDED newwids;
else PACKED newwids;fi,
get_window_event_callbacks window,
get_window_callback window
);
upd_window_gui window newwindow;
upd_path_ass_gui nass;
};
fun delete_widget_guipath ip
=
delete_widget_gui (get_widget_id (get_widget_guipath ip));
# ***********************************************************************
# 3F. UPDATING WIDGETS in the internal GUI state
# ***********************************************************************
# updWidgetPath . IntPath -> Widget s -> GUI s -> ((), GUI s)
fun upd_widget_guipath (window, p) w
=
{
debug::print 2 ("updWidgetGUIPath " + window + " " + p + " " + (get_widget_id w));
# my updWids: List( Widget ) -> Widget_ID -> Widget_Path -> Widget -> List( Widget )
fun upd_wids wids w "" neww
=>
list_util::update_val ((\\ x => w==x; end ) o get_widget_id) neww wids;
upd_wids wids w p neww
=>
{
debug::print 2 ("updWids " + w + " " + p); my
wid = list_util::getx ((\\ x => w==x; end ) o get_widget_id) wids
(WIDGET ("updWids with widgetId " + w));
my
(nw, np) = paths::fst_wid_path p; my
newwid = upd_wid wid nw np neww;
list_util::update_val ((\\ x => w==x; end ) o get_widget_id) newwid wids;
}; end
# my updWid: Widget -> Widget_ID -> Widget_Path -> Widget -> Widget
also
fun upd_wid (FRAME { widget_id, subwidgets, packing_hints, traits, event_callbacks } ) w p neww
=>
FRAME {
widget_id,
subwidgets => case subwidgets PACKED widgets => PACKED (upd_wids widgets w p neww);
GRIDDED widgets => GRIDDED (upd_wids widgets w p neww); esac,
packing_hints,
traits,
event_callbacks
};
upd_wid (widg as (CANVAS _)) w p neww
=>
{ debug::print 2 ("updWid (Canv) " + (get_widget_id widg) + " " + w + " " + p);
canvas_item::upd_canvas_widget upd_wids widg w p neww;};
upd_wid (widg as (TEXT_WIDGET _)) w p neww
=>
{ debug::print 2 ("updWid (TextWid) " + (get_widget_id widg) + " " + w + " " + p);
text_item::upd_text_wid_widget upd_wids widg w p neww;};
upd_wid _ _ _ _
=>
raise exception WIDGET "Error occurred in function updWid"; end;
my
(nw, np) = paths::fst_wid_path p; my
window = get_window_gui window; my
newwids = upd_wids (get_window_subwidgets window) nw np w; my
newwindow = (window, get_window_traits window,
if (window_is_gridded window)
GRIDDED newwids;
else
PACKED newwids;fi,
get_window_event_callbacks window,
get_window_callback window);
upd_window_gui window newwindow;
};
fun upd_widget_gui w
=
upd_widget_guipath (paths::get_int_path_gui (get_widget_id w)) w;
# ***********************************************************************
# ADDING WIDGETS to the "real" GUI
# ***********************************************************************
# -- i.e. sending pack commands to Tcl/Tk
fun is_grid_path (window, p)
=
if (p == "")
window_is_gridded (get_window_gui window);
else
case (get_widget_guipath (window, p))
FRAME { subwidgets, ... }
=>
case subwidgets
GRIDDED _ => TRUE;
_ => FALSE;
esac;
_ => FALSE;
esac;
fi
except
WIDGET _
=
is_grid_path (window, #1 (paths::last_wid_path p));
fun pack_widgets do_p tp ip gopt ws
=
cat (map (pack_widget do_p tp ip gopt) ws)
also
fun pack_widget do_p tp (window, p) gopt w
=
{ my
wid = get_widget_id w; my
nip = (window, p + "." + wid); my
ntp = tp + "." + wid;
my
grid
=
if (not_null gopt)
the gopt;
else
is_grid_path (window, p);fi;
check_widget w;
case w
FRAME { subwidgets, packing_hints, traits, event_callbacks, ... }
=>
(pack_wid do_p "frame" ntp nip wid packing_hints traits event_callbacks
grid +
pack_widgets TRUE ntp nip (THE (is_gridded subwidgets))
(get_raw_widgets subwidgets));
MESSAGE { packing_hints, traits, event_callbacks, ... }
=>
pack_wid do_p "message" ntp nip wid packing_hints traits event_callbacks
grid;
LIST_BOX { scrollbars, packing_hints, traits, event_callbacks, ... }
=>
pack_listbox do_p ntp nip wid scrollbars packing_hints traits
event_callbacks grid;
LABEL { packing_hints, traits, event_callbacks, ... }
=>
pack_wid do_p "label" ntp nip wid packing_hints traits event_callbacks grid;
BUTTON { packing_hints, traits, event_callbacks, ... }
=>
pack_wid do_p "button" ntp nip wid packing_hints traits event_callbacks grid;
RADIO_BUTTON { packing_hints, traits, event_callbacks, ... }
=>
pack_wid do_p "radiobutton" ntp nip wid packing_hints traits event_callbacks
grid;
CHECK_BUTTON { packing_hints, traits, event_callbacks, ... }
=>
pack_wid do_p "checkbutton" ntp nip wid packing_hints traits event_callbacks
grid;
MENU_BUTTON { mitems, packing_hints, traits, event_callbacks, ... }
=>
pack_menu do_p ntp nip wid mitems packing_hints traits event_callbacks grid;
TEXT_WIDGET { scrollbars, live_text, packing_hints, traits, event_callbacks, ... }
=>
pack_text_wid do_p ntp nip wid scrollbars
(live_text::get_livetext_text live_text)
(live_text::get_livetext_text_items live_text) packing_hints traits
event_callbacks grid;
CANVAS { scrollbars, citems, packing_hints, traits, event_callbacks, ... }
=>
pack_canvas do_p ntp nip wid scrollbars citems packing_hints traits
event_callbacks grid;
POPUP { mitems, traits, ... }
=>
pack_popup do_p ntp nip wid mitems traits;
TEXT_ENTRY { packing_hints, traits, event_callbacks, ... }
=>
pack_wid do_p "entry" ntp nip wid packing_hints traits event_callbacks grid;
SCALE_WIDGET { packing_hints, traits, event_callbacks, ... }
=>
pack_wid do_p "scale" ntp nip wid packing_hints traits event_callbacks grid; esac;
}
also
fun pack_wid0 do_p s tp ip w pack conf confstr binds grid
=
if do_p
((if grid
("grid [" + s + " " + tp + " " + config::pack ip conf +
confstr + "] " + (config::grid_info pack) + "\n");
else ("pack [" + s + " " + tp + " " + config::pack ip conf +
confstr + "] " + (config::pack_info pack) + "\n");fi) +
cat (bind::pack_widget tp ip binds));
else
(s + " " + tp + " " + config::pack ip conf + confstr + "\n" +
cat (bind::pack_widget tp ip binds));
fi
also
fun pack_wid do_p s tp ip w pack conf binds grid
=
pack_wid0 do_p s tp ip w pack conf "" binds grid
also
fun pack_menu do_p tp (ip as (window, p)) w ms pack conf binds grid
=
{ my
mip = (window, p + ".m"); my
mtp = tp + ".m"; my
conf' = list::filter
(not o (config::conf_eq (TEAR_OFF TRUE)))
conf;
my
to
=
case (list::find (config::conf_eq (TEAR_OFF TRUE)) conf)
NULL => TRUE;
THE (TEAR_OFF b) => b; esac;
((if do_p
((if grid
"grid [menubutton " + tp + " " +
config::pack ip conf' + " -menu " + mtp +
"] " + config::grid_info pack + "\n";
else
"pack [menubutton " + tp + " " +
config::pack ip conf' + " -menu " + mtp +
"] " + config::pack_info pack + "\n";fi) +
cat (bind::pack_widget tp ip binds));
else
("menubutton " + tp + " " +
config::pack ip conf' + " -menu " + mtp + "\n" +
cat (bind::pack_widget tp ip binds));fi) +
"menu " + mtp + " -tearoff " + (bool::to_string to) + "\n" +
pack_menu_items mtp mip w ms []);
}
also
fun pack_popup do_p tp (ip as (window, p)) w ms conf
=
{ my
mip = (window, p + ".pop"); my
mtp = tp + ".pop";
"menu " + tp + config::pack ip conf + "\n" + pack_menu_items tp ip w ms [];
}
also
fun pack_menu_items tp ip wid mis m_item_path
=
{ fun pmi tp ip w [] n => "";
pmi tp ip w (m . ms) n =>
(pack_menu_item tp ip w m (n . m_item_path) +
pmi tp ip w ms (n+1)); end;
pmi tp ip wid mis 0;
}
also
fun pack_menu_item tp ip w (MENU_SEPARATOR) n
=>
tp + " add separator" + "\n";
pack_menu_item tp ip w (MENU_CHECKBUTTON (cs)) n
=>
tp + " add checkbutton " + config::pack_m ip (reverse n) cs + "\n";
pack_menu_item tp ip w (MENU_RADIOBUTTON (cs)) n
=>
tp + " add radiobutton "+ config::pack_m ip (reverse n) cs + "\n";
pack_menu_item tp (ip as (window, p)) w (MENU_CASCADE (ms, cs)) (n . s)
=>
{ my
ntp = tp + ".m" + int::to_string n; my
n2 = reverse (n . s); my
cs' = list::filter
(not o (config::conf_eq (TEAR_OFF TRUE)))
cs;
my
to =
case (list::find (config::conf_eq (TEAR_OFF TRUE)) cs)
NULL => TRUE;
THE (TEAR_OFF b) => b; esac;
(tp + " add cascade " + config::pack_m ip n2 cs' + " -menu " + ntp + "\n" +
"menu " + ntp + " -tearoff " + (bool::to_string to) + "\n" +
pack_menu_items ntp ip w ms (n . s));
};
pack_menu_item tp ip w (MENU_COMMAND cs) n
=>
tp + " add command " + config::pack_m ip (reverse n) cs + "\n";
end
# Around Listboxes, there is always a FRAME. This has the advantage, that
# packing can treat "Listbox with scrollbar" as a unit. Commands address-
# ing the "Listbox" have to take into account this change of paths...
also
fun pack_listbox do_p tp (ip as (window, pt)) wid NOWHERE p c b grid
=>
{ my
bip = (window, pt + ".box"); my
btp = tp + ".box";
( pack_wid do_p "frame" tp ip wid p [] [] grid +
pack_wid TRUE "listbox" btp bip wid [FILL XY, EXPAND TRUE] c b FALSE
);
};
pack_listbox do_p tp (ip as (window, pt)) wid scb /* C */ p c b grid
=>
if (single scb)
bip = (window, pt + ".box");
btp = tp + ".box";
scip = (window, pt + ".screen");
sctp = tp + ".screen";
si = PACK_AT (scrolltype_to_horizontal_edge scb);
siquer = PACK_AT (scrolltype_to_opposite_horizontal_edge scb);
(pack_wid do_p "frame" tp ip wid p [] [] grid +
pack_wid TRUE "listbox" btp bip wid
[siquer, FILL XY, EXPAND TRUE] c b FALSE +
pack_wid TRUE "scrollbar" sctp scip wid [si, FILL ONLY_Y] [] []
FALSE +
btp + " configure -yscrollcommand \"" + sctp + " set \" " + "\n" +
sctp + " configure -command \"" + btp + " yview\"" + "\n");
else
bip = (window, pt + ".box");
btp = tp + ".box";
vscip = (window, pt + ".hscr");
hscip = (window, pt + ".vscr");
vsctp = tp + ".hscr";
hsctp = tp + ".vscr";
my (scb_hpack, scb_vpack, boxpack)
=
scrolltype_to_grid_coords scb;
(pack_wid do_p "frame" tp ip wid p [] [] grid +
pack_wid TRUE "scrollbar" hsctp hscip wid (scb_hpack @ [STICK TO_EW])
[] [] TRUE +
pack_wid TRUE "scrollbar" vsctp vscip wid (scb_vpack @ [STICK TO_NS])
[] [] TRUE +
pack_wid TRUE "listbox" btp bip wid (boxpack @ [STICK TO_NSEW]) c b
TRUE +
btp + " configure -xscrollcommand \"" + hsctp +
" set \" " + "\n" +
hsctp + " configure -command \"" + btp +
" xview\"" + " -orient horizontal" + "\n" +
btp + " configure -yscrollcommand \"" + vsctp +
" set \" " + "\n" +
vsctp + " configure -command \"" + btp +
" yview\"" + "\n");
fi;
end
# Around Canvases, there is always a FRAME. This has the advantage, that
# packing can treat "Canvas with scrollbar" as a unit. Commands address-
# ing the "Canvas" have to take into account this change of paths...
also
fun pack_canvas do_p tp (ip as (window, pt)) wid NOWHERE ci p c b grid
=>
{ my
cip = (window, pt + ".cnv"); my
ctp = tp + ".cnv";
(pack_wid do_p "frame" tp ip wid p [] [] grid +
pack_wid TRUE "canvas" ctp cip wid [FILL XY, EXPAND TRUE] c b FALSE +
cat (map (canvas_item::pack pack_widget ctp cip) ci));
};
pack_canvas do_p tp (ip as (window, pt)) wid scb ci p c b grid
=>
if (single scb)
if (orient scb)
{ my
cip = (window, pt + ".cnv"); my
ctp = tp + ".cnv"; my
vscip = (window, pt + ".hscr"); my
vsctp = tp + ".hscr"; my
vsi = PACK_AT (scrolltype_to_horizontal_edge scb); my
siquer = PACK_AT (scrolltype_to_opposite_horizontal_edge scb);
(pack_wid do_p "frame" tp ip wid p [] [] grid +
pack_wid TRUE "canvas" ctp cip wid
[siquer, FILL XY, EXPAND TRUE] c b FALSE +
pack_wid TRUE "scrollbar" vsctp vscip wid [vsi, FILL ONLY_Y] [] []
FALSE +
ctp + " configure -yscrollcommand \"" + vsctp +
" set \" " + "\n" +
vsctp + " configure -command \"" + ctp + " yview\"" + "\n" +
cat (map (canvas_item::pack pack_widget ctp cip) ci));
};
else
{ my
cip = (window, pt + ".cnv"); my
ctp = tp + ".cnv"; my
hscip = (window, pt + ".vscr"); my
hsctp = tp + ".vscr"; my
hsi = PACK_AT (scrolltype_to_vertical_edge scb); my
siquer = PACK_AT (scrolltype_to_opposite_vertical_edge scb);
(pack_wid do_p "frame" tp ip wid p [] [] grid +
pack_wid TRUE "canvas" ctp cip wid
[siquer, FILL XY, EXPAND TRUE] c b FALSE +
pack_wid TRUE "scrollbar" hsctp hscip wid [hsi, FILL ONLY_X] [] []
FALSE +
ctp + " configure -xscrollcommand \"" + hsctp +
" set \" " + "\n" +
hsctp + " configure -command \"" + ctp +
" xview\"" + " -orient horizontal" + "\n" +
cat (map (canvas_item::pack pack_widget ctp cip) ci));
};fi;
else # two scrollbars
{ my
cip = (window, pt + ".cnv"); my
ctp = tp + ".cnv"; my
vscip = (window, pt + ".hscr"); my
hscip = (window, pt + ".vscr"); my
vsctp = tp + ".hscr"; my
hsctp = tp + ".vscr"; my
(scb_hpack, scb_vpack, cnvpack)
=
scrolltype_to_grid_coords scb;
(pack_wid do_p "frame" tp ip wid p [] [] grid +
pack_wid TRUE "scrollbar" hsctp hscip wid (scb_hpack @ [STICK TO_EW])
[] [] TRUE +
pack_wid TRUE "scrollbar" vsctp vscip wid (scb_vpack @ [STICK TO_NS])
[] [] TRUE +
pack_wid TRUE "canvas" ctp cip wid
(cnvpack @ [STICK TO_NSEW]) c b TRUE +
ctp + " configure -xscrollcommand \"" + hsctp +
" set \" " + "\n" +
hsctp + " configure -command \"" + ctp +
" xview\"" + " -orient horizontal" + "\n" +
ctp + " configure -yscrollcommand \"" + vsctp +
" set \" " + "\n" +
vsctp + " configure -command \"" + ctp +
" yview\"" + "\n" +
cat (map (canvas_item::pack pack_widget ctp cip) ci));
};fi; end
# At the moment only empty taglists ...
also
fun pack_text_wid do_p tp (ip as (window, pt)) wid NOWHERE t ans p c b grid
=>
{ my
fdef = FONT (fonts::NORMAL_FONT [fonts::NORMAL_SIZE]);
my
bip = (window, pt + ".txt"); my
btp = tp + ".txt";
my
nc = list::filter
(not o (config::conf_eq (ACTIVE TRUE)))
c;
my
sc = list::filter
(config::conf_eq (ACTIVE TRUE))
c;
my
tt = btp + " insert end \"" + string_util::adapt_string t +
"\"" + "\n";
my
stt = btp + " configure " + (config::pack bip sc) + "\n";
my
nc' =
if (list::exists (config::conf_eq fdef) nc) nc; else fdef . nc;fi;
(pack_wid do_p "frame" tp ip wid p [] [] grid +
pack_wid TRUE "text" btp bip wid [FILL XY, EXPAND TRUE] nc' b FALSE +
tt + stt +
cat (map (text_item::pack pack_widget btp bip) ans));
};
pack_text_wid do_p tp (ip as (window, pt)) wid scb t ans p c b grid
=>
if (single scb)
# one scrollbar
{
fdef = FONT (fonts::NORMAL_FONT [fonts::NORMAL_SIZE]);
bip = (window, pt + ".txt");
btp = tp + ".txt";
scip = (window, pt + ".screen");
sctp = tp + ".screen";
si = PACK_AT (scrolltype_to_horizontal_edge scb);
siquer = PACK_AT (scrolltype_to_opposite_horizontal_edge scb);
nc = list::filter (not o (config::conf_eq (ACTIVE TRUE))) c;
sc = list::filter (config::conf_eq (ACTIVE TRUE)) c;
tt = btp + " insert end \"" + string_util::adapt_string t +
"\"" + "\n";
stt = btp + " configure " + config::pack bip sc + "\n";
nc' =
if (list::exists (config::conf_eq fdef) nc) nc; else fdef . nc;fi;
(pack_wid do_p "frame" tp ip wid p [] [] grid +
pack_wid TRUE "text" btp bip wid [siquer, FILL XY, EXPAND TRUE] nc'
b FALSE +
pack_wid TRUE "scrollbar" sctp scip wid [si, FILL ONLY_Y] [] [] FALSE +
btp + " configure -yscrollcommand \"" + sctp + " set \" " + "\n" +
sctp + " configure -command \"" + btp + " yview\"" + "\n" +
tt + stt +
cat (map (text_item::pack pack_widget btp bip) ans));
};
else # two scrollbars
{
fdef = FONT (fonts::NORMAL_FONT [fonts::NORMAL_SIZE]);
bip = (window, pt + ".txt");
btp = tp + ".txt";
vscip = (window, pt + ".hscr");
hscip = (window, pt + ".vscr");
vsctp = tp + ".hscr";
hsctp = tp + ".vscr";
my (scb_hpack, scb_vpack, txtpack) = scrolltype_to_grid_coords scb;
nc = list::filter (not o (config::conf_eq (ACTIVE TRUE))) c;
sc = list::filter (config::conf_eq (ACTIVE TRUE)) c;
tt = btp + " insert end \"" + string_util::adapt_string t +
"\"" + "\n";
stt = btp + " configure " + config::pack bip sc + "\n";
nc' =
if (list::exists (config::conf_eq fdef) nc) nc; else fdef . nc;fi;
(pack_wid do_p "frame" tp ip wid p [] [] grid +
pack_wid TRUE "scrollbar" hsctp hscip wid (scb_hpack @ [STICK TO_EW])
[] [] TRUE +
pack_wid TRUE "scrollbar" vsctp vscip wid (scb_vpack @ [STICK TO_NS])
[] [] TRUE +
pack_wid TRUE "text" btp bip wid (txtpack @ [STICK TO_NSEW]) nc'
b TRUE +
btp + " configure -xscrollcommand \"" + hsctp +
" set \" " + "\n" +
hsctp + " configure -command \"" + btp +
" xview\"" + " -orient horizontal" + "\n" +
btp + " configure -yscrollcommand \"" + vsctp +
" set \" " + "\n" +
vsctp + " configure -command \"" + btp +
" yview\"" + "\n" +
tt + stt +
cat (map (text_item::pack pack_widget btp bip) ans));
};fi; end;
# ***********************************************************************
# UPDATING WIDGETS in the "real" GUI
# ***********************************************************************
/* General Case
-- the widget and its younger brothers must be destroyed
-- and then newly packed.
*/
# my selWidgetsFrom: Widget -> Widget_ID -> List( Widget )
/*
# updPackWidgetPath . IntPath -> GIO s ()
fun updWidgetPackPath (window, p)
=
let
fun selWidgetsFrom (Frame(_, ws, _, _, _))w
=
dropWhile((\\ x => w/=x)o get_widget_ID) ws
| selWidgetsFrom _ _ =
raise exception WIDGET "Error occurred in selWidgetsFrom"
my (fp, w) = paths::lastWidPath p
ftp = paths::getTclPathGUI (window, fp)
in
if fp == "" then
let
wids = dropWhile ((\\ x=>w/=x)o get_widget_ID)
(get_window_subwidgets (getWindowGUI window))
in
packWidgets TRUE ftp (window, fp) wids
end
else
let
wids = selWidgetsFrom (getWidgetGUIPath (window, fp)) w
in
packWidgets TRUE ftp (window, fp) wids
end
end
fun update_widget_packing_hints w
=
updWidgetPackPath (paths::getIntPathGUI (get_widget_ID w))
/* Special Cases
-- here we only have to send the appropriate Tcl/Tk scripts.
*/
fun updConfigurePack wId cs
=
com::putTclCmd (config::pack (paths::getIntPathGUI wId) cs)
fun updNamingPack w bs
=
let ip = paths::getIntPathGUI w
tp = paths::getTclPathGUI ip
in
basic_utilities::apply com::putTclCmd (bind::packWidget tp ip bs)
end
*/
# ***********************************************************************
# 3H. EXPORTED FUNCTIONS
# ***********************************************************************
select_widget = get_widget_gui;
select_widget_path = get_widget_guipath;
fun delete_widget wid
=
{ debug::print 2 ("deleteWidget " + wid);
com::put_tcl_cmd ("destroy " +
(paths::get_tcl_path_gui (paths::get_int_path_gui wid)));
delete_widget_gui wid;};
fun add_widget window_id widget_id widg
=
{ my
wid_path = paths::get_wid_path_gui widget_id;
add_widget_gui window_id wid_path widg;
{ /* Kurzform: hoffentlich hab ich das mit den Pfanden
alles richtig verstanden
nip = (window_id, widPath)
ntclp = paths::getTclPathGUI nip
*/
w_id = get_widget_id widg;
my (window, wp) = paths::get_int_path_gui w_id;
my (nwp, l) = paths::last_wid_path wp;
nip = (window, nwp);
ntclp = paths::get_tcl_path_gui nip;
nwidg = get_widget_gui w_id;
debug::print 2 ("addWidget: " + ntclp + " (" + window + ", " + nwp + ") " + w_id);
com::put_tcl_cmd (pack_widget TRUE ntclp nip NULL nwidg);
};
};
/*
# -- not yet implemented (sigh...)
fun updateWidget w
=
(checkWidget w;
let
ip = paths::getIntPathGUI (get_widget_ID w)
in
updWidgetGUIPath ip w;
updWidgetPackPath ip
end)
*/
# ***********************************************************************
#
# IMPLEMENTATION: WIDGET CONTENTS
#
# ***********************************************************************
# EXPORTED FUNCTIONS
select = get_the_widget_traits o get_widget_gui;
select_command = config::sel_command o get_widget_gui;
select_command_path = config::sel_command o get_widget_guipath;
select_scommand_path = config::sel_scommand o get_widget_guipath;
# This function gets the path of the MENU_BUTTON:
fun select_mcommand_path ip n
=
{ w = get_widget_guipath ip;
fun sel_cascade ms [n]
=>
list::nth (ms, n);
sel_cascade ms (n . m . s)
=>
case (list::nth (ms, n))
MENU_CASCADE (mms, _) => sel_cascade mms (m . s); esac; end;
case w
MENU_BUTTON { mitems, ... }
=>
config::get_menu_item_callback (sel_cascade mitems n);
POPUP { mitems, ... }
=>
config::get_menu_item_callback (sel_cascade mitems n);
_
=>
\\ () => (); end ; esac;
};
# This function gets the menu path, i.e. a path with .m suffix:
fun select_mcommand_mpath (window, mp) n
=
{ my (p, m) = paths::last_wid_path mp;
if (m == "m") select_mcommand_path (window, p ) n;
else select_mcommand_path (window, mp) n;
fi;
};
fun select_mcommand w_id n
=
select_mcommand_path (paths::get_int_path_gui w_id) n;
select_namings = get_the_widget_event_callbacks o get_widget_gui;
fun select_bind_key w_id name
=
bind::get_action_by_name name (get_the_widget_event_callbacks (get_widget_gui w_id));
fun select_bind_key_path ip name
=
bind::get_action_by_name name (get_the_widget_event_callbacks (get_widget_guipath ip));
select_width = config::get_width o get_widget_gui;
select_height = config::get_height o get_widget_gui;
select_relief = config::sel_relief o get_widget_gui;
fun configure w cs
=
{ ip = paths::get_int_path_gui w;
wid = get_widget_guipath ip;
tp = paths::get_tcl_path_gui ip;
ntp =
case wid
TEXT_WIDGET _ => tp + ".txt";
CANVAS _ => tp + ".cnv";
_ => tp;
esac;
if (check_widget_configure (get_widget_type wid) cs)
oldcs = get_the_widget_traits wid;
newcs = config::add oldcs cs;
newwid = set_the_widget_traits wid newcs;
upd_widget_guipath ip newwid;
com::put_tcl_cmd (ntp + " configure " + config::pack ip cs);
else
raise exception CONFIG "Trying to reconfigure with wrong type of configures";
fi;
};
fun newconfigure w cs
=
{ ip = paths::get_int_path_gui w;
wid = get_widget_guipath ip;
wt = get_widget_type wid;
tp = paths::get_tcl_path_gui ip;
ntp =
case wid
TEXT_WIDGET _ => tp + ".txt";
CANVAS _ => tp + ".cnv";
_ => tp; esac;
if (check_widget_configure wt cs)
oldcs = get_the_widget_traits wid;
newcs = config::new wt oldcs cs;
newwid = set_the_widget_traits wid newcs;
upd_widget_guipath ip newwid;
com::put_tcl_cmd (ntp + " configure " + config::pack ip newcs);
else
raise exception CONFIG "Trying to reconfigure with wrong type of configures";
fi;
};
fun configure_command w c = configure w [CALLBACK c];
fun configure_width w n = configure w [WIDTH n];
fun configure_relief w r = configure w [RELIEF r];
fun configure_text w t = configure w [TEXT t];
fun add_namings w bs
=
{ ip = paths::get_int_path_gui w;
wid = get_widget_guipath ip;
tp = paths::get_tcl_path_gui ip;
ntp = case wid
TEXT_WIDGET _ => tp + ".txt";
CANVAS _ => tp + ".cnv";
_ => tp;
esac;
if (check_widget_naming (get_widget_type wid) bs)
oldbs = get_the_widget_event_callbacks wid;
newbs = bind::add oldbs bs;
newwid = set_the_widget_event_callbacks wid newbs;
upd_widget_guipath ip newwid;
com::put_tcl_cmd (cat (bind::pack_widget ntp ip bs));
else
raise exception CONFIG "Trying to add wrong event_callbacks";
fi;
};
fun new_namings w bs
=
{ ip = paths::get_int_path_gui w;
wid = get_widget_guipath ip;
wt = get_widget_type wid;
tp = paths::get_tcl_path_gui ip;
ntp = case wid
TEXT_WIDGET _ => tp + ".txt";
CANVAS _ => tp + ".cnv";
_ => tp;
esac;
if (check_widget_naming wt bs)
oldbs = get_the_widget_event_callbacks wid;
oldks = bind::delete oldbs bs;
newwid = set_the_widget_event_callbacks wid bs;
upd_widget_guipath ip newwid;
com::put_tcl_cmd
( cat (bind::unpack_widget ntp wt oldks)
+ cat (bind::pack_widget ntp ip bs)
);
else
raise exception CONFIG "Trying to newly set wrong event_callbacks";
fi;
};
fun insert_text wid str m
=
{ tp = paths::get_wid_path_gui wid;
ip = paths::get_int_path_gui wid;
w = get_widget_guipath ip;
my (m1, _)= string_util::break_at_dot (mark::show m);
case w
TEXT_WIDGET _
=>
com::put_tcl_cmd ((paths::get_tcl_path_gui ip) +
".txt insert " + mark::show m + " \"" +
string_util::adapt_string str + "\"");
LIST_BOX _
=>
com::put_tcl_cmd ((paths::get_tcl_path_gui ip) +
".box insert " + m1 +
" \"" + string_util::adapt_string str + "\" ");
TEXT_ENTRY _
=>
com::put_tcl_cmd ((paths::get_tcl_path_gui ip) + " insert " + m1 +
" \"" + string_util::adapt_string str + "\" ");
_
=>
raise exception WIDGET "text insertion in illegal window"; esac;
};
fun insert_text_end wid str
=
insert_text wid str MARK_END;
fun delete_text wid (from, to)
=
{ tp = paths::get_wid_path_gui wid;
ip = paths::get_int_path_gui wid;
w = get_widget_guipath ip;
my (m1, _) = string_util::break_at_dot (mark::show from);
my (m2, _) = string_util::break_at_dot (mark::show to);
case w
TEXT_WIDGET _
=>
com::put_tcl_cmd ((paths::get_tcl_path_gui ip) + ".txt delete " +
mark::show from + " " + mark::show to);
LIST_BOX _
=>
com::put_tcl_cmd ((paths::get_tcl_path_gui ip) + ".box delete " + m1 +
" " + m2);
TEXT_ENTRY _
=>
com::put_tcl_cmd ((paths::get_tcl_path_gui ip) + " delete " + m1 +
" " + m2);
_
=>
raise exception WIDGET "text deletion in illegal window"; esac;
};
fun clear_text wid
=
delete_text wid (MARK (0, 0), MARK_END);
fun focus window
=
if (window == "main"
or window == "."
)
com::put_tcl_cmd "focus .";
else
com::put_tcl_cmd ("focus ." + window);
fi;
fun de_focus _
=
com::put_tcl_cmd "focus .";
/* somewhat buggy: XXX BUGGO FIXME
let
my (window, p) = paths::getIntPathGUI wid
in
if ( window == "main" ) then
com::putTclCmd ("focus .")
else
com::putTclCmd ("focus ." + window)
end
*/
fun grab window
=
if (window == "main" or window == ".")
com::put_tcl_cmd "grab set .";
else
com::put_tcl_cmd ("grab set ." + window);fi;
fun de_grab window
=
if (window == "main" or window == ".")
com::put_tcl_cmd "grab release .";
else com::put_tcl_cmd ("grab release ." + window);fi;
fun pop_up_menu wid index co
=
{ tp = paths::get_tcl_path_gui (paths::get_int_path_gui wid);
cot = coordinate::show [co];
fun pop_it_up (MENU_BUTTON _) (THE i)
=>
com::put_tcl_cmd ("tk_popup " + tp + ".m " + cot + " " +
int::to_string (i: Int));
pop_it_up (MENU_BUTTON _) NULL
=>
com::put_tcl_cmd ("tk_popup " + tp + ".m " + cot);
pop_it_up (POPUP _ ) (THE i)
=>
com::put_tcl_cmd ("tk_popup " + tp + " " + cot + " " +
int::to_string (i: Int));
pop_it_up (POPUP _ ) NULL
=>
com::put_tcl_cmd ("tk_popup " + tp + " " + cot);
pop_it_up _ _
=>
raise exception WIDGET "widget_tree::pop_up_menu: tried to pop up non-MenuWidget";
end;
widg = get_widget_gui wid;
pop_it_up widg index;
};
/* doesn't really work --- XXX BUGGO FIXME
fun make_and_pop_up_window widg index co
=
let
winid = paths::make_widget_id()
frmid = paths::make_widget_id()
frm = Frame (frmId, [widg], [], [], [])
wid = get_widget_ID widg
in
window::openW (winid, [], [frm], \\()=> ());
pop_up_menu wid frmid co
end
*/
end;
};