# Compiled by:
# src/lib/tk/src/tests+examples/sources.sublib# ***********************************************************************
#
# Project: tk: an Tk Toolkit for sml
# Author: Burkhart Wolff, University of Bremen
# Date: 25.7.95
# Purpose of this file: Small example
#
# ***********************************************************************
package example1 {
stipulate
include package tk;
herein
main = make_tagged_window_id "main";
warn = make_tagged_window_id "warning";
e1 = make_tagged_widget_id "e1";
enter_name = make_tagged_window_id "entername";
menu = make_tagged_widget_id "menu";
yesquit = make_simple_callback (\\ () => close_window main; end );
nogoon = make_simple_callback (\\ () => close_window warn; end );
# Warning Window
fun nobut msg yes no
=
BUTTON {
widget_id => make_widget_id(),
packing_hints => [PACK_AT RIGHT, FILL ONLY_X, EXPAND TRUE],
traits => [TEXT "NO", CALLBACK no],
event_callbacks => []
};
fun message1 msg yes no
=
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 no
=
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 no
=
FRAME {
widget_id => make_widget_id(),
subwidgets => PACKED [yes_button msg yes no,
nobut msg yes no],
packing_hints => [],
traits => [],
event_callbacks => []
};
fun tree2 msg yes no
=
[message1 msg yes no, yesno msg yes no];
fun warning_window msg yes no
=
make_window { window_id=>warn, traits => [WINDOW_TITLE "Warning",
TRANSIENTS_LEADER (THE main)
/* , OMIT_WINDOW_MANAGER_DECORATIONS TRUE */],
subwidgets => PACKED (tree2 msg yes no),
event_callbacks => [],
init=>null_callback };
fun warning msg yes no
=
open_window (warning_window msg yes no);
/* Enter Window */ my
inputok
=
\\ ()
=>
{ my
nm = make_title (get_tcl_text e1);
change_title main nm ;
close_window enter_name;
}; end ;
my
n_label
=
LABEL {
widget_id => make_widget_id(),
packing_hints => [PACK_AT LEFT],
traits => [TEXT "name:"],
event_callbacks => []
};
my
input
=
TEXT_ENTRY {
widget_id => e1,
packing_hints => [],
traits => [WIDTH 20],
event_callbacks => [ EVENT_CALLBACK (KEY_PRESS "Return", \\ _=> inputok(); end )]
};
my
treesize = [n_label, input];
my
enterwin = make_window {
window_id => enter_name,
traits => [WINDOW_TITLE "Please enter name",
TRANSIENTS_LEADER (THE main)],
subwidgets => PACKED treesize,
event_callbacks => [],
init => null_callback
};
my
playername = make_simple_callback (\\ () => open_window enterwin; end );
# Main Window
my
entername= MENU_COMMAND [TEXT "Enter name", CALLBACK playername];
my
player = MENU_BUTTON { widget_id=>make_widget_id(),
mitems => [entername], packing_hints => [],
traits => [TEXT "Special", MENU_UNDERLINE 0, TEAR_OFF TRUE],
event_callbacks => [] };
my
yesreset = null_callback;
fun newgame ()
=
warning "really reset?" yesreset nogoon;
my
new = MENU_COMMAND [TEXT "New",
MENU_UNDERLINE 0, ACCELERATOR "Ctrl+n",
CALLBACK (make_simple_callback newgame)];
fun quitgame ()
=
warning "really quit?" yesquit nogoon;
my
quit = MENU_COMMAND([TEXT "Quit",
MENU_UNDERLINE 0, ACCELERATOR "Ctrl+q",
CALLBACK (make_simple_callback quitgame)]);
my
game = MENU_BUTTON { widget_id=>make_widget_id(),
mitems => [new, MENU_SEPARATOR, quit],
packing_hints => [PACK_AT LEFT],
traits => [TEXT "Control", MENU_UNDERLINE 0, TEAR_OFF TRUE],
event_callbacks => [] };
my
menu = FRAME {
widget_id => make_widget_id (),
subwidgets => PACKED [game, player],
packing_hints => [], traits => [], event_callbacks => [] };
my
board
=
FRAME {
widget_id => make_widget_id (),
packing_hints => [PACK_AT LEFT, FILL ONLY_X],
subwidgets => PACKED [],
traits => [WIDTH 200, HEIGHT 200],
event_callbacks => [ EVENT_CALLBACK (
KEY_PRESS "q",
\\ _ => quitgame(); end
),
EVENT_CALLBACK (
CONTROL (KEY_PRESS "n"),
\\ _ => newgame(); end
)
]
};
my
initwin = [ make_window {
window_id => main,
traits => [ WINDOW_TITLE "Mini Example" ],
subwidgets => PACKED [menu, board],
event_callbacks => [],
init=>null_callback
}
];
my
do_it = \\ () => start_tcl_and_trap_tcl_exceptions initwin; end ; my
go = do_it;
end; # local use
};