## lazy-tree-g.pkg
## (C) 1999, Bremen Institute for Safe Systems, Universitaet Bremen
## Author: ludi
# Compiled by:
# src/lib/tk/src/toolkit/sources.sublib# ***************************************************************************
# Lazy Tree Lists
# **************************************************************************
### "I was born not knowing and have had only a
### little time to change that here and there."
###
### -- Richard P. Feynman
generic package lazy_tree_g (package obj: Lazy_Tree_Objects;) # Lazy_Tree_Objects is from src/lib/tk/src/toolkit/lazy_tree_objects.api: (weak)
api {
Part = obj::Part;
exception ERROR String;
History_State =
HIST_START | HIST_MIDDLE | HIST_END | HIST_EMPTY;
tree_list :
{ width: Int,
height: Int,
font: tk::Font,
selection_notifier: Null_Or( Part ) -> Void
}
->
{ canvas: Part -> tk::Widget,
selection: Void -> Null_Or( Part ),
up: Void -> Void,
position: Void -> History_State,
back: Void -> Void,
forward: Void -> Void
};
}
{
include package tk;
Part = obj::Part;
Entry_Id = String;
Path = List( Entry_Id );
State_Entry =
STATE_ENTRY
((Path, # 1. path of entry ids
Coordinate, # 2. root coord of entry
Null_Or( Bool ), # 3. TRUE/FALSE if node is open/
# Closed, NULL if leaf
List Canvas_Item, # 4. CItems
Ref Canvas_Item, # 5. line to upper entry
Ref (List Canvas_Item), # 6. plus of minus citems if node
Part, # 7. referenced object
Widget_Id, # 8. Widget_ID of label
Canvas_Item_Id, # 9. Canvas_Item_ID of Icon
Ref Null_Or ( (List State_Entry, # 10. subentries / old root y-coord
Int)))); # if node has been open before
fun sel_entry_content (STATE_ENTRY e) = e;
exception ERROR String;
History_State
=
HIST_START | HIST_MIDDLE | HIST_END | HIST_EMPTY;
my
dummy_event
=
TK_EVENT (0, "", 0, 0, 0, 0);
fun tree_list { width, height, font, selection_notifier } =
{
widget_id = make_widget_id();
entcnt = REF 0;
fun new_entry_id ()
=
{ entcnt := *entcnt + 1;
"entry" + int::to_string *entcnt;
};
state = REF [] : Ref( List( State_Entry ) );
selected = REF NULL
: Ref( Null_Or ((Path, Widget_Id, Part, Canvas_Item_Id)) );
history = REF [] : Ref( List( Path ) );
history_pointer = REF 0;
fun hist_append p
=
{ if (length *history == *history_pointer)
history := *history @ [p];
else
history := list::take_n (*history, *history_pointer) @ [p];
fi;
history_pointer := length *history;
};
fun sub_path p1 p2
=
list::take_n (p1, length p2) == p2
except
_ => FALSE; end ;
fun path_to p = list::take_n (p, length p - 1);
fun enter id _
=
if ( not_null *selected
and #2 (the *selected) == id
)
add_trait id [BACKGROUND GREY, FOREGROUND WHITE];
fi;
fun leave id _
=
if ( not_null *selected
and #2 (the *selected) == id
)
add_trait id [BACKGROUND WHITE, FOREGROUND BLACK];
fi;
fun plus (x, y) bi
=
[ CANVAS_LINE
{ citem_id => make_canvas_item_id(),
coords => [(x + 2, y), (x + 7, y)],
traits => [],
event_callbacks => bi
},
CANVAS_LINE
{ citem_id => make_canvas_item_id(),
coords => [(x + 4, y + 3),
(x + 4, y - 2)],
traits => [],
event_callbacks => bi
}
];
fun minus (x, y) bi
=
[ CANVAS_LINE
{ citem_id => make_canvas_item_id(),
coords => [(x + 2, y), (x + 7, y)],
traits => [],
event_callbacks => bi
}
];
fun sel_next ((e: State_Entry) . es) p
=>
if ( path_to(#1 (sel_entry_content e)) == p
or sub_path (path_to (#1 (sel_entry_content e))) p
)
sel_next es p;
else
(e . es);
fi;
sel_next _ _ => [];
end;
fun stretch ((e1: State_Entry) . e1s)
((e2: State_Entry) . e2s)
=>
if ( path_to(#1 (sel_entry_content e1))
== path_to(#1 (sel_entry_content e2))
)
#5 (sel_entry_content e2)
:=
{ oldcoords
=
get_canvas_item_coordinates(*(#5 (sel_entry_content e2)));
newsndc
=
( #1 (#2 (sel_entry_content e1)) + 4,
#2 (#2 (sel_entry_content e1)) + 4
);
newcoords
=
hd oldcoords . [newsndc];
update_canvas_item_coordinates (*(#5 (sel_entry_content e2)))
newcoords;
};
stretch
(sel_next e1s (path_to(#1 (sel_entry_content e1))))
e2s;
else
if (sub_path (#1 (sel_entry_content e2))
(#1 (sel_entry_content e1))
)
stretch (e1 . e1s) e2s;
else
stretch
(sel_next e1s
(path_to(#1 (sel_entry_content e1))))
(e2 . e2s);
fi;
fi;
stretch _ _ => ();
end;
fun get_coord path ((e: State_Entry) . es)
=
if ( #1 (sel_entry_content e) == path)
#2 (sel_entry_content e);
else get_coord path es;
fi;
fun selected path id ob cid b _
=
if ( not (#1 (the *selected) == path)
except
_ = TRUE
)
my (x, y)
=
get_coord path *state;
if (not_null *selected)
sel = the *selected;
my (sx, sy) = get_coord(#1 sel) *state;
sel_f = selected (#1 sel) (#2 sel)
(#3 sel) (#4 sel)
TRUE;
add_trait (#2 (the *selected))
[RELIEF FLAT, FOREGROUND BLACK,
BACKGROUND WHITE];
delete_canvas_item widget_id (#4 sel);
add_canvas_item widget_id
(CANVAS_ICON { citem_id => #4 sel,
coord =>
(sx + 12, sy),
icon_variety =>
obj::icon(#3 sel),
traits =>
[ANCHOR WEST],
event_callbacks =>
[EVENT_CALLBACK
(ENTER,
enter(#2 sel)),
EVENT_CALLBACK
(LEAVE,
leave(#2 sel)),
EVENT_CALLBACK
(BUTTON_PRESS
(THE 1),
sel_f)] } );
fi;
selected := THE (path, id, ob, cid);
add_trait id [RELIEF SUNKEN, FOREGROUND WHITE,
BACKGROUND GREY];
delete_canvas_item widget_id cid;
add_canvas_item widget_id (CANVAS_ICON { citem_id => cid,
coord => (x + 12, y),
icon_variety =>
obj::selected_icon ob,
traits => [ANCHOR WEST],
event_callbacks =>
[EVENT_CALLBACK (ENTER, enter id),
EVENT_CALLBACK (LEAVE, leave id),
EVENT_CALLBACK
(BUTTON_PRESS (THE 1),
selected path id ob
cid
TRUE)] } );
if b hist_append path; fi;
selection_notifier (THE ob);
fi;
fun reselect ()
=
if (not_null *selected)
{
cid = #4 (the *selected);
item = get_canvas_item widget_id cid;
coord = hd (get_canvas_item_coordinates item);
bind = get_canvas_item_event_callbacks item;
ob = #3 (the *selected);
delete_canvas_item widget_id cid;
add_canvas_item widget_id (CANVAS_ICON { citem_id => cid,
coord,
icon_variety =>
obj::selected_icon ob,
traits => [ANCHOR WEST],
event_callbacks => bind } );
add_trait (#2 (the *selected))
[BACKGROUND GREY, FOREGROUND WHITE,
RELIEF SUNKEN];
}
except _ = { selected := NULL;
selection_notifier NULL;
};
fi;
fun single_entry p ob (x, y) root upper
=
{ path = p @ [new_entry_id()];
id = make_widget_id();
cid = make_canvas_item_id();
dy =
case upper
NULL => 11;
THE TRUE => 16;
THE FALSE => 20;
esac;
binds1 = [EVENT_CALLBACK (ENTER, enter id),
EVENT_CALLBACK (LEAVE, leave id),
EVENT_CALLBACK (BUTTON_PRESS (THE 1),
selected path id ob cid TRUE)];
if (obj::is_leaf ob)
STATE_ENTRY
(path, (x, y), NULL,
[CANVAS_LINE { citem_id => make_canvas_item_id(),
coords => [(x + 4, y), (x + 12, y)],
traits => [WIDTH 2],
event_callbacks => [] },
CANVAS_ICON { citem_id => cid,
coord => (x + 12, y),
icon_variety => obj::icon ob,
traits => [ANCHOR WEST],
event_callbacks => binds1 },
CANVAS_WIDGET { citem_id => make_canvas_item_id(),
coord => (x + 32, y + 2),
subwidgets => PACKED [LABEL { widget_id => id,
packing_hints => [],
traits =>
[TEXT (obj::sel_name ob),
BACKGROUND WHITE,
FONT font],
event_callbacks => binds1 } ],
traits => [ANCHOR WEST],
event_callbacks => [] } ],
REF (CANVAS_LINE { citem_id => make_canvas_item_id(),
coords => [(x + 4, y),
(x + 4, y - dy)],
traits => [WIDTH 2],
event_callbacks => [] } ),
REF [], ob, id, cid, REF NULL);
else
STATE_ENTRY
(path, (x, y),
if root THE TRUE; else THE FALSE;fi,
[CANVAS_LINE { citem_id => make_canvas_item_id(),
coords => [(x + 8, y), (x + 12, y)],
traits => [WIDTH 2],
event_callbacks => [] },
CANVAS_BOX { citem_id => make_canvas_item_id(),
coord1 => (x, y - 4),
coord2 => (x + 8, y + 4),
traits => [],
event_callbacks =>
[EVENT_CALLBACK (BUTTON_PRESS (THE 1),
pressed_obj ob path)] },
CANVAS_ICON { citem_id => cid,
coord => (x + 12, y),
icon_variety => obj::icon ob,
traits => [ANCHOR WEST],
event_callbacks => binds1 },
CANVAS_WIDGET { citem_id => make_canvas_item_id(),
coord => (x + 32, y + 2),
subwidgets => PACKED [LABEL { widget_id => id,
packing_hints => [],
traits =>
[TEXT (obj::sel_name ob),
BACKGROUND WHITE,
FONT font],
event_callbacks => binds1 } ],
traits => [ANCHOR WEST],
event_callbacks => [] } ],
REF (CANVAS_LINE { citem_id => make_canvas_item_id(),
coords => [(x + 4, y - 4),
(x + 4, y - dy)],
traits => [WIDTH 2],
event_callbacks => [] } ),
REF (if root
minus (x, y)
[EVENT_CALLBACK (BUTTON_PRESS (THE 1),
pressed_obj ob path)];
else
plus (x, y)
[EVENT_CALLBACK (BUTTON_PRESS (THE 1),
pressed_obj ob path)];fi),
ob, id, cid, REF NULL);
fi;
}
also
fun pressed_obj ob path _
=
{
fun shift (STATE_ENTRY (path, coord, bopt, cits, cit,
cits2, obj, id, cid, subents)
. es) delta =>
{
fun shift_coord (x, y)
=
(x, y + delta);
fun shift_citem cit
=
update_canvas_item_coordinates cit
(map shift_coord (get_canvas_item_coordinates cit));
STATE_ENTRY (path, shift_coord coord, bopt,
map shift_citem cits,
REF (shift_citem *cit),
REF (map shift_citem *cits2),
obj, id, cid, subents)
. shift es delta;
};
shift [] _ => [];
end;
my (state1, rest, oldst) =
{
fun invert (STATE_ENTRY (path, coord, b, cits,
cit, cits2, obj, id,
cid, subents))
=
{
oldst = the b;
bi = get_canvas_item_event_callbacks (hd *cits2);
newcits2
=
if oldst REF (plus coord bi);
else REF (minus coord bi);
fi;
apply (delete_canvas_item widget_id)
(map get_canvas_item_id *cits2);
apply (add_canvas_item widget_id) *newcits2;
( oldst,
STATE_ENTRY (path, coord,
THE (not oldst), cits,
cit, newcits2, obj, id,
cid, subents)
);
};
fun sep ((e: State_Entry) . es) s1
=
if (#1 (sel_entry_content e) == path)
my (oldst, inverted) = invert e;
(s1 @ [inverted], es, oldst);
else
sep es (s1 @ [e]);
fi;
sep *state [];
};
if oldst # Close
fun sep ((e: State_Entry) . es) subs
=>
if (sub_path (#1 (sel_entry_content e))
path)
sep es (subs @ [e]);
else (subs, e . es);
fi;
sep [] subs
=>
(subs, []);
end;
my (todelete, oldstate2)
=
sep rest [];
delta
=
#2 (#2 (sel_entry_content (hd todelete))) -
#2 (#2 (sel_entry_content
(list::last todelete))) - 20;
state2 = shift oldstate2 delta;
maxy =
int::max (if (null state2 )
#2(#2 (sel_entry_content
(list::last state1)))
+ 12;
else #2(#2 (sel_entry_content
(list::last state2)))
+ 12;fi,
height);
#10 (sel_entry_content (list::last state1))
:=
THE (todelete,
#2(#2 (sel_entry_content
(list::last state1))));
stretch (reverse state1) state2;
apply (delete_canvas_item widget_id)
(map get_canvas_item_id
(list::cat
(map (#4 o sel_entry_content)
rest) @
map (*o (#5 o sel_entry_content))
rest @
list::cat
(map (*o (#6 o sel_entry_content))
rest)));
apply (add_canvas_item widget_id)
(list::cat (map (#4 o sel_entry_content)
state2) @
map (*o (#5 o sel_entry_content))
state2 @
list::cat
(map (*o (#6 o sel_entry_content))
state2));
state := state1 @ state2;
add_trait widget_id [SCROLL_REGION (0, 0, 0, maxy)];
reselect();
# Close
else # use
if ( not_null ( *( #10 (sel_entry_content (list::last state1)))))
# Use with known content:
delta1
=
#2( #2 (sel_entry_content
(list::last state1)))
-
#2 (the( *(#10 (sel_entry_content
(list::last state1)))));
state2
=
shift (#1 (the(*(#10 (sel_entry_content
(list::last
state1))))))
delta1;
delta2
=
#2 (#2 (sel_entry_content
(list::last state2))) -
#2(#2 (sel_entry_content
(list::last state1)));
state3 = shift rest delta2;
maxy =
int::max
(if (null state3)
#2(#2 (sel_entry_content
(list::last state2))) + 12;
else
#2(#2 (sel_entry_content
(list::last state3))) + 12;fi,
height);
stretch (reverse state1) state3;
apply (delete_canvas_item widget_id)
(map get_canvas_item_id
(list::cat
(map (#4 o sel_entry_content)
rest) @
map (*o (#5 o sel_entry_content))
rest @
list::cat
(map
(*o (#6 o sel_entry_content))
rest)));
apply (add_canvas_item widget_id)
(list::cat
(map (#4 o sel_entry_content)
state2) @
map (*o (#5 o sel_entry_content))
state2 @
list::cat
(map (*o (#6 o sel_entry_content))
state2) @
list::cat
(map (#4 o sel_entry_content)
state3) @
map (*o (#5 o sel_entry_content))
state3 @
list::cat
(map (*o (#6 o sel_entry_content))
state3));
state := state1 @ state2 @ state3;
add_trait widget_id
[SCROLL_REGION (0, 0, 0, maxy)];
reselect();
# use with known content
else
# use new
my (x, y) = #2 (sel_entry_content
(list::last state1));
my (state2, delta) =
subtree path ob (x + 17, y + 20);
state3 = shift rest delta;
maxy =
int::max
(if (null state3 )
#2(#2 (sel_entry_content
(list::last state2))) + 12;
else
#2(#2 (sel_entry_content
(list::last state3))) + 12;fi,
height);
stretch (reverse state1) state3;
apply (delete_canvas_item widget_id)
(map get_canvas_item_id
(list::cat
(map (#4 o sel_entry_content)
rest) @
map (*o (#5 o sel_entry_content))
rest @
list::cat
(map
(*o (#6 o sel_entry_content))
rest)));
apply (add_canvas_item widget_id)
(list::cat
(map (#4 o sel_entry_content)
state2) @
map (*o (#5 o sel_entry_content))
state2 @
list::cat
(map (*o (#6 o sel_entry_content))
state2) @
list::cat
(map (#4 o sel_entry_content)
state3) @
map (*o (#5 o sel_entry_content))
state3 @
list::cat
(map (*o (#6 o sel_entry_content))
state3));
state := state1 @ state2 @ state3;
add_trait widget_id
[SCROLL_REGION (0, 0, 0, maxy)];
reselect();
fi;
fi; # use new
} # my pressed_obj
also
fun subtree p ob (x, y)
=
{ fun subtree' (ob . obs) (l, ny) upper
=>
{
ent =
single_entry p ob (x, ny) FALSE upper;
newupper =
THE (not_null(#3 (sel_entry_content ent)));
subtree' obs (l @ [ent], ny + 20) newupper;
};
subtree' [] (l, ny) _
=>
(l, ny - y);
end;
subtree' (obj::children ob) ([], y) NULL;
};
# --- navigation / history --------------------------------------------------
fun selection ()
=
if (not_null *selected) THE (#3 (the *selected));
else NULL;
fi;
fun up ()
=
if (not_null *selected)
fun sep ((e: State_Entry) . es)
=
if ( #1 (sel_entry_content e)
== #1 (the *selected)
)
[];
else
e . sep es;
fi;
fun seek ((e: State_Entry) . es)
=>
if ( length(#1 (sel_entry_content e))
< length(#1 (the *selected))
)
THE e;
else seek es;
fi;
seek []
=>
NULL;
end;
to_select
=
seek (reverse (sep *state));
if (not_null to_select)
selected
(#1 (sel_entry_content (the to_select)))
(#8 (sel_entry_content (the to_select)))
(#7 (sel_entry_content (the to_select)))
(#9 (sel_entry_content (the to_select)))
TRUE
dummy_event;
fi;
fi;
fun position ()
=
if (null *history or length *history == 1)
hist_empty;
else
if (length *history == *history_pointer)
hist_end;
else
if (*history_pointer == 1) hist_start;
else hist_middle;
fi;
fi;
fi;
fun seek_and_open ((e: State_Entry) . es) path
=
if (path == (#1 (sel_entry_content e)))
e;
else
if ( sub_path path (#1 (sel_entry_content e))
and not_null(#3 (sel_entry_content e))
and (not (the(#3 (sel_entry_content e))))
)
pressed_obj (#7 (sel_entry_content e))
(#1 (sel_entry_content e))
dummy_event;
seek_and_open *state path;
else
seek_and_open es path;
fi;
fi;
fun back ()
=
if ( position() != hist_start
and position() != hist_empty
)
history_pointer := *history_pointer - 1;
p = list::nth (*history, *history_pointer - 1);
to_select = seek_and_open *state p;
selected (#1 (sel_entry_content (to_select)))
(#8 (sel_entry_content (to_select)))
(#7 (sel_entry_content (to_select)))
(#9 (sel_entry_content (to_select)))
FALSE
dummy_event;
fi;
fun forward ()
=
if ( position() != hist_end
and position() != hist_empty
)
history_pointer := *history_pointer + 1;
p = list::nth (*history, *history_pointer - 1);
to_select = seek_and_open *state p;
selected (#1 (sel_entry_content (to_select)))
(#8 (sel_entry_content (to_select)))
(#7 (sel_entry_content (to_select)))
(#9 (sel_entry_content (to_select)))
FALSE
dummy_event;
fi;
# --- initialize ------------------------------------------------------------
fun init ob
=
{ root = single_entry [] ob (10, 10) TRUE NULL;
root_id = hd(#1 (sel_entry_content root));
ents = root . #1 (subtree [root_id] ob (27, 30));
maxy = int::max(#2(#2 (sel_entry_content (list::last ents)))
+ 12, height);
selected := NULL;
state := ents;
history := [];
history_pointer := 0;
(SCROLL_REGION (0, 0, 0, maxy),
list::cat (map (#4 o sel_entry_content) ents) @
map (*o (#5 o sel_entry_content)) ents @
list::cat (map (*o (#6 o sel_entry_content)) ents));
};
fun check ob
=
if (obj::is_leaf ob)
print "LazyTrees: tree with leaf object";
raise exception ERROR "LazyTrees: tree with leaf object";
else
ob;
fi;
{ selection,
up,
position,
back,
forward,
canvas
=>
\\ ob
=
{ my (init_scroll, init_citems)
=
init ob;
CANVAS {
widget_id,
scrollbars => AT_RIGHT,
citems => init_citems,
packing_hints => [],
event_callbacks => [],
traits => [ WIDTH width,
HEIGHT height,
init_scroll,
BACKGROUND WHITE
]
};
}
};
}; # my tree_list
}; # package macro LazyTrees