diff options
| author | Xavier Clerc <xavier.clerc@inria.fr> | 2013-09-09 09:32:00 +0000 |
|---|---|---|
| committer | Xavier Clerc <xavier.clerc@inria.fr> | 2013-09-09 09:32:00 +0000 |
| commit | e82104a755463d481667650ba4f00de535048f39 (patch) | |
| tree | 054c7de9b2992be063de2dd22b56ee5993d5a374 /otherlibs/labltk/frx | |
| parent | 83ca86dd2309914aa458bc25fd265f0bcadaa337 (diff) | |
Remove labltk from the distribution (will be available as a third-party library).
git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@14077 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
Diffstat (limited to 'otherlibs/labltk/frx')
46 files changed, 0 insertions, 2132 deletions
diff --git a/otherlibs/labltk/frx/.depend b/otherlibs/labltk/frx/.depend deleted file mode 100644 index 9b27a76b0..000000000 --- a/otherlibs/labltk/frx/.depend +++ /dev/null @@ -1,38 +0,0 @@ -frx_after.cmo: frx_after.cmi -frx_after.cmx: frx_after.cmi -frx_color.cmo: frx_color.cmi -frx_color.cmx: frx_color.cmi -frx_ctext.cmo: frx_fit.cmi frx_text.cmi frx_ctext.cmi -frx_ctext.cmx: frx_fit.cmx frx_text.cmx frx_ctext.cmi -frx_dialog.cmo: frx_dialog.cmi -frx_dialog.cmx: frx_dialog.cmi -frx_entry.cmo: frx_entry.cmi -frx_entry.cmx: frx_entry.cmi -frx_fillbox.cmo: frx_fillbox.cmi -frx_fillbox.cmx: frx_fillbox.cmi -frx_fit.cmo: frx_after.cmi frx_fit.cmi -frx_fit.cmx: frx_after.cmx frx_fit.cmi -frx_focus.cmo: frx_focus.cmi -frx_focus.cmx: frx_focus.cmi -frx_font.cmo: frx_misc.cmi frx_font.cmi -frx_font.cmx: frx_misc.cmx frx_font.cmi -frx_lbutton.cmo: frx_lbutton.cmi -frx_lbutton.cmx: frx_lbutton.cmi -frx_listbox.cmo: frx_listbox.cmi -frx_listbox.cmx: frx_listbox.cmi -frx_mem.cmo: frx_mem.cmi -frx_mem.cmx: frx_mem.cmi -frx_misc.cmo: frx_misc.cmi -frx_misc.cmx: frx_misc.cmi -frx_req.cmo: frx_entry.cmi frx_listbox.cmi frx_widget.cmi frx_req.cmi -frx_req.cmx: frx_entry.cmx frx_listbox.cmx frx_widget.cmx frx_req.cmi -frx_rpc.cmo: frx_rpc.cmi -frx_rpc.cmx: frx_rpc.cmi -frx_selection.cmo: frx_selection.cmi -frx_selection.cmx: frx_selection.cmi -frx_synth.cmo: frx_synth.cmi -frx_synth.cmx: frx_synth.cmi -frx_text.cmo: frx_misc.cmi frx_text.cmi -frx_text.cmx: frx_misc.cmx frx_text.cmi -frx_widget.cmo: frx_widget.cmi -frx_widget.cmx: frx_widget.cmi diff --git a/otherlibs/labltk/frx/Makefile b/otherlibs/labltk/frx/Makefile deleted file mode 100644 index 581200b07..000000000 --- a/otherlibs/labltk/frx/Makefile +++ /dev/null @@ -1,67 +0,0 @@ -####################################################################### -# # -# MLTk, Tcl/Tk interface of OCaml # -# # -# Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis # -# projet Cristal, INRIA Rocquencourt # -# Jacques Garrigue, Kyoto University RIMS # -# # -# Copyright 2002 Institut National de Recherche en Informatique et # -# en Automatique and Kyoto University. All rights reserved. # -# This file is distributed under the terms of the GNU Library # -# General Public License, with the special exception on linking # -# described in file LICENSE found in the OCaml source tree. # -# # -####################################################################### - -include ../support/Makefile.common - -COMPFLAGS=-I ../camltk -I ../support - -OBJS= frx_misc.cmo frx_widget.cmo frx_font.cmo frx_entry.cmo frx_text.cmo \ - frx_listbox.cmo frx_req.cmo frx_fillbox.cmo frx_focus.cmo \ - frx_dialog.cmo frx_mem.cmo frx_rpc.cmo frx_synth.cmo frx_selection.cmo \ - frx_after.cmo frx_fit.cmo frx_ctext.cmo frx_color.cmo - -OBJSX = $(OBJS:.cmo=.cmx) - -all: frxlib.cma - -opt: frxlib.cmxa - -frxlib.cma: $(OBJS) - $(CAMLLIBR) -o frxlib.cma $(OBJS) - -frxlib.cmxa: $(OBJSX) - $(CAMLOPTLIBR) -o frxlib.cmxa $(OBJSX) - -install: - cp *.cmi *.mli frxlib.cma $(INSTALLDIR) - -installopt: - cp frxlib.cmxa frxlib.$(A) $(INSTALLDIR) - -clean: - rm -f *.cm* *.$(O) *.$(A) - -$(OBJS) $(OBJS:.cmo=.cmi): ../lib/$(LIBNAME).cma - -$(OBJSX): ../lib/$(LIBNAME).cmxa - -.SUFFIXES : -.SUFFIXES : .mli .ml .cmi .cmo .cmx - -.mli.cmi: - $(CAMLCOMP) $(COMPFLAGS) $< - -.ml.cmo: - $(CAMLCOMP) $(COMPFLAGS) $< - -.ml.cmx: - $(CAMLOPT) -c $(COMPFLAGS) $< - - -depend: - $(CAMLDEP) *.mli *.ml > .depend - -include .depend diff --git a/otherlibs/labltk/frx/Makefile.nt b/otherlibs/labltk/frx/Makefile.nt deleted file mode 100644 index 74203f039..000000000 --- a/otherlibs/labltk/frx/Makefile.nt +++ /dev/null @@ -1,17 +0,0 @@ -####################################################################### -# # -# MLTk, Tcl/Tk interface of OCaml # -# # -# Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis # -# projet Cristal, INRIA Rocquencourt # -# Jacques Garrigue, Kyoto University RIMS # -# # -# Copyright 2002 Institut National de Recherche en Informatique et # -# en Automatique and Kyoto University. All rights reserved. # -# This file is distributed under the terms of the GNU Library # -# General Public License, with the special exception on linking # -# described in file LICENSE found in the OCaml source tree. # -# # -####################################################################### - -include Makefile diff --git a/otherlibs/labltk/frx/README b/otherlibs/labltk/frx/README deleted file mode 100644 index 65e5dc4c2..000000000 --- a/otherlibs/labltk/frx/README +++ /dev/null @@ -1,2 +0,0 @@ -This is Francois Rouaix's widget set library, Frx. -It uses CamlTk API. diff --git a/otherlibs/labltk/frx/frx_after.ml b/otherlibs/labltk/frx/frx_after.ml deleted file mode 100644 index 1b7dfef8b..000000000 --- a/otherlibs/labltk/frx/frx_after.ml +++ /dev/null @@ -1,24 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -open Protocol -let idle f = - let id = new_function_id () in - let wrapped _ = - clear_callback id; (* do it first in case f raises exception *) - f() in - Hashtbl.add callback_naming_table id wrapped; - tkCommand [| TkToken "after"; TkToken "idle"; - TkToken ("camlcb "^ string_of_cbid id) |] diff --git a/otherlibs/labltk/frx/frx_after.mli b/otherlibs/labltk/frx/frx_after.mli deleted file mode 100644 index 45e30456c..000000000 --- a/otherlibs/labltk/frx/frx_after.mli +++ /dev/null @@ -1,17 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -val idle : (unit -> unit) -> unit - (* [idle f] is equivalent to Tk "after idle {camlcb f}" *) diff --git a/otherlibs/labltk/frx/frx_color.ml b/otherlibs/labltk/frx/frx_color.ml deleted file mode 100644 index e3e616a98..000000000 --- a/otherlibs/labltk/frx/frx_color.ml +++ /dev/null @@ -1,35 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -open Camltk -open Protocol - -module StringSet = Set.Make(struct type t = string let compare = compare end) - -(* should we keep a negative cache ? *) -let available_colors = ref (StringSet.empty) - -let check s = - if StringSet.mem s !available_colors then true - else begin - try - let f = Frame.create_named Widget.default_toplevel "frxcolorcheck" - [Background (NamedColor s)] in - available_colors := StringSet.add s !available_colors; - destroy f; - true - with - TkError _ -> false - end diff --git a/otherlibs/labltk/frx/frx_color.mli b/otherlibs/labltk/frx/frx_color.mli deleted file mode 100644 index b2791655a..000000000 --- a/otherlibs/labltk/frx/frx_color.mli +++ /dev/null @@ -1,16 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -val check : string -> bool diff --git a/otherlibs/labltk/frx/frx_ctext.ml b/otherlibs/labltk/frx/frx_ctext.ml deleted file mode 100644 index 498fe8ec7..000000000 --- a/otherlibs/labltk/frx/frx_ctext.ml +++ /dev/null @@ -1,66 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -(* A trick by Steve Ball to do pixel scrolling on text widgets *) -(* USES frx_fit *) -open Camltk - -let create top opts navigation = - let f = Frame.create top [BorderWidth (Pixels 2); Relief Raised] in - let lf = Frame.create f [] in - let rf = Frame.create f [] in - let c = Canvas.create lf [BorderWidth (Pixels 0)] - and xscroll = Scrollbar.create lf [Orient Horizontal] - and yscroll = Scrollbar.create rf [Orient Vertical] - and secret = Frame.create_named rf "secret" [] - in - let t = Text.create c (BorderWidth(Pixels 0) :: opts) in - if navigation then Frx_text.navigation_keys t; - - (* Make the text widget an embedded canvas object *) - ignore - (Canvas.create_window c (Pixels 0) (Pixels 0) - [Anchor NW; Window t; Tags [Tag "main"]]); - Canvas.focus c (Tag "main"); - (* - Canvas.configure c [Width (Pixels (Winfo.reqwidth t)); - Height(Pixels (Winfo.reqheight t))]; - *) - Canvas.configure c [YScrollCommand (Scrollbar.set yscroll)]; - (* The horizontal scrollbar is directly attached to the - * text widget, because h scrolling works properly *) - Scrollbar.configure xscroll [ScrollCommand (Text.xview t)]; - (* But vertical scroll is attached to the canvas *) - Scrollbar.configure yscroll [ScrollCommand (Canvas.yview c)]; - let scroll, check = Frx_fit.vert t in - Text.configure t [ - XScrollCommand (Scrollbar.set xscroll); - YScrollCommand (fun first last -> - scroll first last; - let x,y,w,h = Canvas.bbox c [Tag "main"] in - Canvas.configure c - [ScrollRegion (Pixels x, Pixels y, Pixels w, Pixels h)]) - ]; - - bind c [[],Configure] (BindSet ([Ev_Width], (fun ei -> - Canvas.configure_window c (Tag "main") [Width (Pixels ei.ev_Width)]))); - - pack [rf] [Side Side_Right; Fill Fill_Y]; - pack [lf] [Side Side_Left; Fill Fill_Both; Expand true]; - pack [secret] [Side Side_Bottom]; - pack [yscroll] [Side Side_Top; Fill Fill_Y; Expand true]; - pack [xscroll] [Side Side_Bottom; Fill Fill_X]; - pack [c] [Side Side_Left; Fill Fill_Both; Expand true]; - f, t diff --git a/otherlibs/labltk/frx/frx_ctext.mli b/otherlibs/labltk/frx/frx_ctext.mli deleted file mode 100644 index 2f696abea..000000000 --- a/otherlibs/labltk/frx/frx_ctext.mli +++ /dev/null @@ -1,23 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -open Camltk - -val create : - Widget.widget -> Camltk.options list -> bool -> Widget.widget * Widget.widget - (* [create parent opts nav_keys] creates a text widget - with "pixel scrolling". Based on a trick learned from Steve Ball. - Returns (frame widget, text widget). - *) diff --git a/otherlibs/labltk/frx/frx_dialog.ml b/otherlibs/labltk/frx/frx_dialog.ml deleted file mode 100644 index 096812dbc..000000000 --- a/otherlibs/labltk/frx/frx_dialog.ml +++ /dev/null @@ -1,115 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -open Camltk -open Protocol - -let rec mapi f n l = - match l with - [] -> [] - | x::l -> let v = f n x in v::(mapi f (succ n) l) - -(* Same as tk_dialog, but not sharing the tkwait variable *) -(* w IS the parent widget *) -let f w name title mesg bitmap def buttons = - let t = Toplevel.create_named w name [Class "Dialog"] in - Wm.title_set t title; - Wm.iconname_set t "Dialog"; - Wm.protocol_set t "WM_DELETE_WINDOW" (function () -> ()); - (* Wm.transient_set t (Winfo.toplevel w); *) - let ftop = - Frame.create_named t "top" [Relief Raised; BorderWidth (Pixels 1)] - and fbot = - Frame.create_named t "bot" [Relief Raised; BorderWidth (Pixels 1)] - in - pack [ftop][Side Side_Top; Fill Fill_Both]; - pack [fbot][Side Side_Bottom; Fill Fill_Both]; - - let l = - Label.create_named ftop "msg" - [Justify Justify_Left; Text mesg; WrapLength (Pixels 600)] in - pack [l][Side Side_Right; Expand true; Fill Fill_Both; - PadX (Millimeters 3.0); PadY (Millimeters 3.0)]; - begin match bitmap with - Predefined "" -> () - | _ -> - let b = - Label.create_named ftop "bitmap" [Bitmap bitmap] in - pack [b][Side Side_Left; PadX (Millimeters 3.0); PadY (Millimeters 3.0)] - end; - - let waitv = Textvariable.create_temporary t in - - let buttons = - mapi (fun i bname -> - let b = Button.create t - [Text bname; - Command (fun () -> Textvariable.set waitv (string_of_int i))] in - if i = def then begin - let f = Frame.create_named fbot "default" - [Relief Sunken; BorderWidth (Pixels 1)] in - raise_window_above b f; - pack [f][Side Side_Left; Expand true; - PadX (Millimeters 3.0); PadY (Millimeters 2.0)]; - pack [b][In f; PadX (Millimeters 2.0); PadY (Millimeters 2.0)]; - bind t [[], KeyPressDetail "Return"] - (BindSet ([], (fun _ -> Button.flash b; Button.invoke b))) - end - else - pack [b][In fbot; Side Side_Left; Expand true; - PadX (Millimeters 3.0); PadY (Millimeters 2.0)]; - b - ) - 0 buttons in - - Wm.withdraw t; - update_idletasks(); - let x = (Winfo.screenwidth t)/2 - (Winfo.reqwidth t)/2 - - (Winfo.vrootx (Winfo.parent t)) - and y = (Winfo.screenheight t)/2 - (Winfo.reqheight t)/2 - - (Winfo.vrooty (Winfo.parent t)) in - Wm.geometry_set t (Printf.sprintf "+%d+%d" x y); - Wm.deiconify t; - - let oldfocus = try Some (Focus.get()) with _ -> None - and oldgrab = Grab.current ~displayof: t () - and grabstatus = ref None in - begin match oldgrab with - [] -> () - | x::l -> grabstatus := Some(Grab.status x) - end; - - (* avoid errors here because it makes the entire app useless *) - (try Grab.set t with TkError _ -> ()); - Tkwait.visibility t; - Focus.set (if def >= 0 then List.nth buttons def else t); - - Tkwait.variable waitv; - begin match oldfocus with - None -> () - | Some w -> try Focus.set w with _ -> () - end; - destroy t; - begin match oldgrab with - [] -> () - | x::l -> - try - match !grabstatus with - Some(GrabGlobal) -> Grab.set_global x - | _ -> Grab.set x - with TkError _ -> () - end; - - int_of_string (Textvariable.get waitv) diff --git a/otherlibs/labltk/frx/frx_dialog.mli b/otherlibs/labltk/frx/frx_dialog.mli deleted file mode 100644 index fd816d34c..000000000 --- a/otherlibs/labltk/frx/frx_dialog.mli +++ /dev/null @@ -1,22 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -open Camltk -val f : - Widget.widget -> - string -> string -> string -> Camltk.bitmap -> int -> string list -> int - (* same as Dialog.create_named, but with a local variable for - synchronisation. Makes it possible to have several dialogs - simultaneously *) diff --git a/otherlibs/labltk/frx/frx_entry.ml b/otherlibs/labltk/frx/frx_entry.ml deleted file mode 100644 index 0b7c339a0..000000000 --- a/otherlibs/labltk/frx/frx_entry.ml +++ /dev/null @@ -1,40 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -open Camltk - -let version = "$Id$" - -(* - * Tk 4.0 has emacs bindings for entry widgets - *) - -let new_label_entry parent txt action = - let f = Frame.create parent [] in - let m = Label.create f [Text txt] - and e = Entry.create f [Relief Sunken; TextWidth 0] in - Camltk.bind e [[], KeyPressDetail "Return"] - (BindSet ([], fun _ -> action(Entry.get e))); - pack [m][Side Side_Left]; - pack [e][Side Side_Right; Fill Fill_X; Expand true]; - f,e - -let new_labelm_entry parent txt memo = - let f = Frame.create parent [] in - let m = Label.create f [Text txt] - and e = Entry.create f [Relief Sunken; TextVariable memo; TextWidth 0] in - pack [m][Side Side_Left]; - pack [e][Side Side_Right; Fill Fill_X; Expand true]; - f,e diff --git a/otherlibs/labltk/frx/frx_entry.mli b/otherlibs/labltk/frx/frx_entry.mli deleted file mode 100644 index 0b09f16d3..000000000 --- a/otherlibs/labltk/frx/frx_entry.mli +++ /dev/null @@ -1,31 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -open Camltk -val new_label_entry : - Widget.widget -> - string -> (string -> unit) -> Widget.widget * Widget.widget - (* [new_label_entry parent label action] - creates a "labelled" entry widget where [action] will be invoked - when the user types Return in the widget. - Returns (frame widget, entry widget) - *) -val new_labelm_entry : - Widget.widget -> - string -> Textvariable.textVariable -> Widget.widget * Widget.widget - (* [new_labelm_entry parent label variable] - creates a "labelled" entry widget whose contents is [variable]. - Returns (frame widget, entry widget) - *) diff --git a/otherlibs/labltk/frx/frx_fileinput.ml b/otherlibs/labltk/frx/frx_fileinput.ml deleted file mode 100644 index dfba7a0f8..000000000 --- a/otherlibs/labltk/frx/frx_fileinput.ml +++ /dev/null @@ -1,39 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -open Camltk - -let version = "$Id$" - -(* - * Simple spooling for fileinput callbacks - *) - -let waiting_list = Queue. new() -and waiting = ref 0 -and max_open = ref 10 -and cur_open = ref 0 - -let add fd f = - if !cur_open < !max_open then begin - incr cur_open; - add_fileinput fd f - end - else begin - incr waiting; - Queue.add (fd,f) waiting_list - end - -let remove fd = diff --git a/otherlibs/labltk/frx/frx_fillbox.ml b/otherlibs/labltk/frx/frx_fillbox.ml deleted file mode 100644 index 143bea4a2..000000000 --- a/otherlibs/labltk/frx/frx_fillbox.ml +++ /dev/null @@ -1,65 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -open Camltk - -(* - * Progress indicators - *) -let okcolor = NamedColor "#3cb371" -and kocolor = NamedColor "#dc5c5c" - - -let new_vertical parent w h = - let c = Canvas.create_named parent "fillbox" - [Width (Pixels w); Height (Pixels h); BorderWidth (Pixels 1); - Relief Sunken] - in - let i = Canvas.create_rectangle c (Pixels 0) (Pixels 0) (Pixels w) (Pixels 0) - [FillColor okcolor; Outline okcolor] - in - c, (function - 0 -> Canvas.configure_rectangle c i [FillColor okcolor; - Outline okcolor]; - Canvas.coords_set c i [Pixels 0; Pixels 0; - Pixels w; Pixels 0] - | -1 -> Canvas.configure_rectangle c i [FillColor kocolor; - Outline kocolor] - | n -> - let percent = if n > 100 then 100 else n in - let hf = percent*h/100 in - Canvas.coords_set c i [Pixels 0; Pixels 0; - Pixels w; Pixels hf]) - -let new_horizontal parent w h = - let c = Canvas.create_named parent "fillbox" - [Width (Pixels w); Height (Pixels h); BorderWidth (Pixels 1); - Relief Sunken] - in - let i = Canvas.create_rectangle c (Pixels 0) (Pixels 0) (Pixels 0) (Pixels h) - [FillColor okcolor; Outline okcolor] - in - c, (function - 0 -> Canvas.configure_rectangle c i [FillColor okcolor; - Outline okcolor]; - Canvas.coords_set c i [Pixels 0; Pixels 0; - Pixels 0; Pixels h] - | -1 -> Canvas.configure_rectangle c i [FillColor kocolor; - Outline kocolor] - | n -> - let percent = if n > 100 then 100 else n in - let wf = percent*w/100 in - Canvas.coords_set c i [Pixels 0; Pixels 0; - Pixels wf; Pixels h]) diff --git a/otherlibs/labltk/frx/frx_fillbox.mli b/otherlibs/labltk/frx/frx_fillbox.mli deleted file mode 100644 index 9cfc9e780..000000000 --- a/otherlibs/labltk/frx/frx_fillbox.mli +++ /dev/null @@ -1,31 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -open Camltk - -val new_vertical : - Widget.widget -> int -> int -> Widget.widget * (int -> unit) - (* [new_vertical parent width height] - creates a vertical fillbox of [width] and [height]. - Returns a frame widget and a function to set the current value of - the fillbox. The value can be - n < 0 : the fillbox changes color (reddish) - 0 <= n <= 100: the fillbox fills up to n percent - 100 <= n : the fillbox fills up to 95% - *) - -val new_horizontal : - Widget.widget -> int -> int -> Widget.widget * (int -> unit) - (* save as above, except the widget is horizontal *) diff --git a/otherlibs/labltk/frx/frx_fit.ml b/otherlibs/labltk/frx/frx_fit.ml deleted file mode 100644 index bcfd457a2..000000000 --- a/otherlibs/labltk/frx/frx_fit.ml +++ /dev/null @@ -1,83 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -open Camltk - -let debug = ref false - -let vert wid = - let newsize = ref 0 - and pending_resize = ref false - and last_last = ref 0.0 in - let rec resize () = - pending_resize := false; - if !debug then - (Printf.eprintf "%s Resize %d\n" - (Widget.name wid) !newsize; flush stderr); - Text.configure wid [TextHeight !newsize]; - () - and check () = - let first, last = Text.yview_get wid in - check1 first last - - and check1 first last = - let curheight = int_of_string (cget wid CHeight) in - if !debug then begin - Printf.eprintf "%s C %d %f %f\n" - (Widget.name wid) curheight first last; - flush stderr - end; - if first = 0.0 && last = 1.0 then () - (* Don't attempt anything if widget is not visible *) - else if not (Winfo.viewable wid) then begin - if !debug then - (Printf.eprintf "%s C notviewable\n" (Widget.name wid); - flush stderr); - (* Try again later *) - bind wid [[], Expose] (BindSet ([], fun _ -> - bind wid [[], Expose] BindRemove; - check())) - end - else begin - let delta = - if last = 0.0 then 1 - else if last = !last_last then - (* it didn't change since our last resize ! *) - 1 - else begin - last_last := last; - (* never to more than double *) - let visible = max 0.5 (last -. first) in - max 1 (truncate (float curheight *. (1. -. visible))) - end in - newsize := max (curheight + delta) !newsize; - if !debug then - (Printf.eprintf "%s newsize: %d\n" (Widget.name wid) !newsize; - flush stderr); - if !pending_resize then () - else begin - pending_resize := true; - Timer.set 300 (fun () -> Frx_after.idle resize) - end - end - - and scroll first last = - if !debug then - (Printf.eprintf "%s V %f %f\n" (Widget.name wid) first last; - flush stderr); - if first = 0.0 && last = 1.0 then () - else check1 first last - in - scroll, check diff --git a/otherlibs/labltk/frx/frx_fit.mli b/otherlibs/labltk/frx/frx_fit.mli deleted file mode 100644 index e61496455..000000000 --- a/otherlibs/labltk/frx/frx_fit.mli +++ /dev/null @@ -1,29 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -open Camltk -open Widget - -val debug: bool ref -val vert: widget -> (float -> float -> unit) * (unit -> unit) - -(* [vert widget] - can be applied to a text widget so that it expands to show its full - contents. Returns [scroll] and [check]. [scroll] must be used as - the YScrollCommand of the widget. [check] can be called when some - modification occurs in the content of the widget (such as a size change - in some embedded windows. - This feature is a terrible hack and should be used with extreme caution. - *) diff --git a/otherlibs/labltk/frx/frx_focus.ml b/otherlibs/labltk/frx/frx_focus.ml deleted file mode 100644 index 29eba574d..000000000 --- a/otherlibs/labltk/frx/frx_focus.ml +++ /dev/null @@ -1,26 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -open Camltk - -(* Temporary focus *) - -(* ? use bind tag ? how about the global reference then *) -let auto w = - let old_focus = ref w in - bind w [[],Enter] - (BindSet([], fun _ -> old_focus := Focus.get (); Focus.set w)); - bind w [[],Leave] - (BindSet([], fun _ -> Focus.set !old_focus)) diff --git a/otherlibs/labltk/frx/frx_focus.mli b/otherlibs/labltk/frx/frx_focus.mli deleted file mode 100644 index dcb9317f8..000000000 --- a/otherlibs/labltk/frx/frx_focus.mli +++ /dev/null @@ -1,18 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -open Camltk -val auto : Widget.widget -> unit - (* *) diff --git a/otherlibs/labltk/frx/frx_font.ml b/otherlibs/labltk/frx/frx_font.ml deleted file mode 100644 index 4acb59979..000000000 --- a/otherlibs/labltk/frx/frx_font.ml +++ /dev/null @@ -1,50 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -open Camltk -open Widget - -let version = "$Id$" - -(* - * Finding fonts. Inspired by code in Ical by Sanjay Ghemawat. - * Possibly bogus because some families use "i" for italic where others - * use "o". - * wght: bold, medium - * slant: i, o, r - * pxlsz: 8, 10, ... -*) -module StringSet = Set.Make(struct type t = string let compare = compare end) - -let available_fonts = ref (StringSet.empty) - -let get_canvas = - Frx_misc.autodef (fun () -> Canvas.create Widget.default_toplevel []) - - -let find fmly wght slant pxlsz = - let fontspec = - "-*-"^fmly^"-"^wght^"-"^slant^"-normal-*-"^string_of_int pxlsz^"-*-*-*-*-*-iso8859-1" in - if StringSet.mem fontspec !available_fonts then fontspec - else - let c = get_canvas() in - try - let tag = Canvas.create_text c (Pixels 0) (Pixels 0) - [Text "foo"; Font fontspec] in - Canvas.delete c [tag]; - available_fonts := StringSet.add fontspec !available_fonts; - fontspec - with - _ -> raise (Invalid_argument fontspec) diff --git a/otherlibs/labltk/frx/frx_font.mli b/otherlibs/labltk/frx/frx_font.mli deleted file mode 100644 index 4ed235f4c..000000000 --- a/otherlibs/labltk/frx/frx_font.mli +++ /dev/null @@ -1,20 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -val find : string -> string -> string -> int -> string - (* [find family weight slant pxlsz] returns the X11 full name of - the font required font, if available. - Raises Invalid_argument fullname otherwise. - *) diff --git a/otherlibs/labltk/frx/frx_group.ml b/otherlibs/labltk/frx/frx_group.ml deleted file mode 100644 index 1adc2d880..000000000 --- a/otherlibs/labltk/frx/frx_group.ml +++ /dev/null @@ -1,22 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -open Camltk - -let vgroup top l = - let f = Frame.create top [] in - Pack.forget l; - Pack.configure l [In f]; - f diff --git a/otherlibs/labltk/frx/frx_lbutton.ml b/otherlibs/labltk/frx/frx_lbutton.ml deleted file mode 100644 index 82ea8a8cc..000000000 --- a/otherlibs/labltk/frx/frx_lbutton.ml +++ /dev/null @@ -1,50 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -open Camltk - -open Widget - - -let version = "$Id$" - -(* - * Simulate a button with a bitmap AND a label - *) - -let rec sort_options but lab com = function - [] -> but,lab,com - |(Command f as o)::l -> sort_options (o::but) lab com l - |(Bitmap b as o)::l -> sort_options (o::but) lab com l - |(Text t as o)::l -> sort_options but (o::lab) com l - |o::l -> sort_options but lab (o::com) l - -let create parent options = - let but,lab,com = sort_options [] [] [] options in - let f = Frame.create parent com in - let b = Button.create f (but@com) - and l = Label.create f (lab@com) in - pack [b;l][]; - bind l [[],ButtonPressDetail 1] (BindSet ([],(function _ -> Button.invoke b))); - f - -let configure f options = - let but,lab,com = sort_options [] [] [] options in - match Pack.slaves f with - [b;l] -> - Frame.configure f com; - Button.configure b (but@com); - Label.configure l (lab@com) - | _ -> raise (Invalid_argument "lbutton configure") diff --git a/otherlibs/labltk/frx/frx_lbutton.mli b/otherlibs/labltk/frx/frx_lbutton.mli deleted file mode 100644 index 5522e5c24..000000000 --- a/otherlibs/labltk/frx/frx_lbutton.mli +++ /dev/null @@ -1,23 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -open Widget -open Camltk - - -val version : string - -val create : Widget -> option list -> Widget -and configure : Widget -> option list -> unit diff --git a/otherlibs/labltk/frx/frx_listbox.ml b/otherlibs/labltk/frx/frx_listbox.ml deleted file mode 100644 index 6d04262b6..000000000 --- a/otherlibs/labltk/frx/frx_listbox.ml +++ /dev/null @@ -1,92 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -open Camltk - -let version = "$Id$" - -(* - * Link a scrollbar and a listbox - *) -let scroll_link sb lb = - Listbox.configure lb - [YScrollCommand (Scrollbar.set sb)]; - Scrollbar.configure sb - [ScrollCommand (Listbox.yview lb)] - -(* - * Completion for listboxes, Macintosh style. - * As long as you type fast enough, the listbox is repositioned to the - * first entry "greater" than the typed prefix. - * assumes: - * sorted list (otherwise it's stupid) - * fixed size, because we don't recompute size at each callback invocation - *) - -let add_completion lb action = - let prefx = ref "" (* current match prefix *) - and maxi = Listbox.size lb - 1 (* maximum index (doesn't matter actually) *) - and current = ref 0 (* current position *) - and lastevent = ref 0 in - - let rec move_forward () = - if Listbox.get lb (Number !current) < !prefx then - if !current < maxi then begin incr current; move_forward() end - - and recenter () = - let element = Number !current in - (* Clean the selection *) - Listbox.selection_clear lb (Number 0) End; - (* Set it to our unique element *) - Listbox.selection_set lb element element; - (* Activate it, to keep consistent with Up/Down. - You have to be in Extended or Browse mode *) - Listbox.activate lb element; - Listbox.selection_anchor lb element; - Listbox.see lb element in - - let complete time s = - if time - !lastevent < 500 then (* sorry, hard coded limit *) - prefx := !prefx ^ s - else begin (* reset *) - current := 0; - prefx := s - end; - lastevent := time; - move_forward(); - recenter() in - - - bind lb [[], KeyPress] - (BindSet([Ev_Char; Ev_Time], - (function ev -> - (* consider only keys producing characters. The callback is called - * even if you press Shift. - *) - if ev.ev_Char <> "" then complete ev.ev_Time ev.ev_Char))); - (* Key specific bindings override KeyPress *) - bind lb [[], KeyPressDetail "Return"] (BindSet([], action)); - (* Finally, we have to set focus, otherwise events dont get through *) - Focus.set lb; - recenter() (* so that first item is selected *) - -let new_scrollable_listbox top options = - let f = Frame.create top [] in - let lb = Listbox.create f options - and sb = Scrollbar.create f [] in - scroll_link sb lb; - pack [lb] [Side Side_Left; Fill Fill_Both; Expand true]; - pack [sb] [Side Side_Left; Fill Fill_Y]; - f, lb diff --git a/otherlibs/labltk/frx/frx_listbox.mli b/otherlibs/labltk/frx/frx_listbox.mli deleted file mode 100644 index 54e7ec6a7..000000000 --- a/otherlibs/labltk/frx/frx_listbox.mli +++ /dev/null @@ -1,32 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -open Camltk -val scroll_link : Widget.widget -> Widget.widget -> unit - (* [scroll_link scrollbar listbox] links [scrollbar] and [listbox] - as expected. - *) - -val add_completion : Widget.widget -> (eventInfo -> unit) -> unit - (* [add_completion listbox action] adds Macintosh like electric navigation - in the listbox when characters are typed in. - [action] is invoked if Return is pressed - *) - -val new_scrollable_listbox : - Widget.widget -> options list -> Widget.widget * Widget.widget - (* [new_scrollable_listbox parent options] makes a scrollable listbox and - returns (frame, listbox) - *) diff --git a/otherlibs/labltk/frx/frx_mem.ml b/otherlibs/labltk/frx/frx_mem.ml deleted file mode 100644 index 6df0da75f..000000000 --- a/otherlibs/labltk/frx/frx_mem.ml +++ /dev/null @@ -1,89 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -(* Memory gauge *) -open Camltk -open Gc - -let inited = ref None -let w = ref 300 -let delay = ref 5 (* in seconds *) -let wordsize = (* officially approved *) - if 1 lsl 31 = 0 then 4 else 8 - - -let init () = - let top = Toplevel.create Widget.default_toplevel [Class "CamlGC"] in - let name = Camltk.appname_get () in - Wm.title_set top (name ^ " Memory Gauge"); - Wm.withdraw top; - inited := Some top; - (* this should be executed before the internal "all" binding *) - bind top [[], Destroy] (BindSet ([], (fun _ -> inited := None))); - let fminors = Frame.create top [] in - let lminors = Label.create fminors [Text "Minor collections"] - and vminors = Label.create fminors [] in - pack [lminors][Side Side_Left]; - pack [vminors][Side Side_Right; Fill Fill_X; Expand true]; - let fmajors = Frame.create top [] in - let lmajors = Label.create fmajors [Text "Major collections"] - and vmajors = Label.create fmajors [] in - pack [lmajors][Side Side_Left]; - pack [vmajors][Side Side_Right; Fill Fill_X; Expand true]; - let fcompacts = Frame.create top [] in - let lcompacts = Label.create fcompacts [Text "Compactions"] - and vcompacts = Label.create fcompacts [] in - pack [lcompacts][Side Side_Left]; - pack [vcompacts][Side Side_Right; Fill Fill_X; Expand true]; - let fsize = Frame.create top [] in - let lsize = Label.create fsize [Text "Heap size (bytes)"] - and vsize = Label.create fsize [] in - pack [lsize][Side Side_Left]; - pack [vsize][Side Side_Right; Fill Fill_X; Expand true]; - let fheap = Frame.create top [Width (Pixels !w); Height (Pixels 10)] in - let flive = Frame.create fheap [Background Red] - and ffree = Frame.create fheap [Background Green] - and fdead = Frame.create fheap [Background Black] in - pack [fminors; fmajors; fcompacts; fsize; fheap][Fill Fill_X]; - - let display () = - let st = Gc.stat() in - Label.configure vminors [Text (string_of_int st.minor_collections)]; - Label.configure vmajors [Text (string_of_int st.major_collections)]; - Label.configure vcompacts [Text (string_of_int st.compactions)]; - Label.configure vsize [Text (string_of_int (wordsize * st.heap_words))]; - let liver = (float st.live_words) /. (float st.heap_words) - and freer = (float st.free_words) /. (float st.heap_words) in - Place.configure flive [X (Pixels 0); Y (Pixels 0); - RelWidth liver; RelHeight 1.0]; - Place.configure ffree [RelX liver; Y (Pixels 0); - RelWidth freer; RelHeight 1.0]; - Place.configure fdead [RelX (liver +. freer); Y (Pixels 0); - RelWidth (1.0 -. freer -. liver); RelHeight 1.0] - - in - let rec tim () = - if Winfo.exists top then begin - display(); - Timer.set (!delay * 1000) tim - end - in - tim() - - -let rec f () = - match !inited with - Some w -> Wm.deiconify w - | None -> init (); f() diff --git a/otherlibs/labltk/frx/frx_mem.mli b/otherlibs/labltk/frx/frx_mem.mli deleted file mode 100644 index 190297b5e..000000000 --- a/otherlibs/labltk/frx/frx_mem.mli +++ /dev/null @@ -1,22 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -(* A Garbage Collector Gauge for OCaml *) - -val init : unit -> unit - (* [init ()] creates the gauge and its updater, but keeps it iconified *) - -val f : unit -> unit - (* [f ()] makes the gauge visible if it has not been destroyed *) diff --git a/otherlibs/labltk/frx/frx_misc.ml b/otherlibs/labltk/frx/frx_misc.ml deleted file mode 100644 index e45c5f0f0..000000000 --- a/otherlibs/labltk/frx/frx_misc.ml +++ /dev/null @@ -1,69 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -(* Delayed global, a.k.a cache&carry *) -let autodef f = - let v = ref None in - (function () -> - match !v with - None -> - let x = f() in - v := Some x; - x - | Some x -> x) - -open Camltk - -(* allows Data in options *) -let create_photo options = - let hasopt = ref None in - (* Check options *) - List.iter (function - Data s -> - begin match !hasopt with - None -> hasopt := Some (Data s) - | Some _ -> raise (Protocol.TkError "two data sources in options") - end - | File f -> - begin match !hasopt with - None -> hasopt := Some (File f) - | Some _ -> raise (Protocol.TkError "two data sources in options") - end - | o -> ()) - options; - match !hasopt with - None -> raise (Protocol.TkError "no data source in options") - | Some (Data s) -> - begin - let tmpfile = Filename.temp_file "img" "" in - let oc = open_out_bin tmpfile in - output_string oc s; - close_out oc; - let newopts = - List.map (function - | Data s -> File tmpfile - | o -> o) - options in - try - let i = Imagephoto.create newopts in - (try Sys.remove tmpfile with Sys_error _ -> ()); - i - with - e -> - (try Sys.remove tmpfile with Sys_error _ -> ()); - raise e - end - | Some (File s) -> Imagephoto.create options - | _ -> assert false diff --git a/otherlibs/labltk/frx/frx_misc.mli b/otherlibs/labltk/frx/frx_misc.mli deleted file mode 100644 index cd3d589fa..000000000 --- a/otherlibs/labltk/frx/frx_misc.mli +++ /dev/null @@ -1,21 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -open Camltk -val autodef : (unit -> 'a) -> (unit -> 'a) - (* [autodef make] is a pleasant wrapper around 'a option ref *) - -val create_photo : Camltk.options list -> Camltk.imagePhoto - (* [create_photo options] allows Data in options (by saving to tmp file) *) diff --git a/otherlibs/labltk/frx/frx_req.ml b/otherlibs/labltk/frx/frx_req.ml deleted file mode 100644 index 41590c145..000000000 --- a/otherlibs/labltk/frx/frx_req.ml +++ /dev/null @@ -1,198 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -open Camltk - -(* - * Some standard requesters (in Amiga techspeak) or dialog boxes (in Apple - * jargon). -*) - -let version = "$Id$" - -(* - * Simple requester - * an entry field, unrestricted, with emacs-like bindings - * Note: grabs focus, thus always unique at one given moment, and we - * shouldn't have to worry about toplevel widget name. - * We add a title widget in case the window manager does not decorate - * toplevel windows. -*) - -let open_simple title action notaction memory = - let t = Toplevel.create Widget.default_toplevel [Class "Dialog"] in - Focus.set t; - Wm.title_set t title; - let tit = Label.create t [Text title] in - let len = max 40 (String.length (Textvariable.get memory)) in - let e = - Entry.create t [Relief Sunken; TextVariable memory; TextWidth len] in - - let activate _ = - let v = Entry.get e in - Grab.release t; (* because of wm *) - destroy t; (* so action can call open_simple *) - action v in - - bind e [[], KeyPressDetail "Return"] (BindSet ([], activate)); - - let f = Frame.create t [] in - let bok = Button.create f [Text "Ok"; Command activate] in - let bcancel = Button.create f - [Text "Cancel"; - Command (fun () -> notaction(); Grab.release t; destroy t)] in - - bind e [[], KeyPressDetail "Escape"] - (BindSet ([], (fun _ -> Button.invoke bcancel))); - pack [bok] [Side Side_Left; Expand true]; - pack [bcancel] [Side Side_Right; Expand true]; - pack [tit;e] [Fill Fill_X]; - pack [f] [Side Side_Bottom; Fill Fill_X]; - Frx_widget.resizeable t; - Focus.set e; - Tkwait.visibility t; - Grab.set t - -(* A synchronous version *) -let open_simple_synchronous title memory = - let t = Toplevel.create Widget.default_toplevel [Class "Dialog"] in - Focus.set t; - Wm.title_set t title; - let tit = Label.create t [Text title] in - let len = max 40 (String.length (Textvariable.get memory)) in - let e = - Entry.create t [Relief Sunken; TextVariable memory; TextWidth len] in - - let waiting = Textvariable.create_temporary t in - - let activate _ = - Grab.release t; (* because of wm *) - destroy t; (* so action can call open_simple *) - Textvariable.set waiting "1" in - - bind e [[], KeyPressDetail "Return"] (BindSet ([], activate)); - - let f = Frame.create t [] in - let bok = Button.create f [Text "Ok"; Command activate] in - let bcancel = - Button.create f - [Text "Cancel"; - Command (fun () -> - Grab.release t; destroy t; Textvariable.set waiting "0")] in - - bind e [[], KeyPressDetail "Escape"] - (BindSet ([], (fun _ -> Button.invoke bcancel))); - pack [bok] [Side Side_Left; Expand true]; - pack [bcancel] [Side Side_Right; Expand true]; - pack [tit;e] [Fill Fill_X]; - pack [f] [Side Side_Bottom; Fill Fill_X]; - Frx_widget.resizeable t; - Focus.set e; - Tkwait.visibility t; - Grab.set t; - Tkwait.variable waiting; - begin match Textvariable.get waiting with - "1" -> true - | _ -> false - end - -(* - * Simple list requester - * Same remarks as in open_simple. - * focus seems to be in the listbox automatically - *) -let open_list title elements action notaction = - let t = Toplevel.create Widget.default_toplevel [Class "Dialog"] in - Wm.title_set t title; - - let tit = Label.create t [Text title] in - let fls = Frame.create t [Relief Sunken; BorderWidth (Pixels 2)] in - let lb = Listbox.create fls [SelectMode Extended] in - let sb = Scrollbar.create fls [] in - Frx_listbox.scroll_link sb lb; - Listbox.insert lb End elements; - - (* activation: we have to break() because we destroy the requester *) - let activate _ = - let l = List.map (Listbox.get lb) (Listbox.curselection lb) in - Grab.release t; - destroy t; - List.iter action l; - break() in - - - bind lb [[Double], ButtonPressDetail 1] (BindSetBreakable ([], activate)); - - Frx_listbox.add_completion lb activate; - - let f = Frame.create t [] in - let bok = Button.create f [Text "Ok"; Command activate] in - let bcancel = Button.create f - [Text "Cancel"; - Command (fun () -> notaction(); Grab.release t; destroy t)] in - - pack [bok; bcancel] [Side Side_Left; Fill Fill_X; Expand true]; - pack [lb] [Side Side_Left; Fill Fill_Both; Expand true]; - pack [sb] [Side Side_Right; Fill Fill_Y]; - pack [tit] [Fill Fill_X]; - pack [fls] [Fill Fill_Both; Expand true]; - pack [f] [Side Side_Bottom; Fill Fill_X]; - Frx_widget.resizeable t; - Tkwait.visibility t; - Grab.set t - - -(* Synchronous *) -let open_passwd title = - let username = ref "" - and password = ref "" - and cancelled = ref false in - let t = Toplevel.create Widget.default_toplevel [Class "Dialog"] in - Focus.set t; - Wm.title_set t title; - let tit = Label.create t [Text title] - and fu,eu = Frx_entry.new_label_entry t "Username" (fun s -> ()) - and fp,ep = Frx_entry.new_label_entry t "Password" (fun s -> ()) - in - let fb = Frame.create t [] in - let bok = Button.create fb - [Text "Ok"; Command (fun _ -> - username := Entry.get eu; - password := Entry.get ep; - Grab.release t; (* because of wm *) - destroy t)] (* will return from tkwait *) - and bcancel = Button.create fb - [Text "Cancel"; Command (fun _ -> - cancelled := true; - Grab.release t; (* because of wm *) - destroy t)] (* will return from tkwait *) - in - Entry.configure ep [Show '*']; - bind eu [[], KeyPressDetail "Return"] - (BindSetBreakable ([], (fun _ -> Focus.set ep; break()))); - bind ep [[], KeyPressDetail "Return"] - (BindSetBreakable ([], (fun _ -> Button.flash bok; - Button.invoke bok; - break()))); - - pack [bok] [Side Side_Left; Expand true]; - pack [bcancel] [Side Side_Right; Expand true]; - pack [tit;fu;fp;fb] [Fill Fill_X]; - Tkwait.visibility t; - Focus.set eu; - Grab.set t; - Tkwait.window t; - if !cancelled then failwith "cancelled" - else (!username, !password) diff --git a/otherlibs/labltk/frx/frx_req.mli b/otherlibs/labltk/frx/frx_req.mli deleted file mode 100644 index 62985b9f9..000000000 --- a/otherlibs/labltk/frx/frx_req.mli +++ /dev/null @@ -1,43 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -(* Various dialog boxes *) -val open_simple : - string -> - (string -> unit) -> (unit -> 'a) -> Textvariable.textVariable -> unit - (* [open_simple title action cancelled memory] - A dialog with a message and an entry field (with memory between - invocations). Either [action] or [cancelled] is called when the user - answers to the dialog (with Ok or Cancel) - *) - -val open_simple_synchronous : string -> Textvariable.textVariable -> bool - (* [open_simple_synchronous title memory] - A synchronous dialog with a message and an entry field (with - memory between invocations). Returns true if the user clicks Ok - or false if the user clicks Cancel. - *) -val open_list : - string -> string list -> (string -> unit) -> (unit -> unit) -> unit - (* [open_list title elements action cancelled] - A dialog for selecting from a list of elements. [action] is called - on each selected element, or [cancelled] is called if the user clicks - Cancel. - *) - -val open_passwd : string -> string * string - (* [open_passwd title] pops up a username/password dialog and returns - (username, password). - *) diff --git a/otherlibs/labltk/frx/frx_rpc.ml b/otherlibs/labltk/frx/frx_rpc.ml deleted file mode 100644 index 5de7a15de..000000000 --- a/otherlibs/labltk/frx/frx_rpc.ml +++ /dev/null @@ -1,55 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -(* Some notion of RPC *) -open Camltk -open Protocol - -(* A RPC is just a callback with a particular name, plus a Tcl procedure *) -let register name f = - let id = new_function_id() in - Hashtbl.add callback_naming_table id f; - (* For rpc_info *) - Textvariable.set (Textvariable.coerce ("camltkrpc("^name^")")) - (string_of_cbid id); - tkCommand [| TkToken "proc"; TkToken name; TkToken "args"; - TkToken ("camlcb "^(string_of_cbid id)^" $args") |] - -(* RPC *) -let invoke interp f args = - tkEval [| - TkToken "send"; - TkToken interp; - TkToken f; - TkTokenList (List.map (fun s -> TkToken s) args) - |] - -let async_invoke interp f args = - tkCommand [| - TkToken "send"; - TkToken "-async"; - TkToken interp; - TkToken f; - TkTokenList (List.map (fun s -> TkToken s) args) - |] - -let rpc_info interp = - tkEval [| - TkToken "send"; - TkToken interp; - TkToken "array"; - TkToken "names"; - TkToken "camltkrpc" - |] diff --git a/otherlibs/labltk/frx/frx_rpc.mli b/otherlibs/labltk/frx/frx_rpc.mli deleted file mode 100644 index 20811738a..000000000 --- a/otherlibs/labltk/frx/frx_rpc.mli +++ /dev/null @@ -1,25 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -(* Some notion of RPC *) - -val register : string -> (string list -> unit) -> unit - (* [register external_name f] *) -val invoke : string -> string -> string list -> string - (* [invoke interp name args] *) -val async_invoke : string -> string -> string list -> unit - (* [async_invoke interp name args] *) -val rpc_info : string -> string - (* [rpc_info interp] *) diff --git a/otherlibs/labltk/frx/frx_selection.ml b/otherlibs/labltk/frx/frx_selection.ml deleted file mode 100644 index ad037ce2d..000000000 --- a/otherlibs/labltk/frx/frx_selection.ml +++ /dev/null @@ -1,45 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -(* A selection handler *) -open Widget -open Protocol -open Camltk - -let frame = ref None -let selection = ref "" - -let read ofs n = - let res = - if ofs < 0 then "" - else if ofs + n > String.length !selection - then String.sub !selection ofs (String.length !selection - ofs) - else String.sub !selection ofs n in - tkreturn res - -(* As long as we don't loose the selection, we keep the widget *) -(* Calling this function means that we own the selection *) -(* When we loose the selection, both cb are destroyed *) -let own () = - match !frame with - None -> - let f = Frame.create_named Widget.default_toplevel "frx_selection" [] in - let lost () = selection := ""; destroy f; frame := None in - Selection.own_set [Selection "PRIMARY"; LostCommand lost] f; - Selection.handle_set [Selection "PRIMARY"; ICCCMType "STRING"] f read; - frame := Some f - | Some f -> () - -let set s = own(); selection := s diff --git a/otherlibs/labltk/frx/frx_selection.mli b/otherlibs/labltk/frx/frx_selection.mli deleted file mode 100644 index b15265834..000000000 --- a/otherlibs/labltk/frx/frx_selection.mli +++ /dev/null @@ -1,17 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -val set : string -> unit - (* [set s] sets the X PRIMARY selection to [s] *) diff --git a/otherlibs/labltk/frx/frx_synth.ml b/otherlibs/labltk/frx/frx_synth.ml deleted file mode 100644 index 21bd7fa86..000000000 --- a/otherlibs/labltk/frx/frx_synth.ml +++ /dev/null @@ -1,88 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -(* Some notion of synthetic events *) -open Camltk -open Widget -open Protocol - -(* To each event is associated a table of (widget, callback) *) -let events = Hashtbl.create 37 - -(* Notes: - * "cascading" events (on the same event) are not supported - * Only one binding active at a time for each event on each widget. - *) - -(* Get the callback table associated with <name>. Initializes if required *) -let get_event name = - try Hashtbl.find events name - with - Not_found -> - let h = Hashtbl.create 37 in - Hashtbl.add events name h; - (* Initialize the callback invocation mechanism, based on - variable trace - *) - let var = "camltk_events(" ^ name ^")" in - let tkvar = Textvariable.coerce var in - let rec set () = - Textvariable.handle tkvar - (fun () -> - begin match Textvariable.get tkvar with - "all" -> (* Invoke all callbacks *) - Hashtbl.iter - (fun p f -> - try - f (cTKtoCAMLwidget p) - with _ -> ()) - h - | p -> (* Invoke callback for p *) - try - let w = cTKtoCAMLwidget p - and f = Hashtbl.find h p in - f w - with - _ -> () - end; - set ()(* reactivate the callback *) - ) in - set(); - h - -(* Remove binding for event <name> on widget <w> *) -let remove w name = - Hashtbl.remove (get_event name) (Widget.name w) - -(* Adds <f> as callback for widget <w> on event <name> *) -let bind w name f = - remove w name; - Hashtbl.add (get_event name) (Widget.name w) f - -(* Sends event <name> to all widgets *) -let broadcast name = - Textvariable.set (Textvariable.coerce ("camltk_events(" ^ name ^")")) "all" - -(* Sends event <name> to widget <w> *) -let send name w = - Textvariable.set (Textvariable.coerce ("camltk_events(" ^ name ^")")) - (Widget.name w) - -(* Remove all callbacks associated to widget <w> *) -let remove_callbacks w = - Hashtbl.iter (fun _ h -> Hashtbl.remove h (Widget.name w)) events - -let _ = - add_destroy_hook remove_callbacks diff --git a/otherlibs/labltk/frx/frx_synth.mli b/otherlibs/labltk/frx/frx_synth.mli deleted file mode 100644 index e5a96aa85..000000000 --- a/otherlibs/labltk/frx/frx_synth.mli +++ /dev/null @@ -1,31 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -(* Synthetic events *) -open Camltk -open Widget - - -val send : string -> widget -> unit - (* [send event_name widget] *) - -val broadcast : string -> unit - (* [broadcase event_name] *) - -val bind : widget -> string -> (widget -> unit) -> unit - (* [bind event_name callback] *) - -val remove : widget -> string -> unit - (* [remove widget event_name] *) diff --git a/otherlibs/labltk/frx/frx_text.ml b/otherlibs/labltk/frx/frx_text.ml deleted file mode 100644 index a9ca17a37..000000000 --- a/otherlibs/labltk/frx/frx_text.ml +++ /dev/null @@ -1,228 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -open Camltk - -let version = "$Id$" - -(* - * convert an integer to an absolute index -*) -let abs_index n = - TextIndex (LineChar(0,0), [CharOffset n]) - -let insertMark = - TextIndex(Mark "insert", []) - -let currentMark = - TextIndex(Mark "current", []) - -let textEnd = - TextIndex(End, []) - -let textBegin = - TextIndex (LineChar(0,0), []) - -(* - * Link a scrollbar and a text widget -*) -let scroll_link sb tx = - Text.configure tx [YScrollCommand (Scrollbar.set sb)]; - Scrollbar.configure sb [ScrollCommand (Text.yview tx)] - - -(* - * Tk 4.0 has navigation in Text widgets, sometimes using scrolling - * sometimes using the insertion mark. It is a pain to add more - * compatible bindings. We do our own. - *) -let page_up tx = Text.yview tx (ScrollPage (-1)) -and page_down tx = Text.yview tx (ScrollPage 1) -and line_up tx = Text.yview tx (ScrollUnit (-1)) -and line_down tx = Text.yview tx (ScrollUnit 1) -and top tx = Text.yview_index tx textBegin -and bottom tx = Text.yview_index tx textEnd - -let navigation_keys tx = - let tags = bindtags_get tx in - match tags with - (WidgetBindings t)::l when t = tx -> - bindtags tx ((WidgetBindings tx) :: (TagBindings "TEXT_RO") :: l) - | _ -> () - -let new_scrollable_text top options navigation = - let f = Frame.create top [] in - let tx = Text.create f options - and sb = Scrollbar.create f [] in - scroll_link sb tx; - (* IN THIS ORDER -- RESIZING *) - pack [sb] [Side Side_Right; Fill Fill_Y]; - pack [tx] [Side Side_Left; Fill Fill_Both; Expand true]; - if navigation then navigation_keys tx; - f, tx - -(* - * Searching - *) -let patternv = Frx_misc.autodef Textvariable.create -and casev = Frx_misc.autodef Textvariable.create - -let topsearch t = - (* The user interface *) - let top = Toplevel.create t [Class "TextSearch"] in - Wm.title_set top "Text search"; - let f = Frame.create_named top "fpattern" [] in - let m = Label.create_named f "search" [Text "Search pattern"] - and e = Entry.create_named f "pattern" - [Relief Sunken; TextVariable (patternv()) ] in - let hgroup = Frame.create top [] - and bgroup = Frame.create top [] in - let fdir = Frame.create hgroup [] - and fmisc = Frame.create hgroup [] in - let direction = Textvariable.create_temporary fdir - and exactv = Textvariable.create_temporary fdir - in - let forw = Radiobutton.create_named fdir "forward" - [Text "Forward"; Variable direction; Value "f"] - and backw = Radiobutton.create_named fdir "backward" - [Text "Backward"; Variable direction; Value "b"] - and exact = Checkbutton.create_named fmisc "exact" - [Text "Exact match"; Variable exactv] - and case = Checkbutton.create_named fmisc "case" - [Text "Fold Case"; Variable (casev())] - and searchb = Button.create_named bgroup "search" [Text "Search"] - and contb = Button.create_named bgroup "continue" [Text "Continue"] - and dismissb = Button.create_named bgroup "dismiss" - [Text "Dismiss"; - Command (fun () -> Text.tag_delete t ["search"]; destroy top)] in - - Radiobutton.invoke forw; - pack [m][Side Side_Left]; - pack [e][Side Side_Right; Fill Fill_X; Expand true]; - pack [forw; backw] [Anchor W]; - pack [exact; case] [Anchor W]; - pack [fdir; fmisc] [Side Side_Left; Anchor Center]; - pack [searchb; contb; dismissb] [Side Side_Left; Fill Fill_X]; - pack [f;hgroup;bgroup] [Fill Fill_X; Expand true]; - - let current_index = ref textBegin in - - let search cont = fun () -> - let opts = ref [] in - if Textvariable.get direction = "f" then - opts := Forwards :: !opts - else opts := Backwards :: !opts ; - if Textvariable.get exactv = "1" then - opts := Exact :: !opts; - if Textvariable.get (casev()) = "1" then - opts := Nocase :: !opts; - try - let forward = Textvariable.get direction = "f" in - let i = Text.search t !opts (Entry.get e) - (if cont then !current_index - else if forward then textBegin - else TextIndex(End, [CharOffset (-1)])) (* does not work with end *) - (if forward then textEnd - else textBegin) in - let found = TextIndex (i, []) in - current_index := - TextIndex(i, [CharOffset (if forward then 1 else (-1))]); - Text.tag_delete t ["search"]; - Text.tag_add t "search" found (TextIndex (i, [WordEnd])); - Text.tag_configure t "search" - [Relief Raised; BorderWidth (Pixels 1); - Background Red]; - Text.see t found - with - Invalid_argument _ -> Bell.ring() in - - bind e [[], KeyPressDetail "Return"] - (BindSet ([], fun _ -> search false ())); - Button.configure searchb [Command (search false)]; - Button.configure contb [Command (search true)]; - Tkwait.visibility top; - Focus.set e - -let addsearch tx = - let tags = bindtags_get tx in - match tags with - (WidgetBindings t)::l when t = tx -> - bindtags tx ((WidgetBindings tx) :: (TagBindings "SEARCH") :: l) - | _ -> () - -(* We use Mod1 instead of Meta or Alt *) -let init () = - List.iter (function ev -> - tag_bind "TEXT_RO" ev - (BindSetBreakable ([Ev_Widget], - (fun ei -> page_up ei.ev_Widget; break())))) - [ - [[], KeyPressDetail "BackSpace"]; - [[], KeyPressDetail "Delete"]; - [[], KeyPressDetail "Prior"]; - [[], KeyPressDetail "b"]; - [[Mod1], KeyPressDetail "v"] - ]; - List.iter (function ev -> - tag_bind "TEXT_RO" ev - (BindSetBreakable ([Ev_Widget], - (fun ei -> page_down ei.ev_Widget; break())))) - [ - [[], KeyPressDetail "space"]; - [[], KeyPressDetail "Next"]; - [[Control], KeyPressDetail "v"] - ]; - List.iter (function ev -> - tag_bind "TEXT_RO" ev - (BindSetBreakable ([Ev_Widget], - (fun ei -> line_up ei.ev_Widget; break())))) - [ - [[], KeyPressDetail "Up"]; - [[Mod1], KeyPressDetail "z"] - ]; - List.iter (function ev -> - tag_bind "TEXT_RO" ev - (BindSetBreakable ([Ev_Widget], - (fun ei -> line_down ei.ev_Widget; break())))) - [ - [[], KeyPressDetail "Down"]; - [[Control], KeyPressDetail "z"] - ]; - - List.iter (function ev -> - tag_bind "TEXT_RO" ev - (BindSetBreakable ([Ev_Widget], - (fun ei -> top ei.ev_Widget; break())))) - [ - [[], KeyPressDetail "Home"]; - [[Mod1], KeyPressDetail "less"] - ]; - - List.iter (function ev -> - tag_bind "TEXT_RO" ev - (BindSetBreakable ([Ev_Widget], - (fun ei -> bottom ei.ev_Widget; break())))) - [ - [[], KeyPressDetail "End"]; - [[Mod1], KeyPressDetail "greater"] - ]; - - List.iter (function ev -> - tag_bind "SEARCH" ev - (BindSetBreakable ([Ev_Widget], - (fun ei -> topsearch ei.ev_Widget; break())))) - [ - [[Control], KeyPressDetail "s"] - ] diff --git a/otherlibs/labltk/frx/frx_text.mli b/otherlibs/labltk/frx/frx_text.mli deleted file mode 100644 index 97783fa96..000000000 --- a/otherlibs/labltk/frx/frx_text.mli +++ /dev/null @@ -1,46 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -open Camltk - -val abs_index : int -> textIndex - (* [abs_index offs] returns the corresponding TextIndex *) - -val insertMark : textIndex -val currentMark : textIndex -val textEnd : textIndex -val textBegin : textIndex - (* shortcuts for various positions in a text widget *) - -val scroll_link : Widget.widget -> Widget.widget -> unit - (* [scroll_link scrollbar text] links a scrollbar and a text widget - as expected - *) - -val new_scrollable_text : - Widget.widget -> options list -> bool -> Widget.widget * Widget.widget - (* [new_scrollable_text parent opts nav_keys] makes a scrollable text - widget with optional navigation keys. Returns frame and text widget. - *) -val addsearch : Widget.widget -> unit - (* [addsearch textw] adds a search dialog bound on [Control-s] - on the text widget - *) - -val navigation_keys : Widget.widget -> unit - (* [navigation_keys textw] adds common navigations functions to [textw] *) - -val init : unit -> unit - (* [init ()] must be called before any of the above features is used *) diff --git a/otherlibs/labltk/frx/frx_toplevel.mli b/otherlibs/labltk/frx/frx_toplevel.mli deleted file mode 100644 index 628cde207..000000000 --- a/otherlibs/labltk/frx/frx_toplevel.mli +++ /dev/null @@ -1,17 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -open Widget -val make_visible : Widget -> unit diff --git a/otherlibs/labltk/frx/frx_widget.ml b/otherlibs/labltk/frx/frx_widget.ml deleted file mode 100644 index 904513436..000000000 --- a/otherlibs/labltk/frx/frx_widget.ml +++ /dev/null @@ -1,23 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -open Camltk -open Widget - -let version = "$Id$" -(* Make a window (toplevel widget) resizeable *) -let resizeable t = - update_idletasks(); (* wait until layout is computed *) - Wm.minsize_set t (Winfo.width t) (Winfo.height t) diff --git a/otherlibs/labltk/frx/frx_widget.mli b/otherlibs/labltk/frx/frx_widget.mli deleted file mode 100644 index f856664cf..000000000 --- a/otherlibs/labltk/frx/frx_widget.mli +++ /dev/null @@ -1,18 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -open Camltk -open Widget -val resizeable : widget -> unit diff --git a/otherlibs/labltk/frx/frxlib.mllib b/otherlibs/labltk/frx/frxlib.mllib deleted file mode 100644 index 3641ae5f2..000000000 --- a/otherlibs/labltk/frx/frxlib.mllib +++ /dev/null @@ -1,4 +0,0 @@ -Frx_misc Frx_widget Frx_font Frx_entry Frx_text -Frx_listbox Frx_req Frx_fillbox Frx_focus -Frx_dialog Frx_mem Frx_rpc Frx_synth Frx_selection -Frx_after Frx_fit Frx_ctext Frx_color |