Commit daeef269 authored by gerd's avatar gerd

Initial revision.


git-svn-id: https://godirepo.camlcity.org/svn/lib-lx/trunk@1 3abd92e6-44db-0310-a70e-9adb87e41fd4
parents
This diff is collapsed.
(* $Id: lx_spots.mli,v 1.1 2002/06/08 19:36:37 gerd Exp $
* ----------------------------------------------------------------------
*
*)
(* Lx_spots provides an additional feature for labltk canvases: You can
* define event handlers for rectangular regions ("spots") that are independent
* of any canvas object. Remember that the Canvas module only allows
* event handlers that are bound to canvas objects (Canvas.bind), and
* the handlers for an object are only active if the object happens to
* be visible at a certain position, and is not hidden by another
* object.
*
* Spots are different. First, spots are always rectangular. Second,
* a spot never hides another spot. When spots overlap, both spots are
* considered as being active in the overlapping region, and the handlers
* of both spots are called.
*
* Last but not least, there are no memory leaks with spots. The handlers
* defined by Canvas.bind cannot be released individually, and will
* allocate memory until the whole canvas is destroyed. This makes highly
* dynamic canvas instances impossible. In contrast to this, spots can
* be deleted, and the memory of the released handlers will be given back
* to the system.
*)
type supported_event =
[ `Motion | `Enter | `Leave | `KeyPress | `KeyRelease | `ButtonPress
| `ButtonRelease
]
(* The event handlers that can be defined for spots *)
type spot
(* A spot is a rectangular region of the canvas with an event
* handler
*)
type t
(* A set of spots for a certain canvas *)
val attach : Widget.canvas Widget.widget -> t
(* Creates a set of spots and attaches it to the passed canvas.
* Event handlers for all supported_events are set.
*)
val add :
?events:supported_event list ->
?action:(supported_event -> Tk.eventInfo -> unit) ->
?tags:string list ->
t -> (* set of spots *)
Tk.tagOrId ->
(int * int * int * int) -> (* dimension *)
unit
(* Adds a spot to the set of spots. The dimension of the spot is
* specified by the quadruple (x0,y0,x1,y1) (as returned by the
* bbox functions of labltk). The spot must have at least one tag
* or ID for identification.
*
* ~tags: Additional tags
* ~events: The events for which the action function is called
* ~action: The action when an event happens
*
* Note that you cannot specify the event fields that are
* filled in the eventInfo record, because the module uses a fixed
* set of fields:
* - `State; `Time; `MouseX; `MouseY; `SendEvent; `RootWindow; `SubWindow;
* `Type; `Widget; `RootX; `RootY: always filled
* - `KeyCode; `KeySymString; `KeySymInt; `Char: for key events
* - `ButtonNumber: for button events
*)
val change_action :
?events:supported_event list ->
?action:(supported_event -> Tk.eventInfo -> unit) ->
t -> (* set of spots *)
Tk.tagOrId list ->
unit
(* Sets the event list and the action function for all spots that match
* the tagOrId criterion.
*)
val delete : t -> Tk.tagOrId list -> unit
(* Deletes all spots from the set that match the tagOrId criterion. *)
val move : t -> Tk.tagOrId list -> x:int -> y:int -> unit
(* Moves all spots by ~x pixels to the right and ~y pixels to the bottom
* that match the tagOrId criterion.
*)
val dimension : t -> Tk.tagOrId list -> (int * int * int * int)
(* Returns the dimension of the bounding box of the union of all spots
* that match the tagOrId criterion.
* This function will raise Not_found if no spot matches.
*)
(* ======================================================================
* History:
*
* $Log: lx_spots.mli,v $
* Revision 1.1 2002/06/08 19:36:37 gerd
* Initial revision.
*
*
*)
This diff is collapsed.
(* $Id: lx_tree.mli,v 1.1 2002/06/08 19:36:37 gerd Exp $
* ----------------------------------------------------------------------
*
*)
(* Lx_tree is a tree widget for labltk. It can visualize a tree structure,
* and you can open and close the branches of the tree. It is not necessary
* that the tree is completely known when you call the widget; the tree can
* be modified dynamically, and the visualization follows the changed
* structure.
*
* For every node, there may be an image (optional), and a single line
* of text. You can bind events to nodes (i.e. to the image and/or the
* text).
*
* Trees are drawn in canvas widgets.
*)
module Types : sig
(* The types are defined in a submodule so you can "open Lx_tree.Types" *)
type 'a tree =
{ mutable node : 'a;
mutable children : 'a tree list;
mutable scanned : bool;
mutable show : bool;
mutable interactive : bool;
}
(* The fundamental tree type. You can put everything into the component
* [node]. The [children] are the ordered descendants of the node.
* The flag [show] determines whether the children are displayed
* (i.e. an opened branch), or not. The flag [scanned] determines how
* a detail is displayed: When [children] is the empty list, this can
* be interpreted in two ways. First, it can mean that there are
* really no children ([scanned=true]). Second, it can mean that we
* have not yet looked at the children, and if we examine them, it might
* turn out that the tree can be continued at this point ([scanned=false]).
*
* Visualization:
*
* Case (1): show=true, children<>[]:
*
* [-] <node> ( "[-]" is a small box containing a minus sign)
* |
* +- <child1>
* ...
* +- <childN>
*
* Case (2): show=true, children=[]
*
* --- <node> (i.e. no small box)
*
* Case (3): show=false, children<>[]
*
* [+] <node> ( "[+]" is a small box containing a plus sign)
*
* Case (4): show=false, children=[], scanned=true
*
* --- <node> (i.e. no small box)
*
* Case (5): show=false, children=[], scanned=false
*
* [+] <node>
*
* If you click at one of the small boxes, the branch is opened ("[+]"),
* or closed ("[-]"). Without small box, you cannot click.
*
* Note that the topmost node is always displayed, and cannot be hidden.
*)
type 'a tree_widget
(* The displayed tree *)
type 'a display_item
(* Describes how a single node is displayed *)
end
open Types
val create : ?background : Tk.color ->
?foreground : Tk.color ->
?activebackground : Tk.color ->
?activeforeground : Tk.color ->
?display : ('a tree_widget -> 'a tree -> 'a display_item) ->
?rescan : ('a tree_widget -> 'a tree -> unit) ->
?width : int ->
?height : int ->
?font : string ->
'a tree ->
'b Widget.widget ->
'a tree_widget
(* Creates a new tree widget. The tree structure and the parent of the
* canvas must be passed to this function. All other arguments are optional.
*
* ~background, ~foreground: The color of the tree background, and the
* color of foreground drawings, respectively.
* ~activebackground, ~activeforeground: The colors to use when an element
* is highlighted because the mouse pointer is over the element
* ~display: This function is called before a node is drawn, and it determines
* what to draw in addition to the pure tree structure (which is drawn
* anyway). Note that this function is called by the [update] function
* for every shown node, and should be quite quick.
* ~rescan: This function is called before a branch is opened, and it can
* update the [children] list.
* ~width: The width of the tree widget. This value determines both the
* width of the screen window where the tree is displayed, and the logical
* width of the canvas. The logical width and the screen width are always
* the same value, and because of this, it does make sense to have a
* horizontal scrollbar for the tree widget. Items beyond the right edge
* are simply clipped.
* By default the width is 200 pixels.
* ~height: The screen height of the tree widget. This is only the height
* of the screen window where the tree is displayed. The logical height
* may a bigger value, and it is reasonable to have a vertical scrollbar
* to adjust the visible region of the tree.
* By default the height is 200 pixels.
* ~font: This is the default font for nodes that do not specify a different
* one.
* By default, the default font is "fixed".
*)
val configure : ?display : ('a tree_widget -> 'a tree -> 'a display_item) ->
?rescan : ('a tree_widget -> 'a tree -> unit) ->
?width : int ->
?height : int ->
?font : string ->
?tree : 'a tree ->
'a tree_widget ->
unit
(* Note that it is currently impossible to change the colors.
* [configure] does not imply [update].
*)
val update : 'a tree_widget -> unit
(* Updates the drawn tree such that it corresponds to the tree structure.
* If you change the tree, this module does not detect the changes until
* somebody calls explicitly [update]. Normally, these calls only happen when
* the user clicks at the small boxes that open and close branches. It
* might be necessary to invoke this function more often when further
* events are defined that change attributes of the tree.
*
* [update] checks for changed structure (when you modify the [children]
* component of a node), for changed flags, and it invokes the [display]
* function for every node to see whether the image or the text must be
* updated.
*)
val display_text : ?font : string ->
?foreground : Tk.color ->
?background : Tk.color ->
?outline : Tk.color ->
?image : Tk.image ->
?long : bool ->
?events : Lx_spots.supported_event list ->
?action : ('a tree_widget ->
'a tree ->
Lx_spots.supported_event ->
Tk.eventInfo ->
unit) ->
string ->
'a display_item
(* Determines how to display a single node. The string argument is the text
* to display at the node. The other properties are optional:
*
* ~font: The font used for the text. By default, the font of the tree widget
* is used.
* ~foreground: The foreground color for the text. By default, the foreground
* color of the tree widget is used.
* ~background: The background color for the text. By default, the background
* color of the tree widget is used. (See also ~long.)
* ~outline: The color of the border to draw around the text. By default,
* no such border is drawn.
* ~long: If [false], the text widget is only as long as needed. If [true],
* the text widget is expanded such that the right edge is near the right
* edge of the canvas. The difference between [false] and [true] is
* only visible if a background or outline color is defined.
* ~image: The image to display. By default, no image is displayed.
* ~events: The events that are bound for this node.
* ~action: The function to call as event handler.
*)
val canvas : 'a tree_widget -> Widget.canvas Widget.widget
(* Returns the canvas widget
*
* Note that the caller must PACK the canvas, othwerwise the whole tree
* is invisible.
*)
val tree : 'a tree_widget -> 'a tree
(* Returns the tree displayed by the widget *)
(* val parent : 'a tree_widget -> 'a tree -> 'a tree *)
(* val succ : 'a tree_widget -> 'a tree -> 'a tree *)
(* val pred : 'a tree_widget -> 'a tree -> 'a tree *)
(* How to connect to a scrollbar:
* If [tw] is the tree widget:
* let canvas = tw.canvas in
* let sbar = Scrollbar.create ~command:(Canvas.yview canvas)
* ~orient:`Vertical top in
* Canvas.configure ~yscrollcommand:(Scrollbar.set sbar) canvas;
*)
(* ======================================================================
* History:
*
* $Log: lx_tree.mli,v $
* Revision 1.1 2002/06/08 19:36:37 gerd
* Initial revision.
*
*
*)
#define minusbox_width 11
#define minusbox_height 11
static unsigned char minusbox_bits[] = {
0xff, 0x07, 0x01, 0x04, 0x01, 0x04, 0x01, 0x04, 0x01, 0x04, 0xfd, 0x05,
0x01, 0x04, 0x01, 0x04, 0x01, 0x04, 0x01, 0x04, 0xff, 0x07};
#define plusbox.xpm_width 11
#define plusbox.xpm_height 11
static unsigned char plusbox.xpm_bits[] = {
0xff, 0x07, 0x01, 0x04, 0x21, 0x04, 0x21, 0x04, 0x21, 0x04, 0xfd, 0x05,
0x21, 0x04, 0x21, 0x04, 0x21, 0x04, 0x01, 0x04, 0xff, 0x07};
open Widget
open Tk
open Lx_tree
let is_dir p =
(Unix.stat p).Unix.st_kind = Unix.S_DIR
;;
let rescan_dir tw t =
let (full_name,name) = t.node in
let d = Unix.opendir full_name in
let l = ref [] in
try
while true do
let e = Unix.readdir d in
if e <> "." && e <> ".." then
l := e :: !l
done; assert false
with
End_of_file ->
Unix.closedir d;
let new_list =
List.map
(fun e -> (Filename.concat full_name e, e))
(List.sort compare !l)
in
let old_list = List.map (fun n -> n.node) t.children in
if new_list <> old_list then
t.children <- List.map (fun (full_e,e) -> { node = (full_e,e);
children = [];
show = false;
scanned = not(is_dir full_e)
}
) new_list
;;
let ls_display tw (path,name) =
if is_dir path then
display ~long:true ~outline:`Black ~foreground:`White ~background:`Blue ~font:"-bitstream-monospace 821-medium-r-normal-*-*-320-*-*-m-*-iso8859-1" name
else
display ~events:[`ButtonPress; `Enter]
~action:(fun addr ev einfo ->
let node = lookup tw addr in
prerr_endline("Current: " ^ fst node.node)) name
;;
let top = openTk() in
let width = 400 in
let height = 800 in
let tw = create ~display:ls_display ~rescan:rescan_dir ~width ~height
~foreground:`Red
~background:`Yellow
(* ~font:"-bitstream-monospace 821-medium-r-normal-*-*-320-*-*-m-*-iso8859-1" *)
{ node = ("/", "/");
children = [];
show = false;
scanned = false;
}
top in
let canvas = canvas tw in
let sbar = Scrollbar.create ~command:(Canvas.yview canvas)
~orient:`Vertical top in
Canvas.configure ~yscrollcommand:(Scrollbar.set sbar) canvas;
pack ~side:`Left [canvas];
pack ~side:`Left ~fill:`Y [ sbar];
mainLoop();;
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment