# Compiled by:
# src/lib/tk/src/tests+examples/sources.sublib# ***********************************************************************
#
# Project: sml/Tk: an Tk Toolkit for sml
# Author: Burkhart Wolff, University of Bremen
# Date: 25.7.95
# Purpose of this file: Small example
#
# ***********************************************************************
### "Don't be too confused.
### It is not your fault.
### The San Andreas is your fault."
###
### -- Sandy Stone
package ex2 {
stipulate
include package tk;
include package basic_utilities;
herein
exception NO_FILE String;
my
warn = make_tagged_window_id "warning"; my
main = make_tagged_window_id "main"; my
enter = make_tagged_window_id "entername"; my
e1 = make_tagged_widget_id "e1"; my
liste = make_tagged_widget_id "liste"; my
state_wid = make_tagged_widget_id "statewid";
fun prs s
=
file::write (file::stdout, s);
fun writeln s
=
prs (s + "\n");
# Cursor Get Callback on Listboxes and TextWidgets
fun getcur wid
=
\\ (_)=> { my MARK (n, m) = get_tcl_cursor wid;
file::write (file::stdout, "POSITION :" + int::to_string n +
"." + int::to_string m + "\n");
}; end ;
# Warning Window
my
nogoon = make_simple_callback (\\ () => close_window warn; end );
fun nobut msg yes
=
BUTTON {
widget_id => make_widget_id(),
packing_hints => [PACK_AT RIGHT, FILL ONLY_X, EXPAND TRUE],
traits => [TEXT "NO", CALLBACK nogoon], event_callbacks => []
};
fun message1 msg yes
=
LABEL {
widget_id => make_widget_id(),
packing_hints => [FILL ONLY_X, EXPAND TRUE],
traits => [TEXT msg, RELIEF FLAT, WIDTH 25],
event_callbacks => []
};
fun yes_button msg yes
=
BUTTON {
widget_id => make_widget_id(),
packing_hints => [PACK_AT LEFT, FILL ONLY_X, EXPAND TRUE],
traits => [TEXT "YES", CALLBACK yes],
event_callbacks => []
};
fun yesno msg yes
=
FRAME {
widget_id => make_widget_id(),
subwidgets => PACKED [yes_button msg yes, nobut msg yes],
packing_hints => [],
traits => [],
event_callbacks => []
};
fun tree2 msg yes
=
[message1 msg yes, yesno msg yes];
fun warning_window msg yes
=
make_window {
window_id => warn,
traits => [WINDOW_TITLE "Warning",
TRANSIENTS_LEADER (THE main)],
subwidgets => PACKED (tree2 msg yes),
event_callbacks => [],
init => null_callback
};
fun warning msg yes
=
open_window (warning_window msg yes);
# Enter Window
my
n_label
=
LABEL {
widget_id => make_widget_id (),
packing_hints => [PACK_AT LEFT],
traits => [TEXT "name:"],
event_callbacks => []
};
fun input enteraction
=
{ my
mrs
=
\\ (_)
=>
{ my
nm = get_tcl_text e1;
enteraction nm ();
close_window enter;
}; end ;
TEXT_ENTRY {
widget_id => e1,
packing_hints => [],
traits => [WIDTH 20],
event_callbacks => [EVENT_CALLBACK (KEY_PRESS "Return", mrs)]
};
};
fun treesize enteraction
=
[n_label, input enteraction];
fun enterwin enteraction
=
make_window {
window_id => enter,
traits => [ WINDOW_TITLE "Please enter name",
TRANSIENTS_LEADER (THE main)
],
subwidgets => PACKED (treesize enteraction),
event_callbacks => [],
init => null_callback
};
# Main Window
my
yesquit = make_simple_callback (\\ () => close_window main; end );
my
entername
=
{ fun inputok nm
=
\\ () => insert_text_end liste nm; end ; my
cmd = make_simple_callback (\\ () => open_window (enterwin inputok); end );
MENU_COMMAND [TEXT "Enter name", CALLBACK (cmd)];
};
my
m1 = make_widget_id(); my
insertmenue
=
MENU_BUTTON {
widget_id => m1,
mitems => [entername],
packing_hints => [PACK_AT LEFT],
traits => [TEXT "Special", TEAR_OFF TRUE],
event_callbacks => []
};
my
list = LIST_BOX {
widget_id => liste,
scrollbars => AT_RIGHT,
packing_hints => [PACK_AT LEFT, PACK_AT TOP, FILL ONLY_Y],
traits => [RELIEF RAISED],
event_callbacks => [EVENT_CALLBACK (DOUBLE (BUTTON_PRESS (THE 1)),
getcur liste)]
};
my
MARKLIST
=
REF([] : List ((Mark, Mark)) );
my
statewid
=
TEXT_WIDGET {
widget_id => state_wid,
scrollbars => AT_RIGHT,
live_text => empty_livetext,
packing_hints => [PACK_AT LEFT, FILL XY],
traits => [RELIEF RAISED, BORDER_WIDTH 2],
event_callbacks => [EVENT_CALLBACK (DOUBLE (BUTTON_PRESS (THE 1)), getcur state_wid),
EVENT_CALLBACK (DOUBLE (BUTTON_PRESS (THE 3)),
\\ _ => { t = get_tcl_selection_window();
m = get_tcl_selection_range state_wid;
case t
NULL =>
writeln("SEL");
THE (window, wid) =>
writeln (make_window_string (window) +
make_widget_string (wid)); esac;
MARKLIST := m;
}; end ),
EVENT_CALLBACK (DOUBLE (BUTTON_PRESS (THE 2)),
\\ (_) => file::write (file::stdout,
get_tcl_text state_wid); end )]
};
my
yesreset = null_callback;
my
loadfile
=
{ fun more str
=
{ my
in_str = ( file::open_for_read str
except
(winix__premicrothread::RUNTIME_EXCEPTION (err, _))
=
raise exception (NO_FILE ("Can't open file " + str + ": " + err))
)
except
io::io { name, ... } = raise exception (NO_FILE name);
while (not (file::end_of_stream in_str)) {
insert_text_end state_wid (file::read_n (in_str, 100));
};
};
fun do_it nm
=
\\ () => { clear_text state_wid;more nm;}; end ;
make_simple_callback (\\ () => (open_window (enterwin do_it)); end );
};
load = MENU_COMMAND [TEXT "Load", CALLBACK loadfile];
quitgame = make_simple_callback (\\ () => warning "really quit?" yesquit; end );
quit = MENU_COMMAND([TEXT "Quit", CALLBACK quitgame]);
m2 = make_widget_id();
ctrmenue = MENU_BUTTON {
widget_id => m2,
mitems => [load, MENU_SEPARATOR, quit],
packing_hints => [PACK_AT LEFT],
traits => [TEXT "Control", TEAR_OFF TRUE],
event_callbacks => []
};
space = FRAME {
widget_id => make_widget_id(),
subwidgets => PACKED [],
packing_hints => [PACK_AT LEFT, FILL XY],
traits => [],
event_callbacks => []
};
my
menu = FRAME {
widget_id => make_widget_id(),
subwidgets => PACKED [ctrmenue, insertmenue, space],
packing_hints => [],
traits => [],
event_callbacks => []
};
my
board = FRAME {
widget_id => make_widget_id(),
subwidgets => PACKED [statewid, list],
packing_hints => [PACK_AT BOTTOM, FILL XY],
traits => [],
event_callbacks => []
};
my
tree1 = [menu, board];
my
initwin = [ make_window {
window_id => main,
traits => [WINDOW_TITLE "Transformation System"],
subwidgets => PACKED tree1,
event_callbacks => [],
init => null_callback
}
];
# Launching and Shutting System
# open_window (hd initwin);
#
# start_tcl initwin;
# start_tcl_exn initwin;
#
# Cursor-Position fuer TextWidgets:
# .text index insert
#
# Cursor-Position fuer Listboxes:
# bind .dateien <Double-Button-1> {
# puts [.dateien curselection]
# }
my
do_it = \\ () = start_tcl_and_trap_tcl_exceptions initwin; my
go = do_it;
end;
};