## tree-list-g.pkg
## (C) 1999, Albert Ludwigs Universität Freiburg
## Author: bu
# Compiled by:
# src/lib/tk/src/toolkit/sources.sublib# ***************************************************************************
# A hierarchical Listbox -- tree-lie browsing and selection.
# **************************************************************************
### "The essence of mathematics lies in its freedom."
###
### -- Georg Cantor
api Treelist_Callbacks {
Part_Ilk; # SML-necessity since no HO-generics
eqtype Node_Info; # SML-necessity since no HO-generics
Subnode_Info; # SML-necessity since no HO-generics
Path; # SML-necessity since no HO-generics
content_label_action:
{ path: Path, was: String, cc: String -> Void } -> Void;
# fired whenever a content label is activated.
# Should be a modal action.
focus_change_notifier:
{ changed_at: List( Path ) } -> Void;
# fired whenever a folder label or a folder icon is modified;
# should be used if tree_list_g is nonmodally coupled over
# gui_state with a notepad.
objtree_change_notifier :
{ changed_at: Path } -> Void;
# fired whenever the tree-package (gui_state) has been modified -
# e.g. as a consequence of an internal drag-drop.
# Used for rehresh`s of other views.
open_close_notifier:
{ is_open: Bool, changed_at: List( Path ) } -> Void;
# fired whenever a folder label or a folder icon is opened;
# can be used if internal tree is incrementally .
error_action: String -> Void;
# fired whenever illegal drag-drop-operations are attempted.
# Should be a modal action.
};
api Join { # Only there for stupid SML-reasons
package m: Ptree_Part_Class; # Ptree_Part_Class is from src/lib/tk/src/toolkit/tree_object_class.api package a: Treelist_Callbacks; # Treelist_Callbacks is from src/lib/tk/src/toolkit/tree-list-g.pkg package clipboard: Clipboard; # Clipboard is from src/lib/tk/src/toolkit/clipboard-g.pkg sharing a::Part_Ilk == m::Part_Ilk;
sharing clipboard::Part == m::Cb_Objects;
sharing a::Node_Info == m::Node_Info;
sharing a::Subnode_Info == m::Subnode_Info;
sharing a::Path == m::Path;
};
generic package tree_list_g (package s: Join;) # Join is from src/lib/tk/src/toolkit/tree-list-g.pkg: (weak)
api {
Scale = MICRO | MINI | DEMO;
Config = { height: Ref( Int ), # Default 300
width: Ref( Int ), # Default 400
scrollbars: Ref( tk::Scrollbars_At ),# Default NOWHERE
no_icons: Ref( Bool ), # no icons used;
# default FALSE
std_icons: Ref( Bool ), # use icons speci-
# fied in M or use
# std-icons;
# default TRUE
scale_factor: Ref( Scale ) # scales display,
# default MICRO
};
my_config: Config;
create_canvas: List( s::m::Part_Ilk ) -> tk::Widget;
upd_guistate: s::m::Path -> List( s::m::Part_Ilk ) -> Void;
get_guistate: Void -> List( s::m::Part_Ilk );
refresh: s::m::Path -> Void;
refresh_label: Void -> Void;
get_selected: Void -> List( s::m::Part_Ilk );
set_selected: List( s::m::Path ) -> Void;
}
{
include package s;
include package tk;
include package global_configuration;
# ***********************************************************************
#
# Configuration ...
#
# ***********************************************************************
Scale = MICRO | MINI | DEMO; # According to icons / filer / *
Config
=
{ height: Ref( Int ), # Default 300
width: Ref( Int ), # Default 400
scrollbars: Ref( tk::Scrollbars_At ),# Default NOWHERE
no_icons: Ref( Bool ), /* no icons used;
default FALSE */
std_icons: Ref( Bool ), # Default TRUE
scale_factor: Ref( Scale ) /* scales display,
default 1 */
};
my
my_config
=
{ height => REF (300),
width => REF (400),
scrollbars => REF (tk::AT_RIGHT),
no_icons => REF FALSE,
std_icons => REF TRUE,
scale_factor => REF MICRO
};
fun debugmsg msg
=
debug::print 11 ("tree_list_g: " + msg);
my
default_printmode
=
{ mode => print::long,
printdepth => 100,
height => NULL,
width => NULL
}; # the value is temporary
fun name2string x
=
m::string_of_name (m::path2name x) default_printmode;
fun scale_to_string MICRO => "micro";
scale_to_string MINI => "mini";
scale_to_string DEMO => "demo"; end;
# Some Display Parameters
/* ****************************************************************
< in2 > -
* ^
* | <hi
<in1 >****** - -
* * ^
* ** **** |
* * | <box_height
****** _
<in3 >
< >box_width
**************************************************************** */
my
box_height = 9; my
box_width = 8; my
box_w_middle = 4; my
box_h_middle = 5; my
icon_width = 9; /* in realitaet 12 !!! */ my
in1 = 4; my
in2 = 9; my
in3 = 12; my
hi = 9;
# The crosshair for dragging an item:
my
drag_cursor = CURSOR (XCURSOR (make_cursor_name("fleur"), NULL));
fun height n
=
coordinate (0, n * (hi+box_height));
# ***********************************************************************
#
# The internal object-tree
#
# ***********************************************************************
# The internal object tree contains not only the pure data-package
# with labels, icons and object items, but also a decent abstraction of
# the state of the canvas, i.e. which folders are displayed
# open or closed ("is_open"), which ones are selected ("is_selct"), etc.
#
# For efficiency reasons, even more information is stored:
# - namely hooks to redisplay functions for local labels
# - and the CItems used in order to move substrees efficiently.
# (not yet implemented)
#
# However, there no real good reason for the fact, that I dicided to
# implement obj_tree in its own in this class here instead of providing
# a new instance of object_to_tree_object_g. Better patternmatch, and efficiency,
# maybe. But the price is code duplicity for critical functions like update.
Leaf_Type = { lab: (m::basic::Part_Ilk, m::Subnode_Info),
path: m::Path,
icon: Null_Or( Icon_Variety ),
cids: (Canvas_Item_Id, Canvas_Item_Id, Canvas_Item_Id, Canvas_Item_Id),
is_selct: Ref( Bool ),
rd_hook: Ref( Null_Or( Void_Callback ) )
};
Folder_Type( A_obj_tree ) =
{ lab: m::Node_Info,
path: m::Path,
subtrees: List( A_obj_tree ),
icon: Null_Or( Icon_Variety ),
cids: (Canvas_Item_Id, Canvas_Item_Id, Canvas_Item_Id ,
Canvas_Item_Id, Canvas_Item_Id, Canvas_Item_Id, Canvas_Item_Id),
is_open: Ref( Bool ),
is_selct: Ref( Bool ),
rd_hook: Ref( Null_Or( Void_Callback ) ) };
Obj_Tree = LEAF Leaf_Type
| FOLDER Folder_Type( Obj_Tree );
fun get_folder (folder x) = x;
fun get_leaf (leaf x) = x;
fun fst (x, y) = x;
fun snd (x, y) = y;
fun convert_ft ( { lab, path, icon, cids, is_selct, rd_hook, ... }
: Folder_Type( A_obj_tree )) =
{ my (x1, x2, x3, _, _, _, _) = cids;
{ lab, path, icon,
cids=>(x1, x2, x3),
is_selct,
rd_hook => rd_hook };
};
fun length [] => 0;
length ((leaf _) . rrr) => 1 + length rrr;
length ((folder { is_open, subtrees, ... } ) . rrr) =>
1 + (if *is_open length subtrees; else 0;fi) + (length rrr); end;
fun relabel (path, _) obs =
{ fun rel p [] => [];
rel p (a as (leaf { lab, path, icon, cids,
is_selct, rd_hook } ) . rrr) =>
leaf { lab, path=>m::path_abs (list::reverse p, snd (m::path_rep path)),
icon, cids, is_selct,
rd_hook }
. (rel p rrr);
rel p (a as (aob as (folder { lab, path, subtrees, icon, cids,
is_open, is_selct, rd_hook } )) . rrr) =>
folder { lab, path => m::path_abs (list::reverse p, NULL),
subtrees => rel (lab . p) subtrees,
icon, cids,
is_open, is_selct,
rd_hook => REF NULL }
. (rel p rrr); end;
rel (list::reverse path) obs; };
exception WRONG_UPDATE;
fun get_subtrees (folder { subtrees, ... } ) => subtrees;
get_subtrees _ => raise exception WRONG_UPDATE; end;
fun update clean path ob [] => [];
update clean path ob x =>
{ fun upd path [] => [];
# search for leaf on leaf >>>
upd ([], THE x) ((aob as (leaf { lab, ... } )) . rrr) =>
(case (m::basic::ord (x, fst lab))
EQUAL => { clean aob; ob . rrr;};
_ => aob . (upd ([], THE x) rrr); esac);
# search for leaf on fold >>>
upd ([], THE x) (aaa . rrr) => aaa . upd ([], THE x) rrr;
# replace folder by folder content >>>
upd ([x], NULL)((aob as (folder { lab, path, subtrees, icon, cids,
is_open, is_selct, rd_hook } )) . rrr)=>
(case (m::ord_node (x, lab))
EQUAL => { apply clean subtrees;
folder { lab, path,
subtrees=>get_subtrees ob /* !!! */,
icon, cids, is_open,
is_selct, rd_hook } . rrr;};
_ => aob . (upd ([x], NULL) rrr); esac);
# search for folder on leaf >>>
upd ([x], NULL) (aaa . rrr) => aaa . upd ([x], NULL) rrr;
# Descending in folder >>>
upd (x . rrr, hhh)((aob as (folder { lab, path, subtrees, icon, cids,
is_open, is_selct, rd_hook } )) . rrr') =>
(case (m::ord_node (x, lab))
EQUAL => (folder { lab, path,
subtrees=>upd (rrr, hhh) subtrees,
icon, cids, is_open,
is_selct, rd_hook } . rrr');
_ => aob . (upd (x . rrr, hhh) rrr'); esac);
upd (x . rrr, hhh) (aaa . rrr') => aaa . upd (x . rrr, hhh) rrr'; end;
upd (m::path_rep path) x; }; end;
exception WRONG_INSERT;
fun insert path obs [] => raise exception WRONG_INSERT;
insert path obs x =>
{ fun ins path [] => [];
# search for leaf on leaf >>>
ins ([], THE x) ((aob as (leaf { lab, ... } )) . rrr) =>
(case (m::basic::ord (x, fst lab))
EQUAL => (aob . (relabel (m::path_rep path) obs)@rrr);
_ => aob . (ins ([], THE x) rrr); esac);
# search for leaf on fold >>>
ins ([], THE x) (aaa . rrr) => aaa . ins ([], THE x) rrr;
# replace folder by folder content >>>
ins ([x], NULL)((aob as (folder { lab, path, subtrees, icon, cids,
is_open, is_selct, rd_hook } )) . rrr)=>
(case (m::ord_node (x, lab))
EQUAL => (aob . (relabel (m::path_rep path) obs)@rrr);
_ => aob . (ins ([x], NULL) rrr); esac);
# search for folder on leaf >>>
ins ([x], NULL) (aaa . rrr) => aaa . ins ([x], NULL) rrr;
# Descending in folder >>>
ins (x . rrr, hhh)((aob as (folder { lab, path, subtrees, icon, cids,
is_open, is_selct, rd_hook } )) . rrr') =>
(case (m::ord_node (x, lab))
EQUAL => (folder { lab, path,
subtrees=>ins (rrr, hhh) subtrees,
icon, cids, is_open,
is_selct, rd_hook } . rrr');
_ => aob . (ins (x . rrr, hhh) rrr'); esac);
ins (x . rrr, hhh) (aaa . rrr') => aaa . ins (x . rrr, hhh) rrr'; end;
ins (m::path_rep path) x; }; end;
fun is_open_at _ [] => FALSE;
is_open_at (a . rrr) ((leaf _) . rrr') => is_open_at (a . rrr) (rrr');
is_open_at [a] ((folder { lab, is_open, subtrees, ... } ) . rrr') =>
if *is_open
case (m::ord_node (a, lab))
EQUAL => TRUE;
_ => FALSE; esac;
else is_open_at [a] (rrr');fi;
is_open_at (a . rrr) ((folder { lab, is_open, subtrees, ... } ) . rrr') =>
if *is_open
case (m::ord_node (a, lab))
EQUAL => is_open_at (rrr) (subtrees);
_ => FALSE; esac;
else is_open_at (a . rrr) (rrr');fi; end;
fun cids_of [] => [];
cids_of((leaf { cids=>(aaa, bbb, ccc, dddd), ... } ) . rrr) => aaa . bbb . ccc . dddd . (cids_of rrr);
cids_of((folder { cids=>(aaa, bbb, ccc, dddd, eee', fff, ggg), subtrees, ... } ) . rrr) =>
aaa . bbb . ccc . dddd . eee' . fff . ggg . (cids_of rrr)@(cids_of subtrees); end;
# ***********************************************************************
#
# Conversion ...
#
# ***********************************************************************
fun gen_cids1 () = (make_canvas_item_id(), make_canvas_item_id(), make_canvas_item_id(), make_canvas_item_id());
fun gen_cids2 () = (make_canvas_item_id(), make_canvas_item_id(), make_canvas_item_id(),
make_canvas_item_id(), make_canvas_item_id(), make_canvas_item_id(), make_canvas_item_id());
my
texticon_id = make_image_id (); my
foldericon_id = make_image_id ();
fun text_icon ()
=
FILE_IMAGE((tk::get_lib_path())$
"/icons/treelist/"$
(scale_to_string *my_config.scale_factor) $
"/text.gif",
texticon_id);
fun folder_icon ()
=
FILE_IMAGE((tk::get_lib_path())$
"/icons/treelist/"$
(scale_to_string *my_config.scale_factor) $
"/folder.gif",
foldericon_id);
fun obj2obj_tree0 p obj
=
if (m::is_folder obj )
{ my (h, s) = m::get_folder obj;
p = h . p;
folder { lab => h,
path => m::path_abs (list::reverse p, NULL),
subtrees => map (obj2obj_tree0 p) s,
icon => if *my_config.no_icons NULL;
else THE (folder_icon ());fi,
cids => gen_cids2 (),
is_open => REF FALSE, is_selct => REF FALSE,
rd_hook => REF NULL };
};
else
leaf { lab => m::get_content obj,
path => m::path_abs (list::reverse p, THE (fst (m::get_content obj))),
icon => if *my_config.no_icons NULL;
elif *my_config.std_icons THE (text_icon ());
else THE (icons::get_microlined_variety (m::icon (m::part_type obj)));
fi,
cids => gen_cids1 (),
is_selct => REF FALSE,
rd_hook => REF NULL
};
fi;
my
obj2obj_tree = obj2obj_tree0 [];
fun obj_tree2obj (folder { lab, subtrees, ... } )
=>
m::folder
(lab, map obj_tree2obj subtrees);
obj_tree2obj (leaf { lab, ... } )
=>
m::content lab; end;
# ***********************************************************************
#
# Display related dagwalk ...
#
# ***********************************************************************
fun clear_sel [] => ();
clear_sel((leaf { is_selct, rd_hook, ... } ) . rrr) =>
{ if *is_selct { is_selct:=FALSE; the *rd_hook ();};
fi;
clear_sel rrr;};
clear_sel((folder { is_selct, rd_hook, subtrees, ... } ) . rrr) =>
{ if *is_selct { is_selct:=FALSE; the *rd_hook ();};
fi;
clear_sel subtrees;
clear_sel rrr;}; end;
fun deselect [] => FALSE;
deselect ((leaf { is_selct, ... } ) . rrr) =>
({ h = *is_selct;
r = deselect rrr;
is_selct:=FALSE; h or r; });
deselect ((folder { is_selct, subtrees, ... } ) . rrr) =>
({ h = *is_selct;
r = deselect rrr;
r' = deselect subtrees;
is_selct:=FALSE; h or r or r'; }); end;
fun set_sel_range aaa tree =
{ mark_mode = REF (0); /* 0 = init, 1 = fill-to-mode,
2 = fill-from-mode, 3 = delete-mode */
fun mlr [] => ();
mlr ((leaf { cids=>(_, _, ccc, _), is_selct, rd_hook, ... } ) . rrr) =>
{ case *mark_mode
0 => if (aaa == ccc) mark_mode:=1;
is_selct:=TRUE;
the *rd_hook ();
elif *is_selct mark_mode:=2;
fi;
1 => if (aaa == ccc) mark_mode:=3;
is_selct:=TRUE;
the *rd_hook();
elif *is_selct mark_mode:=3;
else is_selct:=TRUE;
the *rd_hook ();
fi;
2 => if (aaa == ccc ) mark_mode:=3;
is_selct:=TRUE;
the *rd_hook ();
elif *is_selct ();
else is_selct:=TRUE;
the *rd_hook ();
fi;
3 => if not *is_selct ();
else is_selct:=FALSE;
the *rd_hook ();
fi;
esac;
mlr rrr;};
mlr((folder { cids=>(_, _, _, _, _, ccc, _), is_open, is_selct,
rd_hook, subtrees, ... } ) . rrr) =>
{ case *mark_mode
0 => if (aaa == ccc ) mark_mode:=1;
is_selct:=TRUE;
the *rd_hook ();
elif *is_selct mark_mode:=2;
fi;
1 => if (aaa == ccc ) mark_mode:=3;
is_selct:=TRUE;
the *rd_hook ();
elif *is_selct mark_mode:=3;
else is_selct:=TRUE;
the *rd_hook ();
fi;
2 => if (aaa == ccc ) mark_mode:=3;
is_selct:=TRUE;
the *rd_hook ();
elif *is_selct ();
else is_selct:=TRUE;
the *rd_hook ();
fi;
3 => if (not *is_selct) ();
else is_selct:=FALSE;
the *rd_hook ();
fi;
esac;
if *is_open mlr subtrees; fi;
mlr rrr;
};
end;
mlr tree; };
# ***********************************************************************
#
# State ...
#
# ***********************************************************************
gui_state = REF ([]: List( Obj_Tree ));
global_drag_drop_namings = REF([]:List( Event_Callback ));
refresh_hook = REF( NULL: Null_Or( s::m::Path -> Void ) );
/*
fun get_selected0 () =
let fun get_sel [] = []
|get_sel((leaf { is_selct, lab, path, ... } ) . rrr) =
(if *is_selct then [(path, m::Content lab)]
else []) @ (get_sel rrr)
|get_sel((folder { is_selct, subtrees, lab, path, ... } ) . rrr) =
(if *is_selct
then [(path, m::Folder (lab, map obj_tree2obj subtrees))]
else get_sel subtrees)
@ (get_sel rrr)
in get_sel *gui_state end;
*/
fun get_selected0 ()
=
get_sel *gui_state
where
fun get_sel []
=>
[];
get_sel ((a as leaf { is_selct, lab, path, ... } ) . rrr)
=>
if *is_selct [ (path, a) ];
else [ ];
fi
@
(get_sel rrr);
get_sel ((a as folder { is_selct, subtrees, lab, path, ... } ) . rrr)
=>
if *is_selct [(path, a)];
else get_sel subtrees;
fi
@
(get_sel rrr);
end;
end;
fun get_selected ()
=
map (obj_tree2obj o snd) (get_selected0());
fun rem_selected []
=>
[];
rem_selected ((a as (leaf { is_selct, lab, path, ... } )) . rrr)
=>
(if *is_selct []; else [a];fi) @ (rem_selected rrr);
rem_selected ((a as (folder { lab, path, subtrees, icon, cids, is_open, is_selct, rd_hook } )) . rrr)
=>
if *is_selct
[];
else
[ folder { lab,
path,
icon,
cids,
is_open,
is_selct,
rd_hook,
subtrees => rem_selected subtrees
}
];
fi
@
(rem_selected rrr);
end;
fun set_selected _ = (); # NOT YET IMPLEMETED
fun get_guistate () = map obj_tree2obj *gui_state;
# ***********************************************************************
#
# Drag-drop-control ...
#
# ***********************************************************************
fun debugmsg x = print x;
fun debugmsg x = ();
Dragmodetype = INTERNAL # from tl-canvas to tl-canvas
| EXTERNAL # from tl-canvas to extern
| IMPORT; # from extern to tl-canvas
dragmode = REF (NULL: Null_Or( Dragmodetype )); # NULL: don't know
fun press_grab_button path can_id (ev: Tk_Event)
=
{ dragmode := NULL;
debugmsg "drag:";
debugmsg (name2string path);
debugmsg "\n";
add_trait can_id [drag_cursor];};
fun release_grab_button path can_id (TK_EVENT(_, _, x, y, _, _))
=
{ debugmsg ("release:");
debugmsg (name2string path);
case *dragmode
NULL => debugmsg ": none \n";
THE IMPORT => debugmsg ": Import \n";
THE INTERNAL => debugmsg ": internal \n";
THE EXTERNAL => debugmsg ": external \n";
esac;
# Dragmode := NULL;
add_trait can_id [CURSOR (NO_CURSOR)];};
fun grabbed_motion can_id _
=
{ dragmode := THE (internal);
debugmsg "motion \n";};
fun leave_canvas can_id ev =
{ case *dragmode
THE (internal) => dragmode := THE (external);
_ => dragmode := NULL; esac;
debugmsg "leave: \n";
{ objs = get_selected();
fun remove objs = (print " export objects \n");
clipboard::put (m::cb_objects_abs (\\() => objs; end )) ev
(\\() => remove (objs); end ); }
;};
fun import_objects to_path objs ev =
{ print " include objects \n";
if (clipboard::is_empty ev ) ();
else { objs = (m::cb_objects_rep (clipboard::get ev))();
fun do_it x = ();
do_it objs; };fi;};
fun move_objects path intern canvas_id =
{ print " move objects \n";
# internal objects have been dragged into can Id.
# This resulted in storing the objects in the
# internal_release_buffer.
{ objs = map snd (get_selected0());
state' = rem_selected *gui_state;
state'' = insert path objs state';
# first: delete everything from screen (including
# stuff not in nustate)
apply (\\ x => (delete_canvas_item canvas_id x
except CANVAS_ITEM _ => (); end ); end )
(cids_of *gui_state);
gui_state:=state'';
the *refresh_hook (m::path_abs([], NULL));
# <<< removes again, but does not hurt <<<
a::objtree_change_notifier { changed_at=>m::path_abs([], NULL) };
# HACK! more precise: least common prefix of all paths . . .
};};
# enterCanvas atpath called_internally inCanvasId ...
fun enter_canvas path TRUE can_id ev
=>
{ debugmsg ("enter:1:");
debugmsg (name2string path);
case *dragmode
THE EXTERNAL => (print (":ext \n"));
THE IMPORT => { print (":imp \n");
import_objects path TRUE ev;};
THE INTERNAL => { print (":int \n");
move_objects path TRUE can_id;};
_ => print (":no \n");
esac;
dragmode := NULL;};
enter_canvas path FALSE can_id ev
=>
{ debugmsg ("enter:2:");
debugmsg (name2string path);
case *dragmode
THE EXTERNAL => print (":ext \n");
THE INTERNAL => { print (":int \n");
move_objects path FALSE can_id;};
THE IMPORT => { print (":imp \n");
import_objects path FALSE ev;};
_ => print (":no \n");
esac;
dragmode := NULL;
};
end;
fun press_sel_button can_id _
=
();
# ***********************************************************************
#
# object-tree - drawing ...
#
# ***********************************************************************
canvas_id = make_widget_id();
fun cline (cid, c, cl, bl)
=
tk::CANVAS_LINE { citem_id=>cid, coords=>c,
traits=>cl, event_callbacks=>bl };
# make_label: generates a editable label for folders and basicobjects.
# Lots of functionality for selection is provided -
# requiring additional information of the global tree, the surrounding
# canvas-widget, the Canvas_Item_ID for delete-management.
fun make_label is_selected rd_hook (gttxt, updtxt) pos aaa wid path
=
# in order not to redraw the whole tree in case of a selection,
# local redraw functions are provided here and stored in the
# obj_tree via the hooks. Thus, selection with global effects
# can be implemented via evaluating the local redraw functions
# on demand. This complicates the story a bit.
{ label_id = make_widget_id();
fun col_lab b
=
if b BACKGROUND (*(colors::config.background_sel));
else BACKGROUND (*(colors::config.background));fi;
fun relief_lab b
=
b ?? RELIEF SUNKEN
:: RELIEF FLAT;
fun redraw _
=
(add_trait label_id [col_lab *is_selected,
relief_lab *is_selected,
TEXT (gttxt())]);
fun hilite b _
=
if (not *is_selected)
add_trait label_id [col_lab (b)];
fi;
fun sel_action _
=
{ clear_sel *gui_state;
is_selected := TRUE;
the *rd_hook ();
};
fun sel_range_action _
=
(set_sel_range aaa *gui_state);
fun sel_group_elem_action _
=
{ is_selected:= not *is_selected;
the *rd_hook ();};
fun activate _
=
{ updtxt (the *rd_hook);
redraw ()
;};
fun lab b
=
LABEL { widget_id=>label_id,
packing_hints => [],
event_callbacks => [EVENT_CALLBACK (events::sel_elem_event(),
\\ XX => { sel_action XX;
# Drag-code >>>
press_grab_button
path wid XX;}; end ),
/*CONFLICT with:
EVENT_CALLBACK (Events::drag_event(),
pressGrabButton path wid), */ /* Problem: This conflict-resolution above
assumes a particular configuration
of sel_elem_event() and drag_event() */
EVENT_CALLBACK (events::drop_event(), release_grab_button path wid),
EVENT_CALLBACK (events::dd_motion_event(), grabbed_motion wid),
EVENT_CALLBACK (events::sel_range_event(),
sel_range_action),
EVENT_CALLBACK (events::sel_group_elem_event(),
sel_group_elem_action),
EVENT_CALLBACK (events::activate_event(),
activate),
EVENT_CALLBACK (ENTER, \\ XX=>{ hilite TRUE XX;
enter_canvas path
FALSE wid XX;}; end ),
EVENT_CALLBACK (LEAVE, hilite FALSE)
],
traits => [TEXT (gttxt ()),
col_lab b, relief_lab b,
FONT (tk::SANS_SERIF [tk::SMALL])]
};
m = coordinate (icon_width + 4, 0);
fun make_clab b
=
CANVAS_WIDGET {
citem_id => aaa,
coord => add_coordinates pos m,
subwidgets => PACKED [lab b],
traits => [ANCHOR WEST],
event_callbacks => []
};
rd_hook := THE redraw;
make_clab *is_selected;
};
# mini-box: clickable symbol for folders; activation may result in opening
# the folder by displaying the subtree. The symbol is drawn - not a gif.
# b: open/close status; pos: top-left start position of the drawing,
# aaa, bbb, ccc, dddd: Canvas_Item_ID's stored here for systematic release,
# cmd: command for activation, path: info for activation and debugging:
fun mini_box b pos (aaa, bbb, ccc, dddd) cmd path
=
{ fun cm _ = { a::open_close_notifier { is_open=> *b, changed_at => [path] };
# Caution ! this may change the gui_state !
cmd();};
bi = EVENT_CALLBACK (events::activate_event(), cm);
[CANVAS_BOX { citem_id=>aaa, coord1=>pos,
coord2=>add_coordinates pos (coordinate (box_width, box_height)),
traits => [FILL_COLOR WHITE, OUTLINE BLACK], event_callbacks => [bi] },
cline (bbb,[add_coordinates pos (coordinate (2, box_h_middle)),
add_coordinates pos (coordinate (box_width - 1, box_h_middle))],[],[bi]),
cline (ccc,[add_coordinates pos (coordinate (box_width, box_h_middle)),
add_coordinates pos (coordinate (in3, box_h_middle))],[],[bi])] @
(if *b [];
else [cline (dddd,[add_coordinates pos (coordinate (box_w_middle, 2)),
add_coordinates pos (coordinate (box_w_middle, box_width))],
[],[bi])];fi);
};
# icon_piece: clickable symbol for folders and basicobjects;
# activation may result in firing the activation fate.
# The symbol is a gif - either user-defined (i available), or standard.
# p: top-left start position of the drawing,
# path: info for activation and debugging
fun icon_piece (THE i) citem_id p path hi wid
=>
{ fun activate _
=
a::focus_change_notifier { changed_at => [path] };
[ CANVAS_ICON {
citem_id,
coord => add_coordinates p (add_coordinates (in3+1, box_h_middle) hi),
icon_variety => i,
traits => [ANCHOR WEST],
event_callbacks => [ /* EVENT_CALLBACK (Events::sel_elem_event(), sel_action),
EVENT_CALLBACK (Events::sel_range_event(), sel_range_action),
EVENT_CALLBACK (Events::sel_group_elem_event(),
sel_group_elem_action),
*/
EVENT_CALLBACK (events::drag_event(), press_grab_button path wid),
EVENT_CALLBACK (events::drop_event(), release_grab_button path wid),
EVENT_CALLBACK (events::activate_event(), activate),
EVENT_CALLBACK (ENTER, enter_canvas path FALSE wid)
]
}
];
};
icon_piece (NULL) citem_id p path hi wid => []; end;
# folder_line: line in tree consisting of box, icon, and label (for folders).
# All information from the context tree must be passed to the drawing
# functions of these subitems.
# The offset off produces a shift of the line level and a suitably prologued
# front vertex.
fun folder_line is_open is_slct rdh icon p path
off lab (aaa, bbb, ccc, dddd, eee', fff, ggg) cmd wid
=
{ p' = add_coordinates p (coordinate (in1, 0));
hi = add_coordinates (coordinate (0, hi)) (height off);
li = cline (aaa, [p', add_coordinates p' hi],[],[]);
p'' = add_coordinates p hi;
p'''= add_coordinates p (add_coordinates (coordinate (in3, box_h_middle)) hi);
li . mini_box is_open p'' (bbb, ccc, dddd, eee') cmd path @
icon_piece icon ggg p path hi wid @
[make_label is_slct rdh lab p''' fff wid path];
};
# object_line: line in tree consisting of front vertrex, icon, and label
# (for basicobjects).
# All information from the context tree must be passed to the drawing
# functions of these subitems.
# The offset off produces a shift of the line level and a suitably
# prolongued front vertex.
fun object_line is_open is_slct rdh icon p path off lab (aaa, bbb, ccc, dddd) wid
=
{ p' = add_coordinates p (coordinate (in1, 0));
hi = add_coordinates (coordinate (0, hi)) (height off);
hi_tot= add_coordinates hi (coordinate (0, box_height));
p'' = add_coordinates (add_coordinates p' hi)
(coordinate (0, box_h_middle));
p''' = if is_open add_coordinates p' hi_tot; else p'';fi;
p'''' = add_coordinates p (add_coordinates (coordinate (in3, box_h_middle)) hi);
[cline (aaa, [p', p'''],[],[]),
cline (bbb, [p'', add_coordinates p'' (coordinate (in3-in1, 0))],[],[])] @
icon_piece icon dddd p path hi wid @
[make_label is_slct rdh lab p'''' ccc wid path];
};
fun diag1 maxcl p lab ccc
=
{ s = m::basic::string_of_name (m::basic::name_of lab) maxcl;
fun upd1 s lab ccc= (\\ s' => if (s==s' ) ();
else { m::basic::rename s' lab; ccc();};fi; end );
a::content_label_action {
path => p,
was => s,
cc => upd1 s lab ccc
};
};
fun diag2 maxcl p lab ccc
=
{ s = m::string_of_name_node lab maxcl;
fun upd2 s lab ccc= (\\ s' => if (s==s' ) ();
else { m::rename_node s' lab; ccc();};fi; end );
a::content_label_action {
path=>p,
was=>s,
cc=>upd2 s lab ccc
};
};
# placing a tree into a canvas - with all jingles . . .
fun place_tree pos wid tree
=
{ cl = { mode=>print::short, printdepth=>1,
height=>NULL, width=>NULL }; # HACK !
fun str1 lab = (\\ () => m::basic::string_of_name
(m::basic::name_of lab) cl; end );
fun str2 lab = (\\ () => m::string_of_name_node lab cl; end );
fun shift n p = add_coordinates p (height n);
fun indent p = add_coordinates p (coordinate (in3 + (icon_width div 2) - 1, 0));
fun beh1 p lab = (str1 lab, diag1 cl p lab);
fun beh2 p lab = (str2 lab, diag2 cl p lab);
fun open_cont p lt is_open_ref _ =
{ is_open_ref := not *is_open_ref;
(.is_selct (get_folder lt)) := deselect [lt];
refresh (m::path_rep p);};
# the core of the display algorithm:
fun pt p off ([]) => [];
pt p off ((leaf { lab, icon, cids, is_selct, rd_hook, path, ... } ) . rrr) =>
(object_line (not (null rrr)) is_selct rd_hook icon p path
off (beh1 path (fst lab)) cids wid) @
(pt (shift (1+off) p) 0 rrr);
pt p off ((lt as folder { icon, lab, cids, is_selct,
rd_hook, is_open, subtrees, path, ... } ) . rrr)=>
if *is_open
(folder_line is_open is_selct rd_hook icon p path
off (beh2 path lab)
cids (open_cont path lt is_open) wid) @
(pt (indent (shift 1 p)) (0) subtrees) @
(pt (shift (1+off) p) (length subtrees) rrr);
else (folder_line is_open is_selct rd_hook icon p path
off (beh2 path lab)
cids (open_cont path lt is_open) wid) @
(pt (shift (1+off) p) 0 rrr);fi; end;
debugmsg "place_tree ... "; pt pos 0 tree;
}
also
fun refresh ([], _)
=>
{ apply (\\ x => (delete_canvas_item canvas_id x
except CANVAS_ITEM _ => (); end ); end )
(cids_of *gui_state);
# gui_state := map (obj2obj_tree o obj_tree2obj) *gui_state;
apply (add_canvas_item canvas_id)
(place_tree (coordinate (10, 15)) canvas_id *gui_state)
;};
refresh (p, NULL) => refresh ([], NULL); end;
/* correct, but inefficient. This refresh is used for internal
use - i.e. redisplay for open-close-actions. */
fun refresh_o ([], xxx')
=>
refresh ([], xxx');
refresh_o (p, NULL)
=>
if (is_open_at p *gui_state)
# Very simple heuristic
# to keep it smooth.
print "refresh full\n";
refresh ([], NULL);
else
(print "refresh optimized\n");
fi;
end;
refresh = (\\ p = refresh (m::path_rep p));
refresh_o = (\\ p = refresh_o (m::path_rep p));
fun refresh_label ()
=
rl *gui_state
where
fun rl [] => ();
rl ((leaf { rd_hook, ... } ) . rrr)
=>
{ the *rd_hook ();
rl rrr;
};
rl ((folder { rd_hook, is_open, subtrees, ... } ) . rrr)
=>
{ the *rd_hook ();
if *is_open rl subtrees; fi;
rl rrr;
};
end;
end;
fun redisplay ()
=
{ apply
(\\ x = (delete_canvas_item canvas_id x
except CANVAS_ITEM _ = ()))
(cids_of *gui_state);
# <<< better: scratch everything from complete canvas ...
#
gui_state
:=
map (obj2obj_tree o obj_tree2obj)
*gui_state;
apply
(add_canvas_item canvas_id)
(place_tree (coordinate (10, 15)) canvas_id *gui_state);
};
# ***********************************************************************
#
# update access to gui_state ...
#
# ***********************************************************************
/* merge maintains the internal data-package,
as long as there are no differences to the
analogous external package. Maintaining
means open/Close, cids, etc. Path is patched.
*/
fun merge p rrr [] => rrr;
merge p [] rrr => map (obj2obj_tree0 p) rrr;
merge p ((aob as (leaf { lab, ... } )) . rrr) (a . rrr') =>
if (m::is_folder a ) ((obj2obj_tree0 p a) . (merge p rrr rrr'));
else (case (m::basic::ord (fst (m::get_content a), fst lab))
EQUAL => aob . (merge p rrr rrr');
_ => (obj2obj_tree0 p a) . (merge p rrr rrr'); esac);fi;
merge p ((aob as (folder { lab, path, subtrees, icon, cids,
is_open, is_selct, rd_hook } )) . rrr) (a . rrr') =>
if (m::is_folder a )
{ my (n, rrr'') = m::get_folder a;
(case (m::ord_node (n, lab))
EQUAL => ((folder { lab, path=>m::path_abs (list::reverse p, NULL),
subtrees => merge (n . p) subtrees rrr'',
icon, cids, is_open,
is_selct, rd_hook } )
. (merge p rrr rrr'));
_ => (obj2obj_tree0 p a) . (merge p rrr rrr'); esac);
};
else (obj2obj_tree0 p a) . (merge p rrr rrr');fi;
end;
fun upd_guistate (p as ([], NULL)) obs
=>
{ apply (\\ x => (delete_canvas_item canvas_id x
except CANVAS_ITEM _ => (); end ); end )
(cids_of *gui_state);
gui_state:= map obj2obj_tree obs;};
upd_guistate (p as (m, _)) [ob] =>
{ fun clean dob = apply (\\ x => (delete_canvas_item canvas_id x
except CANVAS_ITEM _ => (); end ); end )
(cids_of [dob]);
gui_state:=update clean (m::path_abs p)
(obj2obj_tree0 (tl (reverse m)) ob)
*gui_state;
};
end;
upd_guistate = \\ p => \\ obs => upd_guistate (m::path_rep p) obs; end; end ;
fun canvas_event_callbacks can_id
=
[ EVENT_CALLBACK (events::drag_event(), \\ _ => { clear_sel *gui_state;
dragmode:=NULL;
refresh_label ();}; end ),
EVENT_CALLBACK (events::drop_event(), release_grab_button (m::path_abs([], NULL)) can_id),
EVENT_CALLBACK (events::dd_motion_event(), grabbed_motion can_id),
EVENT_CALLBACK (events::dd_leave_event(), leave_canvas can_id),
# EVENT_CALLBACK (Events::dd_enter_event(), enterCanvas([], NULL)TRUE canId),
# <<< seems to have no effect . . .
# EVENT_CALLBACK (ENTER, enterCanvas ([], NULL) FALSE canId)
EVENT_CALLBACK (LEAVE, leave_canvas can_id)
];
/* Events::drag_event() = BUTTON_PRESS (THE 1)
Events::drop_event() = BUTTON_RELEASE (THE 1)
Events::dd_motion_event() = MODIFIER_BUTTON (1, MOTION)
Events::dd_leave_event() = MODIFIER_BUTTON (1, LEAVE)
Events::dd_enter_event() = MODIFIER_BUTTON (1, ENTER)
*/
fun create_canvas obj
=
{ my () = { gui_state := map obj2obj_tree obj;
global_drag_drop_namings := canvas_event_callbacks canvas_id;
refresh_hook:=THE (refresh);};
CANVAS {
widget_id => canvas_id,
scrollbars => *my_config.scrollbars,
citems => (place_tree (coordinate (10, 15))canvas_id *gui_state),
packing_hints => [PACK_AT TOP, FILL ONLY_X, EXPAND TRUE],
event_callbacks => *global_drag_drop_namings,
traits => [ HEIGHT *my_config.height,
WIDTH *my_config.width,
RELIEF GROOVE,
BACKGROUND (*(colors::config.background))
]
};
};
my
refresh = refresh_o; # This optimized refresh is exported ...
};