# ***********************************************************************
#
# Project: sml/Tk: an Tk Toolkit for sml
# Author: Burkhart Wolff, University of Bremen
# Date: 25.7.95
# Purpose of this file: Abstract data Type Window
#
# ***********************************************************************
# Compiled by:
# src/lib/tk/src/tk.sublibpackage window
: (weak) Window # Window is from src/lib/tk/src/windows.api{
include package basic_utilities;
include package basic_tk_types;
include package gui_state;
# ***********************************************************************
#
# IMPLEMENTATION: WINDOWS
#
# ***********************************************************************
# functions related to Window Namings
fun sel_window_naming (_, _, _, bds, _)
=
bds;
fun select_bind_key_path window name
=
bind::get_action_by_name name (sel_window_naming (gui_state::get_window_gui window));
# I'm not sure if it could be called before the window is added to
/* the internal GUI state. Therefore True as well if no window is */
# present as if it really is the first in the GUI state.
# isInitWin . Window_ID -> GUI s -> (Bool, GUI s)
/* Moved To Basic_Tk_Types for visibility reasons
fun isInitWin w =
(\\ ([], _) => TRUE | (window . windows, _) => (w = (window_id window))) *gui_state;
*/
# CHECKING the INTEGRITY of a WINDOW
# window title may contain alphanumerical characters only
fun check_window_id ""
=>
FALSE;
check_window_id s
=>
(char::is_lower (string::get_byte_as_char (s, 0))) and (string_util::all char::is_alpha_num s);
end;
check_title = string_util::all char::is_print;
fun check (window as (w, wcnfgs, wids, _, _))
=
{ mbt = config::sel_window_title window;
bb = check_window_id w;
case mbt
NULL => bb;
THE t => check_title t and bb; esac;
};
fun append_gui w
=
upd_windows_gui (get_windows_gui() @ [w]);
fun add_gui (w as (window_id, wcnfgs, widgs, binds, act))
=
if (check w)
if (paths::occurs_window_gui (get_window_id w))
raise exception WINDOWS ("Two identical window names not allowed: " +
(get_window_id w));
else
tmp_window = (window_id, wcnfgs,
if (window_is_gridded w ) GRIDDED []; else PACKED [];fi,
binds, act);
{ append_gui tmp_window;
widget_tree::add_widgets_gui window_id "" (get_raw_widgets widgs);};
fi;
else
raise exception WINDOWS ("Definition of window " + get_window_id w + " is not OK");fi;
fun delete_gui w
=
{ wins = get_windows_gui();
ass = get_path_ass_gui();
nwins = list::filter ((\\ x => not (w==x); end ) o get_window_id) wins;
nass = paths::delete_window w ass;
upd_gui (nwins, nass);
};
delete_all_gui = upd_gui([], []);
# 2F. EXPORTED FUNCTIONS
fun open_w (w as (window, wconfigs, widgets, event_callbacks, init_action))
=
{ add_gui w;
if (is_init_window window)
(com::put_tcl_cmd (cat (map (config::pack_window_conf ".")
wconfigs) +
cat (bind::pack_window window event_callbacks) +
"bind . <Destroy> { if {\"%W\" == \".\"} {" +
com::comm_to_tcl + " \"Destroy " +
window + " <Destroy> " + tk_event::show() + " \"}}\n" +
widget_tree::pack_widgets TRUE "" (window, "") NULL
(get_raw_widgets widgets)));
else
(com::put_tcl_cmd ("toplevel ." + window + "\n" +
cat (map (config::pack_window_conf ("." + window))
wconfigs) +
cat (bind::pack_window window event_callbacks) +
"bind ." + window + " <Destroy> { if {\"%W\" == \"." +
window + "\"} {" + com::comm_to_tcl +
" \"Destroy " + window + " <Destroy> " +
tk_event::show() + " \"}}\n" +
(widget_tree::pack_widgets TRUE ("." + window) (window, "")
NULL (get_raw_widgets widgets))));fi;
init_action();
};
fun close window
=
if (is_init_window window)
com::exit_tcl();
delete_all_gui;
else
com::put_tcl_cmd ("destroy ." + window);
delete_gui window;
fi;
fun change_title window_id title
=
{ window = get_window_gui window_id;
wc = get_window_traits window;
wc' = config::add_window_conf wc [WINDOW_TITLE title];
window' = update_window_traits window wc';
if (check_title title)
upd_window_gui window_id window';
if (is_init_window window_id)
com::put_tcl_cmd (config::pack_window_conf "." (WINDOW_TITLE title));
else com::put_tcl_cmd (config::pack_window_conf ("." + window_id) (WINDOW_TITLE title)); fi;
else
raise exception WINDOWS ("Title " + title + " for window " + window_id + " is not OK");
fi;
};
};