Add to HEAD branch

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@2649 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
author: Jacques Garrigue <garrigue at math.nagoya-u.ac.jp> 1999-11-30 14:59:39 +0000
committer: Jacques Garrigue <garrigue at math.nagoya-u.ac.jp> 1999-11-30 14:59:39 +0000
commit: ca0b21c5adbe660a52e5a9dfe1dda16985fe5f7c (patch)
tree: e202ba49531807a7a6c2bd46f37b2bbbeb170d0f /otherlibs/labltk/builtin
parent: 68ba9a8c42b0197bc415de2f81aa6d0c8e84780a (diff)
36 files changed, 844 insertions, 0 deletions
diff --git a/otherlibs/labltk/builtin/builtin_GetBitmap.ml b/otherlibs/labltk/builtin/builtin_GetBitmap.ml
new file mode 100644
index 000000000..31b807e68
--- /dev/null
+++ b/otherlibs/labltk/builtin/builtin_GetBitmap.ml
@@ -0,0 +1,8 @@
+(* Tk_GetBitmap emulation *)
+(* type *)
+type bitmap = [
+    `File string                 (* path of file *)
+  | `Predefined string           (* bitmap  name *)
+]
+(* /type *)
+
diff --git a/otherlibs/labltk/builtin/builtin_GetCursor.ml b/otherlibs/labltk/builtin/builtin_GetCursor.ml
new file mode 100644
index 000000000..1b7235741
--- /dev/null
+++ b/otherlibs/labltk/builtin/builtin_GetCursor.ml
@@ -0,0 +1,24 @@
+(* Color *)
+(* type *)
+type color = [
+    `Color string
+  | `Black                      (* tk keyword: black *)
+  | `White                      (* tk keyword: white *)
+  | `Red                        (* tk keyword: red *)
+  | `Green                      (* tk keyword: green *)
+  | `Blue                       (* tk keyword: blue *)
+  | `Yellow                     (* tk keyword: yellow *)
+]
+(* /type *)
+
+(* Tk_GetCursor emulation *)
+(* type *)
+type cursor = [
+    `Xcursor string
+  | `Xcursorfg string * color
+  | `Xcursorfgbg string * color * color
+  | `Cursorfilefg string * color
+  | `Cursormaskfile string * string * color * color
+]
+(* /type *)
+
diff --git a/otherlibs/labltk/builtin/builtin_GetPixel.ml b/otherlibs/labltk/builtin/builtin_GetPixel.ml
new file mode 100644
index 000000000..f760dce75
--- /dev/null
+++ b/otherlibs/labltk/builtin/builtin_GetPixel.ml
@@ -0,0 +1,11 @@
+(* Tk_GetPixels emulation *)
+(* type *)
+type units = [
+    `Pix int
+  | `Cm float
+  | `In float
+  | `Mm float
+  | `Pt float
+]
+(* /type *)
+
diff --git a/otherlibs/labltk/builtin/builtin_ScrollValue.ml b/otherlibs/labltk/builtin/builtin_ScrollValue.ml
new file mode 100644
index 000000000..201247e41
--- /dev/null
+++ b/otherlibs/labltk/builtin/builtin_ScrollValue.ml
@@ -0,0 +1,8 @@
+(* type *)
+type scrollValue = [
+    `Page(int)          (* tk option: scroll <int> page *)
+  | `Unit(int)          (* tk option: scroll <int> unit *)
+  | `Moveto(float)      (* tk option: moveto <float> *)
+]
+(* /type *)
+
diff --git a/otherlibs/labltk/builtin/builtin_bind.ml b/otherlibs/labltk/builtin/builtin_bind.ml
new file mode 100644
index 000000000..d8923353a
--- /dev/null
+++ b/otherlibs/labltk/builtin/builtin_bind.ml
@@ -0,0 +1,236 @@
+open Widget
+
+(* Events and bindings *)
+(* Builtin types *)
+(* type *)
+type xEvent = [
+    `ButtonPress (* also Button, but we omit it *)
+  | `ButtonPressDetail (int)
+  | `ButtonRelease
+  | `ButtonReleaseDetail (int)
+  | `Circulate
+  | `ColorMap
+  | `Configure
+  | `Destroy
+  | `Enter
+  | `Expose
+  | `FocusIn
+  | `FocusOut
+  | `Gravity
+  | `KeyPress (* also Key, but we omit it *)
+  | `KeyPressDetail (string)      (* /usr/include/X11/keysymdef.h *)
+  | `KeyRelease
+  | `KeyReleaseDetail (string)
+  | `Leave
+  | `Map
+  | `Motion
+  | `Property
+  | `Reparent
+  | `Unmap
+  | `Visibility 
+]
+(* /type *)
+
+(* type *)
+type modifier = [
+    `Control
+  | `Shift
+  | `Lock
+  | `Button1
+  | `Button2
+  | `Button3
+  | `Button4
+  | `Button5
+  | `Double
+  | `Triple
+  | `Mod1
+  | `Mod2
+  | `Mod3
+  | `Mod4
+  | `Mod5
+  | `Meta
+  | `Alt 
+]
+(* /type *)
+
+(* Event structure, passed to bounded functions *)
+
+(* type *)
+type eventInfo =
+  {
+  mutable ev_Above : int;               (* tk: %a *)
+  mutable ev_ButtonNumber : int;        (* tk: %b *)
+  mutable ev_Count : int;               (* tk: %c *)
+  mutable ev_Detail : string;           (* tk: %d *)
+  mutable ev_Focus : bool;              (* tk: %f *)
+  mutable ev_Height : int;              (* tk: %h *)
+  mutable ev_KeyCode : int;             (* tk: %k *)
+  mutable ev_Mode : string;             (* tk: %m *)
+  mutable ev_OverrideRedirect : bool;   (* tk: %o *)
+  mutable ev_Place : string;            (* tk: %p *)
+  mutable ev_State : string;            (* tk: %s *)
+  mutable ev_Time : int;                (* tk: %t *)
+  mutable ev_Width : int;               (* tk: %w *)
+  mutable ev_MouseX : int;              (* tk: %x *)
+  mutable ev_MouseY : int;              (* tk: %y *)
+  mutable ev_Char : string;             (* tk: %A *)
+  mutable ev_BorderWidth : int;         (* tk: %B *)
+  mutable ev_SendEvent : bool;          (* tk: %E *)
+  mutable ev_KeySymString : string;     (* tk: %K *)
+  mutable ev_KeySymInt : int;           (* tk: %N *)
+  mutable ev_RootWindow : int;          (* tk: %R *)
+  mutable ev_SubWindow : int;           (* tk: %S *)
+  mutable ev_Type : int;                (* tk: %T *)
+  mutable ev_Widget : any widget;       (* tk: %W *)
+  mutable ev_RootX : int;               (* tk: %X *)
+  mutable ev_RootY : int                (* tk: %Y *)
+  }
+(* /type *)
+
+
+(* To avoid collision with other constructors (Width, State), 
+   use Ev_ prefix *)
+(* type *)
+type eventField = [
+    `Above
+  | `ButtonNumber
+  | `Count
+  | `Detail
+  | `Focus
+  | `Height
+  | `KeyCode
+  | `Mode
+  | `OverrideRedirect
+  | `Place
+  | `State
+  | `Time 
+  | `Width
+  | `MouseX
+  | `MouseY
+  | `Char
+  | `BorderWidth
+  | `SendEvent
+  | `KeySymString
+  | `KeySymInt
+  | `RootWindow
+  | `SubWindow
+  | `Type
+  | `Widget
+  | `RootX
+  | `RootY
+]
+(* /type *)
+
+let filleventInfo ev v = function 
+    `Above    ->        ev.ev_Above <- int_of_string v
+  | `ButtonNumber ->    ev.ev_ButtonNumber <- int_of_string v
+  | `Count ->           ev.ev_Count <- int_of_string v
+  | `Detail ->          ev.ev_Detail <- v
+  | `Focus ->           ev.ev_Focus <- v = "1"
+  | `Height ->          ev.ev_Height <- int_of_string v
+  | `KeyCode ->         ev.ev_KeyCode <- int_of_string v
+  | `Mode ->            ev.ev_Mode <- v
+  | `OverrideRedirect -> ev.ev_OverrideRedirect <- v = "1"
+  | `Place ->           ev.ev_Place <- v
+  | `State ->           ev.ev_State <- v
+  | `Time ->            ev.ev_Time <- int_of_string v
+  | `Width ->           ev.ev_Width <- int_of_string v
+  | `MouseX ->          ev.ev_MouseX <- int_of_string v
+  | `MouseY ->          ev.ev_MouseY <- int_of_string v
+  | `Char ->            ev.ev_Char <- v
+  | `BorderWidth ->     ev.ev_BorderWidth <- int_of_string v
+  | `SendEvent ->       ev.ev_SendEvent <- v = "1"
+  | `KeySymString ->    ev.ev_KeySymString <- v
+  | `KeySymInt ->       ev.ev_KeySymInt <- int_of_string v
+  | `RootWindow ->      ev.ev_RootWindow <- int_of_string v
+  | `SubWindow ->       ev.ev_SubWindow <- int_of_string v
+  | `Type ->            ev.ev_Type <- int_of_string v
+  | `Widget ->          ev.ev_Widget <- cTKtoCAMLwidget v
+  | `RootX ->           ev.ev_RootX <- int_of_string v
+  | `RootY ->           ev.ev_RootY <- int_of_string v
+
+let wrapeventInfo f what =
+  let ev = {
+    ev_Above = 0;
+    ev_ButtonNumber = 0;
+    ev_Count = 0;
+    ev_Detail = "";
+    ev_Focus = false;
+    ev_Height = 0;
+    ev_KeyCode = 0;
+    ev_Mode = "";
+    ev_OverrideRedirect = false;
+    ev_Place = "";
+    ev_State = "";
+    ev_Time = 0;
+    ev_Width = 0;
+    ev_MouseX = 0;
+    ev_MouseY = 0;
+    ev_Char = "";
+    ev_BorderWidth = 0;
+    ev_SendEvent = false;
+    ev_KeySymString = "";
+    ev_KeySymInt = 0;
+    ev_RootWindow = 0;
+    ev_SubWindow = 0;
+    ev_Type = 0;
+    ev_Widget = forget_type default_toplevel;
+    ev_RootX = 0;
+    ev_RootY = 0 } in
+     function args ->
+       let l = ref args in
+         List.iter fun:(function field ->
+                    match !l with
+                      [] -> ()
+                    | v::rest -> filleventInfo ev v field; l:=rest)
+                 what;
+       f ev
+
+
+
+let rec writeeventField = function
+    [] -> ""
+  | field::rest ->
+    begin
+    match field with
+        `Above ->     " %a"
+      | `ButtonNumber ->" %b"
+      | `Count ->     " %c"
+      | `Detail ->    " %d"
+      | `Focus ->     " %f"
+      | `Height ->    " %h"
+      | `KeyCode ->   " %k"
+      | `Mode ->      " %m"
+      | `OverrideRedirect -> " %o"
+      | `Place ->     " %p"
+      | `State ->     " %s"
+      | `Time ->      " %t"
+      | `Width ->     " %w"
+      | `MouseX ->    " %x"
+      | `MouseY ->    " %y"
+      (* Quoting is done by Tk *)
+      | `Char ->      " %A"
+      | `BorderWidth -> " %B"
+      | `SendEvent -> " %E"
+      | `KeySymString -> " %K"
+      | `KeySymInt -> " %N"
+      | `RootWindow ->" %R"
+      | `SubWindow -> " %S"
+      | `Type ->      " %T"
+      | `Widget ->" %W"
+      | `RootX ->     " %X"
+      | `RootY ->     " %Y"
+    end 
+    ^ writeeventField rest
+
+
+(* type *)
+type bindAction = [
+   `Set ( eventField list *  (eventInfo -> unit))
+  | `Setbreakable ( eventField list *  (eventInfo -> unit) )
+  | `Remove
+  | `Extend ( eventField list *  (eventInfo -> unit))
+]
+(* /type *)
+
+
diff --git a/otherlibs/labltk/builtin/builtin_bindtags.ml b/otherlibs/labltk/builtin/builtin_bindtags.ml
new file mode 100644
index 000000000..88b9d87db
--- /dev/null
+++ b/otherlibs/labltk/builtin/builtin_bindtags.ml
@@ -0,0 +1,7 @@
+(* type *)
+type bindings = [
+    `Tag(string)                (* tk option: <string> *)
+  | `Widget(any widget)         (* tk option: <widget> *)
+]
+(* /type *)
+
diff --git a/otherlibs/labltk/builtin/builtin_grab.ml b/otherlibs/labltk/builtin/builtin_grab.ml
new file mode 100644
index 000000000..3fe288d16
--- /dev/null
+++ b/otherlibs/labltk/builtin/builtin_grab.ml
@@ -0,0 +1 @@
+type grabGlobal = bool
diff --git a/otherlibs/labltk/builtin/builtin_index.ml b/otherlibs/labltk/builtin/builtin_index.ml
new file mode 100644
index 000000000..2f5bbfba7
--- /dev/null
+++ b/otherlibs/labltk/builtin/builtin_index.ml
@@ -0,0 +1,56 @@
+(* Various indexes
+    canvas
+    entry
+    listbox
+*)
+
+type canvas_index = [
+    `Num(int)           
+  | `End                        
+  | `Insert             
+  | `Selfirst           
+  | `Sellast            
+  | `Atxy(int * int)         
+]
+
+type entry_index = [
+    `Num(int)           
+  | `End
+  | `Insert             
+  | `Selfirst           
+  | `Sellast            
+  | `At(int)
+  | `Anchor
+]
+
+type listbox_index = [
+    `Num(int)           
+  | `Active
+  | `Anchor
+  | `End
+  | `Atxy(int * int)
+]
+
+type menu_index = [
+    `Num(int)           
+  | `Active
+  | `End
+  | `Last                       
+  | `None               
+  | `At(int)
+  | `Pattern(string)
+]
+
+type text_index = [
+    `Linechar(int * int)   
+  | `Atxy(int * int)
+  | `End
+  | `Mark(string)
+  | `Tagfirst(string)
+  | `Taglast(string)
+  | `Window(any widget)
+  | `Image(string) 
+]
+
+type linechar_index = int * int
+type num_index = int
diff --git a/otherlibs/labltk/builtin/builtin_palette.ml b/otherlibs/labltk/builtin/builtin_palette.ml
new file mode 100644
index 000000000..1bf305490
--- /dev/null
+++ b/otherlibs/labltk/builtin/builtin_palette.ml
@@ -0,0 +1,7 @@
+(* type *)
+type paletteType = [
+    `Gray (int)
+  | `Rgb (int * int * int)
+]
+(* /type *)
+
diff --git a/otherlibs/labltk/builtin/builtin_text.ml b/otherlibs/labltk/builtin/builtin_text.ml
new file mode 100644
index 000000000..1937e7911
--- /dev/null
+++ b/otherlibs/labltk/builtin/builtin_text.ml
@@ -0,0 +1,24 @@
+(* Not a string as such, more like a symbol *)
+
+(* type *)
+type textMark = string
+(* /type *)
+
+(* type *)
+type textTag = string
+(* /type *)
+
+(* type *)
+type textModifier = [
+    `Char(int)          (* tk keyword: +/- Xchars *)
+  | `Line(int)          (* tk keyword: +/- Xlines *)
+  | `Linestart                  (* tk keyword: linestart *)
+  | `Lineend                    (* tk keyword: lineend *)
+  | `Wordstart                  (* tk keyword: wordstart *)
+  | `Wordend                    (* tk keyword: wordend *)
+]
+(* /type *)
+
+(* type *)
+type textIndex = text_index * textModifier list
+(* /type *)
diff --git a/otherlibs/labltk/builtin/builtina_empty.ml b/otherlibs/labltk/builtin/builtina_empty.ml
new file mode 100644
index 000000000..e69de29bb
--- /dev/null
+++ b/otherlibs/labltk/builtin/builtina_empty.ml
diff --git a/otherlibs/labltk/builtin/builtinf_bind.ml b/otherlibs/labltk/builtin/builtinf_bind.ml
new file mode 100644
index 000000000..b05219143
--- /dev/null
+++ b/otherlibs/labltk/builtin/builtinf_bind.ml
@@ -0,0 +1,83 @@
+(*
+FUNCTION
+ val bind: 
+    any widget -> (modifier list * xEvent) list -> bindAction -> unit
+/FUNCTION
+*)
+let bind widget events:eventsequence action:(action : bindAction) =
+  tkEval [| TkToken "bind";
+            TkToken (Widget.name widget);
+            cCAMLtoTKeventSequence eventsequence;
+  begin match action with
+     `Remove -> TkToken ""
+  |  `Set (what, f) ->
+      let cbId = register_callback widget callback: (wrapeventInfo f what) in
+        TkToken ("camlcb " ^ cbId ^ (writeeventField what))
+  |  `Setbreakable (what, f) ->
+      let cbId = register_callback widget callback: (wrapeventInfo f what) in
+        TkToken ("camlcb " ^ cbId ^ (writeeventField what)^
+                 " ; if { $BreakBindingsSequence == 1 } then { break ;} ; set BreakBindingsSequence 0"
+                )
+  |  `Extend (what, f) ->
+      let cbId = register_callback widget callback: (wrapeventInfo f what) in
+        TkToken ("+camlcb " ^ cbId ^ (writeeventField what))
+      
+  end
+  |];
+  ()
+
+(* 
+FUNCTION
+(* unsafe *)
+ val class_bind : 
+    string -> (modifier list * xEvent) list -> bindAction -> unit 
+(* /unsafe *)
+/FUNCTION
+ class arg is not constrained
+*)
+let class_bind clas events:eventsequence action:(action : bindAction) =
+  tkEval [| TkToken "bind";
+            TkToken clas;
+            cCAMLtoTKeventSequence eventsequence;
+  begin match action with
+     `Remove -> TkToken ""
+  |  `Set (what, f) ->
+      let cbId = register_callback Widget.dummy 
+                                   callback: (wrapeventInfo f what) in
+        TkToken ("camlcb " ^ cbId ^ (writeeventField what))
+  |  `Setbreakable (what, f) ->
+      let cbId = register_callback Widget.dummy 
+                                   callback: (wrapeventInfo f what) in
+        TkToken ("camlcb " ^ cbId ^ (writeeventField what)^
+                 " ; if { $BreakBindingsSequence == 1 } then { break ;} ; set BreakBindingsSequence 0"
+                )
+  |  `Extend (what, f) ->
+      let cbId = register_callback Widget.dummy 
+                                   callback: (wrapeventInfo f what) in
+        TkToken ("+camlcb " ^ cbId ^ (writeeventField what))
+      
+  end
+ |];
+  ()
+
+(* 
+FUNCTION
+(* unsafe *)
+ val tag_bind : 
+    string -> (modifier list * xEvent) list -> bindAction -> unit 
+(* /unsafe *)
+/FUNCTION
+ tag name arg is not constrained 
+*)
+
+let tag_bind = class_bind
+
+
+(*
+FUNCTION
+  val break : unit -> unit
+/FUNCTION
+*)
+let break = function () ->
+  tkEval [| TkToken "set" ; TkToken "BreakBindingsSequence" ; TkToken "1" |];
+  ()
diff --git a/otherlibs/labltk/builtin/builtini_GetBitmap.ml b/otherlibs/labltk/builtin/builtini_GetBitmap.ml
new file mode 100644
index 000000000..d18111127
--- /dev/null
+++ b/otherlibs/labltk/builtin/builtini_GetBitmap.ml
@@ -0,0 +1,10 @@
+let cCAMLtoTKbitmap : bitmap -> tkArgs = function
+  `File s -> TkToken ("@" ^ s)
+| `Predefined s -> TkToken s
+
+let cTKtoCAMLbitmap s = 
+ if String.get s 0 = '@'
+ then `File (String.sub s pos:1 len:(String.length s - 1))
+ else `Predefined s
+
+
diff --git a/otherlibs/labltk/builtin/builtini_GetCursor.ml b/otherlibs/labltk/builtin/builtini_GetCursor.ml
new file mode 100644
index 000000000..8c63876cb
--- /dev/null
+++ b/otherlibs/labltk/builtin/builtini_GetCursor.ml
@@ -0,0 +1,24 @@
+let cCAMLtoTKcolor : color -> tkArgs = function
+    `Color x -> TkToken x
+  | `Black -> TkToken "black"
+  | `White -> TkToken "white"
+  | `Red -> TkToken "red"
+  | `Green -> TkToken "green"
+  | `Blue -> TkToken "blue"
+  | `Yellow -> TkToken "yellow"
+
+let cTKtoCAMLcolor = function  s -> `Color s
+
+
+let cCAMLtoTKcursor : cursor -> tkArgs = function
+   `Xcursor s -> TkToken s
+ | `Xcursorfg (s,fg) -> 
+    TkQuote(TkTokenList [TkToken s; cCAMLtoTKcolor fg])
+ | `Xcursorfgbg (s,fg,bg) ->
+    TkQuote(TkTokenList [TkToken s; cCAMLtoTKcolor fg; cCAMLtoTKcolor bg])
+ | `Cursorfilefg (s,fg) ->
+    TkQuote(TkTokenList [TkToken ("@"^s); cCAMLtoTKcolor fg])
+ | `Cursormaskfile (s,m,fg,bg) ->
+    TkQuote(TkTokenList [TkToken ("@"^s); TkToken m; cCAMLtoTKcolor fg; cCAMLtoTKcolor bg])
+
+
diff --git a/otherlibs/labltk/builtin/builtini_GetPixel.ml b/otherlibs/labltk/builtin/builtini_GetPixel.ml
new file mode 100644
index 000000000..e47048aec
--- /dev/null
+++ b/otherlibs/labltk/builtin/builtini_GetPixel.ml
@@ -0,0 +1,18 @@
+let cCAMLtoTKunits : units -> tkArgs = function
+    `Pix (foo) -> TkToken (string_of_int foo)
+  | `Mm (foo)  -> TkToken(string_of_float foo^"m")
+  | `In (foo)  -> TkToken(string_of_float foo^"i")
+  | `Pt (foo) -> TkToken(string_of_float foo^"p")
+  | `Cm (foo) -> TkToken(string_of_float foo^"c")
+  
+
+let cTKtoCAMLunits str = 
+  let len = String.length str in
+  let num_part str = String.sub str pos:0 len:(len - 1) in
+  match String.get str (pred len) with
+    'c' -> `Cm (float_of_string (num_part str))
+  | 'i' -> `In (float_of_string (num_part str))
+  | 'm' -> `Mm (float_of_string (num_part str))
+  | 'p' -> `Pt (float_of_string (num_part str))
+  | _ -> `Pix(int_of_string str)
+
diff --git a/otherlibs/labltk/builtin/builtini_ScrollValue.ml b/otherlibs/labltk/builtin/builtini_ScrollValue.ml
new file mode 100644
index 000000000..8327ab6f7
--- /dev/null
+++ b/otherlibs/labltk/builtin/builtini_ScrollValue.ml
@@ -0,0 +1,17 @@
+let cCAMLtoTKscrollValue : scrollValue -> tkArgs = function
+   `Page v1 ->
+    TkTokenList [TkToken"scroll"; TkToken (string_of_int v1); TkToken"pages"]
+ | `Unit v1 ->
+    TkTokenList [TkToken"scroll"; TkToken (string_of_int v1); TkToken"units"]
+ | `Moveto v1 ->
+    TkTokenList [TkToken"moveto"; TkToken (string_of_float v1)]
+
+(* str l -> scrllv -> str l *)
+let cTKtoCAMLscrollValue = function
+   "scroll"::n::"pages"::l -> 
+     `Page (int_of_string n), l
+ | "scroll"::n::"units"::l ->
+     `Unit (int_of_string n), l
+ | "moveto"::f::l ->
+     `Moveto (float_of_string f), l
+ | _ -> raise (Invalid_argument "TKtoCAMLscrollValue")
diff --git a/otherlibs/labltk/builtin/builtini_bind.ml b/otherlibs/labltk/builtin/builtini_bind.ml
new file mode 100644
index 000000000..8dbde204b
--- /dev/null
+++ b/otherlibs/labltk/builtin/builtini_bind.ml
@@ -0,0 +1,58 @@
+let cCAMLtoTKxEvent : xEvent -> string = function
+    `ButtonPress -> "ButtonPress"
+  | `ButtonPressDetail n -> "ButtonPress-"^string_of_int n
+  | `ButtonRelease -> "ButtonRelease"
+  | `ButtonReleaseDetail n -> "ButtonRelease-"^string_of_int n
+  | `Circulate -> "Circulate"
+  | `ColorMap -> "ColorMap"
+  | `Configure -> "Configure"
+  | `Destroy -> "Destroy"
+  | `Enter -> "Enter"
+  | `Expose -> "Expose"
+  | `FocusIn -> "FocusIn"
+  | `FocusOut -> "FocusOut"
+  | `Gravity -> "Gravity"
+  | `KeyPress -> "KeyPress"
+  | `KeyPressDetail s -> "KeyPress-"^s
+  | `KeyRelease -> "KeyRelease"
+  | `KeyReleaseDetail s -> "KeyRelease-"^s
+  | `Leave -> "Leave"
+  | `Map -> "Map"
+  | `Motion -> "Motion"
+  | `Property -> "Property"
+  | `Reparent -> "Reparent"
+  | `Unmap -> "Unmap"
+  | `Visibility -> "Visibility" 
+
+let cCAMLtoTKmodifier : modifier -> string = function
+   `Control -> "Control-"
+ | `Shift -> "Shift-"
+ | `Lock -> "Lock-"
+ | `Button1 -> "Button1-"
+ | `Button2 -> "Button2-"
+ | `Button3 -> "Button3-"
+ | `Button4 -> "Button4-"
+ | `Button5 -> "Button5-"
+ | `Double -> "Double-"
+ | `Triple -> "Triple-"
+ | `Mod1 -> "Mod1-"
+ | `Mod2 -> "Mod2-"
+ | `Mod3 -> "Mod3-"
+ | `Mod4 -> "Mod4-"
+ | `Mod5 -> "Mod5-"
+ | `Meta -> "Meta-"
+ | `Alt -> "Alt-"
+
+
+(* type event = modifier list * xEvent *)
+let cCAMLtoTKevent : (modifier list * xEvent) -> string = 
+ function (ml, xe) ->
+  "<" ^ (catenate_sep " " (List.map fun:cCAMLtoTKmodifier ml))  
+      ^ (cCAMLtoTKxEvent xe) ^ ">"
+  
+(* type eventSequence == (modifier list * xEvent) list *)
+let cCAMLtoTKeventSequence : (modifier list * xEvent) list -> tkArgs = 
+ function l ->
+  TkToken(catenate_sep "" (List.map fun:cCAMLtoTKevent l))
+
+
diff --git a/otherlibs/labltk/builtin/builtini_bindtags.ml b/otherlibs/labltk/builtin/builtini_bindtags.ml
new file mode 100644
index 000000000..7bbfe5963
--- /dev/null
+++ b/otherlibs/labltk/builtin/builtini_bindtags.ml
@@ -0,0 +1,9 @@
+let cCAMLtoTKbindings = function
+  `Widget v1 -> cCAMLtoTKwidget v1
+| `Tag v1 -> TkToken v1
+
+(* this doesn't really belong here *)
+let cTKtoCAMLbindings s =
+  if String.length s > 0 & s.[0] = '.' then
+    `Widget (cTKtoCAMLwidget s)
+  else `Tag s
diff --git a/otherlibs/labltk/builtin/builtini_grab.ml b/otherlibs/labltk/builtin/builtini_grab.ml
new file mode 100644
index 000000000..9007d04fa
--- /dev/null
+++ b/otherlibs/labltk/builtin/builtini_grab.ml
@@ -0,0 +1,2 @@
+let cCAMLtoTKgrabGlobal x =
+  if x then TkToken "-global" else TkTokenList []
diff --git a/otherlibs/labltk/builtin/builtini_index.ml b/otherlibs/labltk/builtin/builtini_index.ml
new file mode 100644
index 000000000..cd2dc9c0b
--- /dev/null
+++ b/otherlibs/labltk/builtin/builtini_index.ml
@@ -0,0 +1,70 @@
+let cCAMLtoTKindex (* Don't put explicit typing *) = function
+   `Num x -> TkToken (string_of_int x)
+ | `Active -> TkToken "active"
+ | `End -> TkToken "end"
+ | `Last -> TkToken "last"
+ | `None -> TkToken "none"
+ | `Insert -> TkToken "insert"
+ | `Selfirst -> TkToken "sel.first"
+ | `Sellast -> TkToken "sel.last"
+ | `At n -> TkToken ("@"^string_of_int n)
+ | `Atxy (x,y) -> TkToken ("@"^string_of_int x^","^string_of_int y)
+ | `Anchor -> TkToken "anchor"
+ | `Pattern s -> TkToken s
+ | `Linechar (l,c) -> TkToken (string_of_int l^"."^string_of_int c)
+ | `Mark s -> TkToken s
+ | `Tagfirst t -> TkToken (t^".first")
+ | `Taglast t -> TkToken (t^".last")
+ | `Window (w : any widget) -> cCAMLtoTKwidget w
+ | `Image s -> TkToken s
+
+let cCAMLtoTKcanvas_index = (cCAMLtoTKindex : canvas_index -> tkArgs)
+let cCAMLtoTKentry_index = (cCAMLtoTKindex : entry_index -> tkArgs)
+let cCAMLtoTKlistbox_index = (cCAMLtoTKindex : listbox_index -> tkArgs)
+let cCAMLtoTKmenu_index = (cCAMLtoTKindex : menu_index -> tkArgs)
+let cCAMLtoTKtext_index = (cCAMLtoTKindex : text_index -> tkArgs)
+
+(* Assume returned values are only numerical and l.c *)
+(* .menu index returns none if arg is none, but blast it *)
+
+let cTKtoCAMLindex s =
+  try
+   let p = String.index elt:'.' s in
+    `Linechar (int_of_string (String.sub s pos:0 len:p), 
+             int_of_string (String.sub s pos:(p+1) 
+                                         len:(String.length s - p - 1)))
+  with
+    Not_found ->
+      try `Num (int_of_string s)
+      with _ -> raise (Invalid_argument ("TKtoCAMLindex: "^s))
+
+let cTKtoCAMLtext_index s = 
+  try
+   let p = String.index elt:'.' s in
+    `Linechar (int_of_string (String.sub s pos:0 len:p), 
+             int_of_string (String.sub s pos:(p+1) 
+                                         len:(String.length s - p - 1)))
+  with
+    Not_found ->
+      raise (Invalid_argument ("TKtoCAMLtext_index: "^s))
+
+
+let cTKtoCAMLlistbox_index s =
+  try `Num (int_of_string s)
+  with _ -> raise (Invalid_argument ("TKtoCAMLlistbox_index: "^s))
+
+(*
+let cTKtoCAMLlinechar_index s =
+  try
+   let p = char_index '.' in:s in
+      (int_of_string (String.sub s pos:0 len:p), 
+             int_of_string (String.sub s pos:(p+1) 
+                                         len:(String.length s - p - 1)))
+  with
+    Not_found ->
+      raise (Invalid_argument ("TKtoCAMLlinechar_index: "^s))
+
+let cTKtoCAMLnum_index s =
+  try int_of_string s
+  with _ -> raise (Invalid_argument ("TKtoCAMLnum_index: "^s))
+*)
diff --git a/otherlibs/labltk/builtin/builtini_palette.ml b/otherlibs/labltk/builtin/builtini_palette.ml
new file mode 100644
index 000000000..c4d3d752c
--- /dev/null
+++ b/otherlibs/labltk/builtin/builtini_palette.ml
@@ -0,0 +1,5 @@
+let cCAMLtoTKpaletteType : paletteType -> tkArgs = function
+    `Gray (foo) -> TkToken (string_of_int foo)
+  | `Rgb (r,v,b) -> TkToken (string_of_int r ^ "/" ^
+                             string_of_int v ^ "/" ^
+                             string_of_int b)
diff --git a/otherlibs/labltk/builtin/builtini_text.ml b/otherlibs/labltk/builtin/builtini_text.ml
new file mode 100644
index 000000000..1c7e2d7c0
--- /dev/null
+++ b/otherlibs/labltk/builtin/builtini_text.ml
@@ -0,0 +1,37 @@
+let cCAMLtoTKtextMark  x =  TkToken x
+let cTKtoCAMLtextMark x = x
+
+let cCAMLtoTKtextTag  x =  TkToken x
+let cTKtoCAMLtextTag x = x
+
+(* TextModifiers are never returned by Tk *)
+let ppTextModifier = function
+   `Char n -> 
+      if n > 0 then "+" ^ (string_of_int n) ^ "chars"
+      else if n = 0 then ""
+      else (string_of_int n) ^ "chars"
+ | `Line n -> 
+      if n > 0 then "+" ^ (string_of_int n) ^ "lines"
+      else if n = 0 then ""
+      else (string_of_int n) ^ "lines"
+ | `Linestart -> " linestart"
+ | `Lineend -> " lineend"
+ | `Wordstart -> " wordstart"
+ | `Wordend -> " wordend"
+
+(*
+let ppTextIndex = function
+   `None -> ""
+ | `Index (base, ml) -> 
+     let (TkToken ppbase) = cCAMLtoTKtext_index base in 
+       catenate_sep "" (ppbase :: List.map fun:ppTextModifier ml)
+*)
+
+let ppTextIndex = function
+  (base, ml) -> 
+     let (TkToken ppbase) = cCAMLtoTKtext_index base in 
+       catenate_sep "" (ppbase :: List.map fun:ppTextModifier ml)
+
+let cCAMLtoTKtextIndex : textIndex -> tkArgs = function i -> 
+  TkToken (ppTextIndex i)
+
diff --git a/otherlibs/labltk/builtin/canvas_bind.ml b/otherlibs/labltk/builtin/canvas_bind.ml
new file mode 100644
index 000000000..43f07dcb7
--- /dev/null
+++ b/otherlibs/labltk/builtin/canvas_bind.ml
@@ -0,0 +1,21 @@
+let bind widget :tag events:eventsequence :action =
+  tkEval [| cCAMLtoTKwidget widget;
+            TkToken "bind";
+            cCAMLtoTKtagOrId tag;
+            cCAMLtoTKeventSequence eventsequence;
+  begin match action with
+     `Remove -> TkToken ""
+  |  `Set (what, f) ->
+      let cbId = register_callback widget callback:(wrapeventInfo f what) in
+        TkToken ("camlcb " ^ cbId ^ (writeeventField what))
+  |  `Setbreakable (what, f) ->
+      let cbId = register_callback widget callback:(wrapeventInfo f what) in
+        TkToken ("camlcb " ^ cbId ^ (writeeventField what)^
+                " ; if { $BreakBindingsSequence == 1 } then { break ;} ; set BreakBindingsSequence 0"
+                )
+  |  `Extend (what, f) ->
+      let cbId = register_callback widget callback:(wrapeventInfo f what) in
+        TkToken ("+camlcb " ^ cbId ^ (writeeventField what))
+
+  end |];
+  ()
diff --git a/otherlibs/labltk/builtin/canvas_bind.mli b/otherlibs/labltk/builtin/canvas_bind.mli
new file mode 100644
index 000000000..55c3ec364
--- /dev/null
+++ b/otherlibs/labltk/builtin/canvas_bind.mli
@@ -0,0 +1,2 @@
+val bind : canvas widget -> tag: tagOrId -> 
+           events: (modifier list * xEvent) list -> action: bindAction -> unit 
diff --git a/otherlibs/labltk/builtin/dialog.ml b/otherlibs/labltk/builtin/dialog.ml
new file mode 100644
index 000000000..9b5e06fbf
--- /dev/null
+++ b/otherlibs/labltk/builtin/dialog.ml
@@ -0,0 +1,12 @@
+let create :parent :title :message :buttons ?:name
+    ?:bitmap{=`Predefined ""} ?:default{= -1} () =
+  let w = Widget.new_atom "toplevel" ?:name :parent in
+  let res = tkEval [|TkToken"tk_dialog";
+                     cCAMLtoTKwidget w;
+                     TkToken title;
+                     TkToken message;
+                     cCAMLtoTKbitmap bitmap;
+                     TkToken (string_of_int default);
+                     TkTokenList (List.map fun:(fun x -> TkToken x) buttons)|]
+   in
+    int_of_string res
diff --git a/otherlibs/labltk/builtin/dialog.mli b/otherlibs/labltk/builtin/dialog.mli
new file mode 100644
index 000000000..d0f6398c3
--- /dev/null
+++ b/otherlibs/labltk/builtin/dialog.mli
@@ -0,0 +1,8 @@
+val create : 
+  parent: 'a widget ->
+  title: string ->
+  message: string ->
+  buttons: string list ->
+  ?name: string -> ?bitmap: bitmap -> ?default: int -> unit ->int 
+  (* [create title message bitmap default button_names parent] 
+     cf. tk_dialog *)
diff --git a/otherlibs/labltk/builtin/optionmenu.ml b/otherlibs/labltk/builtin/optionmenu.ml
new file mode 100644
index 000000000..c4090d25a
--- /dev/null
+++ b/otherlibs/labltk/builtin/optionmenu.ml
@@ -0,0 +1,16 @@
+open Protocol
+(* Implementation of the tk_optionMenu *)
+
+let create :parent :variable ?:name values =
+  let w = Widget.new_atom "menubutton" :parent ?:name in
+  let mw = Widget.new_atom "menu" parent:w name:"menu" in 
+  (* assumes .menu naming *)
+  let res = 
+     tkEval [|TkToken "tk_optionMenu";
+              TkToken (Widget.name w);
+              cCAMLtoTKtextVariable variable;
+              TkTokenList (List.map fun:(fun x -> TkToken x) values)|] in
+   if res <> Widget.name mw then
+     raise (TkError "internal error in Optionmenu.create")
+   else
+     w,mw
diff --git a/otherlibs/labltk/builtin/optionmenu.mli b/otherlibs/labltk/builtin/optionmenu.mli
new file mode 100644
index 000000000..46a9051f0
--- /dev/null
+++ b/otherlibs/labltk/builtin/optionmenu.mli
@@ -0,0 +1,7 @@
+(* Support for tk_optionMenu *)
+val create: parent:'a widget -> variable:textVariable ->
+            ?name: string -> string list -> menubutton widget * menu widget
+              (* [create parent var options] creates a multi-option 
+                 menubutton and its associated menu. The option is also stored
+                 in the variable. Both widgets (menubutton and menu) are
+                 returned *)
diff --git a/otherlibs/labltk/builtin/selection_handle_set.ml b/otherlibs/labltk/builtin/selection_handle_set.ml
new file mode 100644
index 000000000..33a2baec0
--- /dev/null
+++ b/otherlibs/labltk/builtin/selection_handle_set.ml
@@ -0,0 +1,15 @@
+(* The function *must* use tkreturn *)
+let handle_set command: cmd =
+selection_handle_icccm_optionals (fun opts w ->
+tkEval [|TkToken"selection";
+         TkToken"handle";
+         TkTokenList 
+           (List.map opts fun:(cCAMLtoTKselection_handle_icccm w));
+         cCAMLtoTKwidget w;
+         let id = register_callback w callback:(function args ->
+           let a1 = int_of_string (List.hd args) in
+           let a2 = int_of_string (List.nth args pos:1) in
+           tkreturn (cmd pos:a1 len:a2)) in TkToken ("camlcb "^id)
+       |];
+  ())
+
diff --git a/otherlibs/labltk/builtin/selection_handle_set.mli b/otherlibs/labltk/builtin/selection_handle_set.mli
new file mode 100644
index 000000000..d1d996399
--- /dev/null
+++ b/otherlibs/labltk/builtin/selection_handle_set.mli
@@ -0,0 +1,4 @@
+val handle_set :
+    command: (pos:int -> len:int -> string) -> 
+    ?format: string -> ?selection:string -> ?type: string -> 'a widget -> unit
+(* tk invocation: selection handle <icccm list> <widget> <command> *)
diff --git a/otherlibs/labltk/builtin/selection_own_set.ml b/otherlibs/labltk/builtin/selection_own_set.ml
new file mode 100644
index 000000000..d851b85dc
--- /dev/null
+++ b/otherlibs/labltk/builtin/selection_own_set.ml
@@ -0,0 +1,13 @@
+(* builtin to handle callback association to widget *)
+let own_set ?:command =
+selection_ownset_icccm_optionals ?:command (fun opts w ->
+tkEval [|TkToken"selection";
+         TkToken"own";
+         TkTokenList 
+           (List.map 
+             fun:(function x -> 
+               cCAMLtoTKselection_ownset_icccm w x)
+             opts);
+        cCAMLtoTKwidget w|];
+())
+
diff --git a/otherlibs/labltk/builtin/selection_own_set.mli b/otherlibs/labltk/builtin/selection_own_set.mli
new file mode 100644
index 000000000..d05450903
--- /dev/null
+++ b/otherlibs/labltk/builtin/selection_own_set.mli
@@ -0,0 +1,3 @@
+val own_set :
+    ?command:(unit->unit) -> ?selection:string -> 'a widget -> unit 
+(* tk invocation: selection own <icccm list> <widget> *)
diff --git a/otherlibs/labltk/builtin/text_tag_bind.ml b/otherlibs/labltk/builtin/text_tag_bind.ml
new file mode 100644
index 000000000..2abb30a18
--- /dev/null
+++ b/otherlibs/labltk/builtin/text_tag_bind.ml
@@ -0,0 +1,22 @@
+let tag_bind widget :tag events:eventsequence :action =
+  tkEval [| cCAMLtoTKwidget widget;
+            TkToken "tag";
+            TkToken "bind";
+            cCAMLtoTKtextTag tag;
+            cCAMLtoTKeventSequence eventsequence;
+  begin match action with
+     `Remove -> TkToken ""
+  |  `Set (what, f) ->
+      let cbId = register_callback widget callback:(wrapeventInfo f what) in
+        TkToken ("camlcb " ^ cbId ^ (writeeventField what))
+  |  `Setbreakable (what, f) ->
+      let cbId = register_callback widget callback:(wrapeventInfo f what) in
+        TkToken ("camlcb " ^ cbId ^ (writeeventField what)^
+                 " ; if { $BreakBindingsSequence == 1 } then { break ;} ; set BreakBindingsSequence 0"
+                )
+  |  `Extend (what, f) ->
+      let cbId = register_callback widget callback:(wrapeventInfo f what) in
+        TkToken ("+camlcb " ^ cbId ^ (writeeventField what))
+  end
+  |];
+  ()
diff --git a/otherlibs/labltk/builtin/text_tag_bind.mli b/otherlibs/labltk/builtin/text_tag_bind.mli
new file mode 100644
index 000000000..c78a35e62
--- /dev/null
+++ b/otherlibs/labltk/builtin/text_tag_bind.mli
@@ -0,0 +1,2 @@
+val tag_bind: text widget -> tag:textTag ->
+      events:(modifier list * xEvent) list -> action: bindAction -> unit 
diff --git a/otherlibs/labltk/builtin/winfo_contained.ml b/otherlibs/labltk/builtin/winfo_contained.ml
new file mode 100644
index 000000000..76df1025f
--- /dev/null
+++ b/otherlibs/labltk/builtin/winfo_contained.ml
@@ -0,0 +1,2 @@
+let contained :x :y w =
+  forget_type w = containing :x :y ()
diff --git a/otherlibs/labltk/builtin/winfo_contained.mli b/otherlibs/labltk/builtin/winfo_contained.mli
new file mode 100644
index 000000000..0baf36ebd
--- /dev/null
+++ b/otherlibs/labltk/builtin/winfo_contained.mli
@@ -0,0 +1,2 @@
+val contained : x:int -> y:int -> 'a widget -> bool
+(* [contained x y w] returns true if (x,y) is in w *)
author	Jacques Garrigue <garrigue at math.nagoya-u.ac.jp>	1999-11-30 14:59:39 +0000
committer	Jacques Garrigue <garrigue at math.nagoya-u.ac.jp>	1999-11-30 14:59:39 +0000
commit	ca0b21c5adbe660a52e5a9dfe1dda16985fe5f7c (patch)
tree	e202ba49531807a7a6c2bd46f37b2bbbeb170d0f /otherlibs/labltk/builtin
parent	68ba9a8c42b0197bc415de2f81aa6d0c8e84780a (diff)