## boxes.pkg
## (C) 1996, Bremen Institute for Safe Systems, Universitaet Bremen
## Author: cxl
# Compiled by:
# src/lib/tk/src/toolkit/tests+examples/sources.sublib# ***************************************************************************
# Test and example program for the drag&drop package.
#
# It presents the amazed user with a window in which he can move
# around wee blue, red and green boxes. Moving a box on the red box
# makes it go away, moving it onto the green box makes it replicate
# itself. You can't move the green or red box onto anything. In fact,
# you can't move the red box at all.
#
# Use WeeBoxes::go() to start. You have to call SysInit::initSmlTk() first,
# and the drag_and_drop_g class macro has to be in the environment.
# ***************************************************************************
package wee_boxes
: (weak) api { go: Void -> String; }
{
include package basic_utilities;
include package tk;
Box = RED_BOX Canvas_Item_Id
| GREEN_BOX Canvas_Item_Id
| BLUE_BOX Canvas_Item_Id;
fun is_blue (blue_box _) => TRUE;
is_blue _ => FALSE; end;
my
backdrop = make_widget_id();
# Bit of a hack, this: this variable will point towards the function
# exported from drag_and_drop_g by which we can place items on the
# drag&drop area.
my
add_new_box_fun = REF (\\ e: Box=> (); end );
my
box_size = 50; my
backdrop_height = 300; my
backdrop_width = 400;
fun debug str
=
debug::print 19 ("Boxes: " $ str);
# This function adds a new box to the area. You can only use it
# after initializing addNewBoxFun above.
#
fun add_new_box (boxitem, boxcit)
=
{ add_canvas_item backdrop boxcit;
*add_new_box_fun boxitem;
};
# Auxiliary functions to create new Boxes in a format to
# use with addNewBox above.
#
fun new_box colour w_here
=
CANVAS_BOX { citem_id=>make_canvas_item_id(), coord1=>w_here,
coord2 => add_coordinates w_here (coordinate (box_size, box_size)),
traits => [FILL_COLOR colour, OUTLINE BLACK, OUTLINE_WIDTH 3],
event_callbacks => []
};
fun new_green_box w_here
=
{ nu_box = new_box GREEN w_here;
(green_box (get_canvas_item_id (nu_box)), nu_box);
};
fun new_red_box w_here
=
{ nu_box = new_box RED w_here;
(red_box (get_canvas_item_id (nu_box)), nu_box);
};
fun new_blue_box w_here
=
{ nu_box = new_box BLUE w_here;
(blue_box (get_canvas_item_id (nu_box)), nu_box);
};
# List of the initial boxes:
all_my_boxes
=
[new_blue_box (coordinate (10, 10)), new_blue_box (coordinate (10, 80)), new_blue_box (coordinate (10, 150)),
new_green_box (coordinate (10, backdrop_height - 10-box_size)),
new_red_box (coordinate (backdrop_width - 10-box_size, backdrop_height - 10-box_size))];
fun sel_box_id (red_box cit) => cit;
sel_box_id (green_box cit) => cit;
sel_box_id (blue_box cit) => cit; end;
fun enlarge_box cit
=
{ coords = get_tcl_canvas_item_coordinates backdrop cit;
nuc = (subtract_coordinates (hd coords) (coordinate (5, 5))) .
(add_coordinates (hd (tl coords)) (coordinate (5, 5))) . NIL;
set_canvas_item_coordinates backdrop cit nuc;
};
fun shrink_box cit
=
{ coords = get_tcl_canvas_item_coordinates backdrop cit;
nuc = (add_coordinates (hd coords) (coordinate (5, 5))) .
(subtract_coordinates (hd (tl coords)) (coordinate (5, 5))) . NIL;
set_canvas_item_coordinates backdrop cit nuc;
};
fun colour_box cit colour
=
add_canvas_item_traits backdrop cit [FILL_COLOR colour];
fun hilight_box (red_box cit) => enlarge_box cit;
hilight_box (green_box cit) => shrink_box cit;
hilight_box (blue_box cit) => colour_box cit YELLOW;
end;
fun enter_box box boxes
=
{ cin_drop = list::all is_blue boxes;
if cin_drop hilight_box box;
fi;
{ debug (canvas_item_id_to_string (sel_box_id box)$" entered by "$
(string::join " " (map (canvas_item_id_to_string o sel_box_id) boxes))$
": " $ (bool::to_string cin_drop));
cin_drop;};
};
fun leave_box (red_box cit) => shrink_box cit;
leave_box (green_box cit) => enlarge_box cit;
leave_box (blue_box cit) => colour_box cit BLUE;
end;
fun lowlight_box (blue_box cit) => colour_box cit BLUE;
lowlight_box _ => ();
end;
fun drop_box (red_box _) _
=>
FALSE;
drop_box (blue_box _) _
=>
{ posix::sleep (time::from_seconds 20);
TRUE;
};
drop_box (green_box cit) _
=>
{ w_here = get_tcl_canvas_item_coordinates backdrop cit;
add_new_box (new_blue_box (add_coordinates (coordinate (60, 0)) (hd w_here)));
TRUE;
};
end;
my
move_opaque = REF FALSE;
# Changed by toggleMove, see moveButton() below
fun move_box box delta
=
if *move_opaque
move_canvas_item backdrop (sel_box_id box) delta;
fi;
# Boxes as Drag&Drop-Items:
#
package box_items: (weak) Drag_And_Drop_Items { # Drag_And_Drop_Items is from src/lib/tk/src/toolkit/drag-and-drop.api Item = Box;
Item_List = List( Box );
fun item_list_rep x = x;
fun item_list_abs x = x;
my
get_canvas_item_id = sel_box_id;
fun is_immobile (red_box _) => TRUE;
is_immobile _ => FALSE; end;
fun sel_drop_zone _
=
make_box (coordinate (2, 2), coordinate (box_size- 2, box_size -2));
fun grab _ = (); my
release = lowlight_box; my
move = move_box;
my
select = hilight_box; my
deselect = lowlight_box;
my
enter = enter_box; my
leave = leave_box;
fun drop b bb
=
{ debug ("drop " $ (string::join " "
(map (canvas_item_id_to_string o sel_box_id) bb)) $ " on " $
(canvas_item_id_to_string (sel_box_id b))); drop_box b bb;};
# Although we do not use the clipboard, it has to be here.
#
package clipboard
=
clipboard_g ( Part = List( Box ); );
};
package drag_drop_boxes
=
drag_and_drop_g( box_items );
fun init_boxes ()
=
{ my
ddboxes = drag_drop_boxes::init backdrop;
fun place_new_blue_box (TK_EVENT(_, _, x, y, _, _))
=
add_new_box (new_blue_box (coordinate (x, y)));
{ add_new_box_fun := drag_drop_boxes::place ddboxes;
apply add_new_box all_my_boxes;
add_event_callbacks backdrop [EVENT_CALLBACK (DOUBLE (BUTTON_PRESS (THE 1)), make_callback (place_new_blue_box))];
};
};
# Get a window
fun backdrop_namings ()
=
[ EVENT_CALLBACK (
LEAVE,
make_callback (
\\ TK_EVENT(_, _, x, y, _, _)
=>
debug::print 19 ("Leave event occurred at " $
(int::to_string x) $ ", " $ (int::to_string y)); end
)
)
];
fun backdrop_canvas ()
=
CANVAS {
widget_id => backdrop,
scrollbars => NOWHERE,
citems => [],
packing_hints => [PACK_AT TOP, FILL ONLY_X, EXPAND TRUE],
event_callbacks => backdrop_namings(),
traits => [ HEIGHT backdrop_height,
WIDTH backdrop_width,
RELIEF GROOVE,
BACKGROUND GREY
]
};
fun quit_button window
=
BUTTON {
widget_id => make_widget_id (),
packing_hints => [PACK_AT BOTTOM, FILL ONLY_X, EXPAND TRUE],
event_callbacks => [],
traits => [ TEXT "Quit",
CALLBACK (make_simple_callback (\\ _ = tk::close_window window)),
RELIEF RIDGE,
BORDER_THICKNESS 2
]
};
fun toggle_move mb ()
=
if *move_opaque
move_opaque := FALSE;
add_trait mb [TEXT "Move Opaque", CALLBACK (make_simple_callback (toggle_move mb))];
else
move_opaque := TRUE;
add_trait mb [TEXT "Move Invisible", CALLBACK (make_simple_callback (toggle_move mb))];
fi;
fun move_button ()
=
{ my
mb = make_widget_id ();
BUTTON {
widget_id => mb,
packing_hints => [PACK_AT BOTTOM, FILL ONLY_X, EXPAND TRUE],
event_callbacks => [],
traits => [ TEXT "Move Opaque",
CALLBACK (make_simple_callback (toggle_move mb)),
RELIEF RIDGE,
BORDER_THICKNESS 2
]
};
};
fun go ()
=
{ my
mw = make_window_id (); my
boxwin = make_window {
window_id => mw,
traits => [WINDOW_TITLE "LittleBoxes"],
subwidgets => PACKED [backdrop_canvas(),
quit_button mw, move_button()],
event_callbacks => [],
init => init_boxes
};
start_tcl_and_trap_tcl_exceptions [boxwin]
except
drag_drop_boxes::DRAG_AND_DROP why
=>
why; end ;
};
};