## tree_list.pkg
## (C) 1999, Albert Ludwigs Universität Freiburg
## Author: bu
# Compiled by:
# src/lib/tk/src/toolkit/tests+examples/sources.sublib# **************************************************************************
# Test of hierarchical Listbox.
# **************************************************************************
package little_tree_list
: (weak)
api {
go: Void -> String;
}
{
include package tk;
# ***********************************************************************
#
# Data Construction
#
# ***********************************************************************
package m: (weak) Part_Class # Part_Class is from src/lib/tk/src/toolkit/object_class.api =
package {
Name = Ref( String );
Part_Ilk = ((Int, Name));
Part_Type = INT;
fun ord ((x, _), (x', _)) = int::compare (x, x');
fun name_of(_, y) = y;
fun rename s (x, y) = (y:=s);
fun reset_name (x, y)=(y:="stdname: " $ (int::to_string x));
fun string_of_name s t = *s;
fun part_type _ = INT;
fun icon _ = { print"W\n";raise exception empty;};
Cb_Objects = Void -> List( Part_Ilk );
fun cb_objects_abs x = x;
fun cb_objects_rep x = x;
};
package n: (weak) Folder_Info # Folder_Info is from src/lib/tk/src/toolkit/tree_object_class.api =
package {
Node_Info = Ref( String );
Subnode_Info = Void;
fun ord_node (x, y) = string::compare(*x,*y);
fun string_of_name_node s _ = *s;
fun rename_node s t = (t:=s);
fun reset_name_node s = (s:="...");
};
package tree_obj
=
object_to_tree_object_g (package n = n also m = m;);
# ***********************************************************************
#
# Provoding additional TreeList-Behaviour
# (Renaming dialogues etc.) and intantiating tree_list_g
#
# ***********************************************************************
package treelist_callbacks: (weak) Treelist_Callbacks # Treelist_Callbacks is from src/lib/tk/src/toolkit/tree-list-g.pkg =
package {
Part_Ilk = tree_obj::Part_Ilk;
Node_Info = tree_obj::Node_Info;
Subnode_Info = tree_obj::Subnode_Info;
Path = tree_obj::Path;
fun content_label_action { path, was, cc } =
uw::enter_line { title=>"enter label:",
prompt=>"", default=>was,
width=>15, cc };
fun to_str x = tree_obj::string_of_name
(tree_obj::path2name x)
{ mode => print::long,
printdepth=>100,
height=>NULL,
width=>NULL };
fun objtree_change_notifier { changed_at: Path } =
(print ( "general change notifier at :"$
(to_str changed_at) + "\n"));
fun focus_change_notifier { changed_at: List( Path ) } =
(print ( "notifier activated at :" +
(string::cat
(map to_str changed_at)) +
"\n"));
fun open_close_notifier { is_open: Bool,
changed_at: List( Path ) } =
(print ( "open/close notifier activated at :" +
(string::cat
(map to_str changed_at)) +
"\n"));
fun error_action s = (uw::error "ERROR" );
};
package clipboard = clipboard_g ( Part = Void -> List( tree_obj::Part_Ilk ); );
package tree_list =
tree_list_g (package s = package {
package m = tree_obj;
package a = treelist_callbacks;
Objlist = Void ->
List( tree_obj::Part_Ilk );
package clipboard = clipboard;
};);
# ***********************************************************************
#
# Wrapping TreeList in a window
#
# ***********************************************************************
fun quit_button window
=
BUTTON {
widget_id => make_widget_id(),
packing_hints => [PACK_AT TOP, FILL ONLY_X, EXPAND TRUE],
traits => [TEXT "Quit", CALLBACK (\\ () = close_window window)],
event_callbacks => []
};
fun testwin test
=
{ my
winid = make_window_id ();
make_window {
window_id => winid,
traits => [ WINDOW_TITLE "Little Folder Tree",
WINDOW_ASPECT_RATIO_LIMITS (4, 3, 4, 3),
WIDE_HIGH_MIN (200, 200),
WIDE_HIGH_MAX (500, 400)],
subwidgets => PACKED [tree_list::create_canvas test,
quit_button winid],
event_callbacks => [],
init => (\\ ()=> (); end )
};
};
# ***********************************************************************
#
# Building a hierarchical object "test"
#
# ***********************************************************************
stipulate
include package tree_obj;
herein
# local name generation management:
my
ctr = REF (0);
fun make_obj s
=
((*ctr, REF (s)), ());
fun make_fol s
=
REF (s);
fun emb s
=
((), s);
my
test = [ content (make_obj"blub"),
folder (make_fol"bla",
[content (make_obj"fgh"),
folder (make_fol"g8tgku",[]),
folder (make_fol"rtfu",[])
]
),
folder (make_fol"blerg",[])
];
end;
# ***********************************************************************
#
# Run the sucker !
#
# ***********************************************************************
fun go ()
=
start_tcl_and_trap_tcl_exceptions [ testwin test ];
};