/*
*
* Project: sml/Tk: an Tk Toolkit for sml
* Author: Burkhart Wolff, University of Bremen
* $Date: 2001/03/30 13:39:33 $
* $Revision: 3.0 $
* Purpose of this file: PopUp example
*
*/
# Compiled by:
# src/lib/tk/src/tests+examples/sources.sublibpackage pop_up_ex : api {
go: Void -> String;
}
{
include package tk;
my
warn = make_tagged_window_id "warning";
# Warning Window
fun warning_window msg yes no
=
make_window {
window_id => warn,
traits => [WINDOW_TITLE "Warning"],
subwidgets => PACKED [
LABEL {
widget_id => make_widget_id(),
packing_hints => [FILL ONLY_X, EXPAND TRUE],
traits => [TEXT msg, RELIEF FLAT, WIDTH 25],
event_callbacks => []
},
FRAME {
widget_id => make_widget_id(),
subwidgets => PACKED [
BUTTON {
widget_id => make_widget_id (),
packing_hints => [PACK_AT LEFT, FILL ONLY_X, EXPAND TRUE],
traits => [TEXT "YES", CALLBACK yes],
event_callbacks => []
},
BUTTON {
widget_id => make_widget_id (),
packing_hints => [PACK_AT RIGHT, FILL ONLY_X, EXPAND TRUE],
traits => [TEXT "NO", CALLBACK no],
event_callbacks => []
}
],
packing_hints => [],
traits => [],
event_callbacks => []
}
],
event_callbacks => [],
init => null_callback
};
fun warning msg yes no
=
open_window (warning_window msg yes no);
# Enter Window
main_window_id = make_tagged_window_id "meisterfenster";
entern = make_tagged_window_id "entername";
p1 = make_tagged_widget_id "p1";
p2 = make_tagged_widget_id "p2";
c1 = make_tagged_widget_id "c1";
it1 = make_tagged_canvas_item_id "it1";
it2 = make_tagged_canvas_item_id "it2";
e1 = make_tagged_widget_id "e1";
itemmenu = make_tagged_widget_id "itemmenu";
enterwin =
{
inputok = \\ () => { change_title main_window_id (make_title (get_tcl_text e1));
close_window entern ;}; end ;
make_window {
window_id => entern,
traits => [WINDOW_TITLE "Please enter name"],
subwidgets => PACKED [
LABEL {
widget_id => make_widget_id (),
packing_hints => [PACK_AT LEFT],
traits => [TEXT "name:"],
event_callbacks => []
},
TEXT_ENTRY {
widget_id => e1,
packing_hints => [],
traits => [WIDTH 20],
event_callbacks => [ EVENT_CALLBACK ( KEY_PRESS "Return",
\\ (_: Tk_Event) => inputok(); end )
]
}
],
event_callbacks => [],
init => null_callback
};
};
my
playername
=
\\ () => open_window enterwin; end ;
# Main Window
my
entername
=
MENU_COMMAND [TEXT "Enter name", CALLBACK playername];
my
menu
=
{
nogoon = make_simple_callback (\\ () = close_window warn);
yesquit = make_simple_callback (\\ () = close_window main_window_id);
yesreset = make_simple_callback (\\ () = ());
newgame = make_simple_callback (\\() = warning "really reset?" yesreset nogoon);
quitgame = make_simple_callback (\\ () = warning "really quit?" yesquit nogoon);
FRAME {
widget_id => make_widget_id (),
packing_hints => [FILL ONLY_X],
traits => [RELIEF RAISED, BORDER_THICKNESS 2],
event_callbacks => [],
subwidgets => PACKED [
MENU_BUTTON {
widget_id => make_widget_id (),
mitems => [ MENU_COMMAND([TEXT "New", CALLBACK newgame]),
MENU_SEPARATOR,
MENU_COMMAND( [TEXT "Quit", CALLBACK quitgame])
],
packing_hints => [PACK_AT LEFT],
traits => [TEXT "File", TEAR_OFF TRUE],
event_callbacks => []
},
MENU_BUTTON {
widget_id => make_widget_id (),
mitems => [ MENU_COMMAND([TEXT "Enter name", CALLBACK playername])
],
packing_hints => [PACK_AT LEFT],
traits => [TEXT "Special", TEAR_OFF TRUE],
event_callbacks => []
},
MENU_BUTTON {
widget_id => itemmenu,
mitems => [ MENU_COMMAND([TEXT "Add", CALLBACK playername]),
MENU_COMMAND([TEXT "Delete", CALLBACK (make_simple_callback((\\ () => (); end )))])
],
packing_hints => [PACK_AT LEFT],
traits => [TEXT "Item", TEAR_OFF TRUE],
event_callbacks => []
}
]
};
};
fun popup1 wid =
POPUP { widget_id => wid,
mitems => [MENU_COMMAND([TEXT "Add",
CALLBACK (make_simple_callback (\\ () => (); end )) ]),
MENU_COMMAND([TEXT "Delete",
CALLBACK (make_simple_callback (\\ () => (); end ))]),
MENU_SEPARATOR,
MENU_COMMAND([TEXT "Properties", CALLBACK playername])],
traits => [] };
my
board
=
{ my
pos = REF (0: Int, 0: Int);
fun grab_it (wid: Widget_Id) (cid: Canvas_Item_Id) (TK_EVENT(_, _, x, y, _, _))
=
pos := (x, y);
fun move_it (wid: Widget_Id) (cid: Canvas_Item_Id) (TK_EVENT(_, _, x, y, _, _))
=
{
cit_col = get_tcl_canvas_item_coordinates wid cid;
my (x_p, y_p) = *pos;
(pos:=(x, y));
delta = coordinate (x-x_p, y-y_p);
move_canvas_item wid cid delta;
};
fun popitup_m (TK_EVENT(_, _, _, _, xr, yr))
=
pop_up_menu itemmenu NULL (coordinate (xr, yr));
fun popitup_p (TK_EVENT(_, _, _, _, xr, yr))
=
pop_up_menu p1 (THE 4) (coordinate (xr, yr));
fun popitup_d (TK_EVENT(_, _, _, _, xr, yr))
=
# widget_ops::make_and_pop_up_window (Popup1 p2) (THE 4) (xr, yr)
make_and_pop_up_window (popup1 p2) (THE 4) (coordinate (xr, yr));
fun popitdown_d _
=
delete_widget p2;
fun itbds (wid: Widget_Id) (cid: Canvas_Item_Id)
=
[ EVENT_CALLBACK (BUTTON_PRESS (THE 2), make_callback (popitup_m)),
EVENT_CALLBACK (SHIFT (BUTTON_PRESS (THE 3)), make_callback (popitup_d)),
EVENT_CALLBACK (SHIFT (BUTTON_RELEASE (THE 3)), make_callback (popitdown_d)),
EVENT_CALLBACK (BUTTON_PRESS (THE 3), make_callback (popitup_p)),
EVENT_CALLBACK (BUTTON_PRESS (THE 1), make_callback (grab_it wid cid)),
EVENT_CALLBACK (MODIFIER_BUTTON (1, MOTION), make_callback (move_it wid cid))
];
FRAME {
widget_id => make_widget_id (),
packing_hints => [PACK_AT LEFT, FILL ONLY_X],
traits => [WIDTH 200, HEIGHT 200, RELIEF RAISED, BORDER_THICKNESS 2],
event_callbacks => [],
subwidgets => PACKED [
CANVAS {
widget_id => c1,
scrollbars => AT_LEFT_AND_BOTTOM,
citems => [ CANVAS_OVAL {
citem_id=>it1, coord1=>coordinate (50, 50),
coord2=>coordinate (100, 100),
traits => [FILL_COLOR RED],
event_callbacks=>itbds c1 it1
},
CANVAS_OVAL {
citem_id=>it2,
coord1 => coordinate (100, 100),
coord2 => coordinate (150, 150),
traits => [FILL_COLOR RED],
event_callbacks=>itbds c1 it2
}
],
packing_hints => [],
traits => [SCROLL_REGION (0, 0, 400, 400)],
event_callbacks => []
}
]
};
};
my
area = [menu, board, (popup1 p1)];
my
initwin = [ make_window {
window_id => main_window_id,
traits => [WINDOW_TITLE "POPUP Example"],
subwidgets => PACKED area,
event_callbacks => [],
init => null_callback
}
];
my
go = \\ () => start_tcl_and_trap_tcl_exceptions initwin; end ;
};