10 files changed, 1200 insertions, 0 deletions

diff --git a/otherlibs/labltk/example/Lambda2.back.gif b/otherlibs/labltk/example/Lambda2.back.gif
new file mode 100644
index 000000000..7cb3d2c13
--- /dev/null
+++ b/otherlibs/labltk/example/Lambda2.back.gif
diff --git a/otherlibs/labltk/example/Makefile b/otherlibs/labltk/example/Makefile
new file mode 100644
index 000000000..c30d2aa38
--- /dev/null
+++ b/otherlibs/labltk/example/Makefile
@@ -0,0 +1,46 @@
+include ../Makefile.config
+
+COMPFLAGS=-I ../lib -I ../support 
+
+TKLINKOPT= -ccopt -L../support -cclib -llabltk41 $(TKLIBS) $(X11_LIBS)
+
+all: hello demo eyes calc clock tetris
+
+opt: hello.opt demo.opt eyes.opt calc.opt tetris.opt
+
+hello: hello.cmo
+	$(LABLC) -custom $(COMPFLAGS) -o hello tk41.cma hello.cmo $(TKLINKOPT)
+
+demo: demo.cmo
+	$(LABLC) -custom $(COMPFLAGS) -o demo tk41.cma demo.cmo $(TKLINKOPT)
+
+eyes: eyes.cmo
+	$(LABLC) -custom $(COMPFLAGS) -o eyes tk41.cma eyes.cmo $(TKLINKOPT)
+
+calc: calc.cmo
+	$(LABLC) -custom $(COMPFLAGS) -o calc tk41.cma calc.cmo $(TKLINKOPT)
+
+clock: clock.cmo
+	$(LABLC) -custom $(COMPFLAGS) -o clock tk41.cma unix.cma clock.cmo \
+	      $(TKLINKOPT) -cclib -lunix
+
+tetris: tetris.cmo
+	$(LABLC) -custom $(COMPFLAGS) -o tetris tk41.cma tetris.cmo $(TKLINKOPT)
+
+clean:
+	rm -f hello demo eyes calc clock tetris *.opt *.o *.cm*
+
+.SUFFIXES :
+.SUFFIXES : .mli .ml .cmi .cmx .cmo .opt
+
+.mli.cmi:
+	$(LABLCOMP) $(COMPFLAGS) $<
+
+.ml.cmo:
+	$(LABLCOMP) $(COMPFLAGS) $<
+
+.ml.cmx:
+	$(CAMLOPT) -c $(COMPFLAGS) $<
+
+.cmx.opt:
+	labltkopt $(COMPFLAGS) -o $@ $<
diff --git a/otherlibs/labltk/example/README b/otherlibs/labltk/example/README
new file mode 100644
index 000000000..71bbaca79
--- /dev/null
+++ b/otherlibs/labltk/example/README
@@ -0,0 +1,18 @@
+$Id$
+
+Some examples for LablTk. They must be compiled with the -modern
+option, except for hello.ml and calc.ml.
+
+hello.ml	A very simple example of CamlTk 
+hello.tcl	The same programme in Tcl/Tk
+
+demo.ml		A demonstration using many widget classes
+
+eyes.ml		A "bind" test
+
+calc.ml		A little calculator
+
+clock.ml	An analog clock
+
+tetris.ml	You NEED a game also. Edit it to set a background
+
diff --git a/otherlibs/labltk/example/calc.ml b/otherlibs/labltk/example/calc.ml
new file mode 100644
index 000000000..a330a9ecb
--- /dev/null
+++ b/otherlibs/labltk/example/calc.ml
@@ -0,0 +1,112 @@
+(* $Id$ *)
+
+(* A simple calculator demonstrating OO programming with O'Labl
+   and LablTk.
+
+   LablTk itself is not OO, but it is good to wrap complex
+   structures in objects. Even if the absence of initializers
+   makes things a little bit awkward.
+*)
+
+open Tk
+
+let mem_string elt:c s =
+  try
+    for i = 0 to String.length s -1 do
+      if s.[i] = c then raise Exit
+    done; false
+  with Exit -> true
+
+let ops = ['+',(+.); '-',(-.); '*',( *.); '/',(/.)]
+
+(* The abstract calculator class.
+   Does not use Tk (only Textvariable) *)
+
+class calc () = object (calc)
+  val variable = Textvariable.create ()
+  val mutable x = 0.0
+  val mutable op = None
+  val mutable displaying = true
+
+  method set = Textvariable.set variable
+  method get = Textvariable.get variable
+  method insert s = calc#set to:(calc#get ^ s)
+  method get_float = float_of_string (calc#get)
+
+  method command s =
+    if s <> "" then match s.[0] with
+      '0'..'9' ->
+	if displaying then (calc#set to:""; displaying <- false);
+	calc#insert s
+    | '.' ->
+	if displaying then
+	  (calc#set to:"0."; displaying <- false)
+	else
+	  if not (mem_string elt:'.' calc#get) then calc#insert s
+    | '+'|'-'|'*'|'/' as c ->
+	displaying <- true;
+	begin match op with
+	  None ->
+	    x <- calc#get_float;
+	    op <- Some (List.assoc key:c ops)
+	| Some f ->
+	    x <- f x (calc#get_float);
+	    op <- Some (List.assoc key:c ops);
+	    calc#set to:(string_of_float x)
+	end
+    | '='|'\n'|'\r' ->
+	displaying <- true;
+	begin match op with
+	  None -> ()
+	| Some f ->
+	    x <- f x (calc#get_float);
+	    op <- None;
+	    calc#set to:(string_of_float x)
+	end
+    | 'q' -> closeTk (); exit 0
+    | _ -> ()
+end
+
+(* Buttons for the calculator *)
+
+let m =
+  [|["7";"8";"9";"+"];
+    ["4";"5";"6";"-"];
+    ["1";"2";"3";"*"];
+    ["0";".";"=";"/"]|]
+
+(* The physical calculator. Inherits from the abstract one *)
+
+class calculator :parent = object
+  inherit calc () as calc
+
+  val label = Label.create :parent anchor:`E relief:`Sunken padx:(`Pix 10) ()
+  val frame = Frame.create :parent ()
+
+  initializer
+    let buttons =
+      Array.map fun:
+	(List.map fun:
+	   (fun text ->
+	     Button.create parent:frame :text
+	       command:(fun () -> calc#command text) ()))
+	m
+    in
+    Label.configure textvariable:variable label;
+    calc#set to:"0";
+    bind parent events:[[],`KeyPress]
+      action:(`Set([`Char],fun ev -> calc#command ev.ev_Char));
+    for i = 0 to Array.length m - 1 do
+      Grid.configure row:i buttons.(i)
+    done;
+    pack side:`Top fill:`X [label];
+    pack side:`Bottom fill:`Both expand:true [frame];
+end
+
+(* Finally start everything *)
+
+let top = openTk ()
+
+let applet = new calculator parent:top
+
+let _ = mainLoop ()
diff --git a/otherlibs/labltk/example/clock.ml b/otherlibs/labltk/example/clock.ml
new file mode 100644
index 000000000..0aa0ab74d
--- /dev/null
+++ b/otherlibs/labltk/example/clock.ml
@@ -0,0 +1,115 @@
+(* $Id$ *)
+
+(* Clock/V, a simple clock.
+   Reverts every time you push the right button.
+   Adapted from ASCII/V May 1997
+
+   Uses Tk and Unix, so you must link with
+     labltklink unix.cma clock.ml -o clock -cclib -lunix
+*)
+
+open Tk
+
+(* pi is not a constant! *)
+let pi = acos (-1.)
+
+(* The main class:
+     * create it with a parent: [new clock parent:top]
+     * initialize with [#init]
+*)
+
+class clock :parent = object (self)
+
+  (* Instance variables *)
+  val canvas = Canvas.create :parent width:(`Pix 100) height:(`Pix 100) ()
+  val mutable height = 100
+  val mutable width = 100
+  val mutable rflag = -1
+
+  (* Convert from -1.0 .. 1.0 to actual positions on the canvas *)
+  method x x0 = `Pix (truncate (float width *. (x0 +. 1.) /. 2.))
+  method y y0 = `Pix (truncate (float height *. (y0 +. 1.) /. 2.))
+
+  initializer
+    (* Create the oval border *)
+    Canvas.create_oval canvas tags:[`Tag "cadran"]
+      x1:(`Pix 1) y1:(`Pix 1)
+      x2:(`Pix (width - 2)) y2:(`Pix (height - 2))
+      width:(`Pix 3) outline:(`Yellow) fill:`White;
+    (* Draw the figures *)
+    self#draw_figures;
+    (* Create the arrows with dummy position *)
+    Canvas.create_line canvas tags:[`Tag "hours"] fill:`Red
+      xys:[self#x 0.; self#y 0.; self#x 0.; self#y 0.];
+    Canvas.create_line canvas tags:[`Tag "minutes"] fill:`Blue
+      xys:[self#x 0.; self#y 0.; self#x 0.; self#y 0.];
+    Canvas.create_line canvas tags:[`Tag "seconds"] fill:`Black
+      xys:[self#x 0.; self#y 0.; self#x 0.; self#y 0.];
+    (* Setup a timer every second *)
+    let rec timer () =
+      self#draw_arrows (Unix.localtime (Unix.time ()));
+      Timer.add ms:1000 callback:timer; ()
+    in timer ();
+    (* Redraw when configured (changes size) *)
+    bind canvas events:[[],`Configure]
+      action:(`Set ([], fun _ ->
+	width <- Winfo.width canvas;
+	height <- Winfo.height canvas;
+	self#redraw));
+    (* Change direction with right button *)
+    bind canvas events:[[],`ButtonPressDetail 3]
+      action:(`Set ([], fun _ -> rflag <- -rflag; self#redraw));
+    (* Pack, expanding in both directions *)
+    pack [canvas] fill:`Both expand:true
+
+  (* Redraw everything *)
+  method redraw =
+    Canvas.coords_set canvas tag:(`Tag "cadran")
+      coords:[ `Pix 1; `Pix 1;
+	       `Pix (width - 2); `Pix (height - 2) ];
+    self#draw_figures;
+    self#draw_arrows (Unix.localtime (Unix.time ()))
+
+  (* Delete and redraw the figures *)
+  method draw_figures =
+    Canvas.delete canvas tags:[`Tag "figures"];
+    for i = 1 to 12 do
+      let angle = float (rflag * i - 3) *. pi /. 6. in
+      Canvas.create_text canvas tags:[`Tag "figures"]
+	text:(string_of_int i) font:"variable"
+	x:(self#x (0.8 *. cos angle))
+	y:(self#y (0.8 *. sin angle))
+	anchor:`Center
+    done
+
+  (* Resize and reposition the arrows *)
+  method draw_arrows tm =
+    Canvas.configure_line canvas tag:(`Tag "hours")
+      width:(`Pix (min width height / 40));
+    let hangle =
+      float (rflag * (tm.Unix.tm_hour * 60 + tm.Unix.tm_min) - 180)
+	*. pi /. 360. in
+    Canvas.coords_set canvas tag:(`Tag "hours")
+      coords:[ self#x 0.; self#y 0.;
+	       self#x (cos hangle /. 2.); self#y (sin hangle /. 2.) ];
+    Canvas.configure_line canvas tag:(`Tag "minutes")
+      width:(`Pix (min width height / 50));
+    let mangle = float (rflag * tm.Unix.tm_min - 15) *. pi /. 30. in
+    Canvas.coords_set canvas tag:(`Tag "minutes")
+      coords:[ self#x 0.; self#y 0.;
+	       self#x (cos mangle /. 1.5); self#y (sin mangle /. 1.5) ];
+    let sangle = float (rflag * tm.Unix.tm_sec - 15) *. pi /. 30. in
+    Canvas.coords_set canvas tag:(`Tag "seconds")
+      coords:[ self#x 0.; self#y 0.;
+	       self#x (cos sangle /. 1.25); self#y (sin sangle /. 1.25) ]
+end
+
+(* Initialize the Tcl interpreter *)
+let top = openTk ()
+
+(* Create a clock on the main window *)
+let clock =
+  new clock parent:top
+
+(* Wait for events *)
+let _ = mainLoop ()
diff --git a/otherlibs/labltk/example/demo.ml b/otherlibs/labltk/example/demo.ml
new file mode 100644
index 000000000..897d4b9e4
--- /dev/null
+++ b/otherlibs/labltk/example/demo.ml
@@ -0,0 +1,150 @@
+(* Some CamlTk4 Demonstration by JPF *)
+
+(* First, open these modules for convenience *)
+open Tk
+
+(* Dummy let *)
+let _ =
+
+(* Initialize Tk *)
+let top = openTk () in 
+(* Title setting *)
+Wm.title_set top title:"LablTk demo";
+
+(* Base frame *)
+let base = Frame.create parent:top () in
+pack [base];
+
+(* Menu bar *)
+let bar =
+  Frame.create parent: base borderwidth: (`Pix 2) relief: `Raised  () in 
+pack [bar] fill: `X;
+
+  (* Menu and Menubutton *)
+  let meb = Menubutton.create parent: bar text: "Menu" () in
+  let men = Menu.create parent: meb () in
+  Menu.add_command men label: "Quit" command: (fun () -> closeTk (); exit 0);
+  Menubutton.configure meb menu: men; 
+  
+  (* Frames *)
+  let base2 = Frame.create parent:base () in
+  let left = Frame.create parent:base2 () in
+  let right = Frame.create parent:base2 () in
+  pack [base2];
+  pack [left; right] side: `Left;
+  
+    (* Widgets on left and right *)
+    
+    (* Button *)
+    let but = Button.create parent: left text: "Welcome to LablTk" () in
+    
+    (* Canvas *)
+    let can = Canvas.create parent: left width: (`Pix 100) 
+      height: (`Pix 100) borderwidth: (`Pix 1) relief: `Sunken ()
+    in
+    Canvas.create_oval can x1:(`Pix 10) y1:(`Pix 10) 
+                           x2:(`Pix 90) y2:(`Pix 90)
+      	                   fill:`Red; 
+
+    (* Check button *)
+    let che = Checkbutton.create parent: left text: "Check" () in
+    
+    (* Entry *)
+    let ent = Entry.create parent: left width: 10 () in 
+    
+    (* Label *)
+    let lab = Label.create parent: left text: "Welcome to LablTk" () in
+    
+    (* Listbox *)
+    let lis = Listbox.create parent: left () in
+    Listbox.insert lis index: `End texts: ["This"; "is"; "Listbox"];
+    
+    (* Message *)
+    let mes = Message.create parent: left ()
+      text: "Hello this is a message widget with very long text, but ..." in
+    
+    (* Radio buttons *)
+    let tv = Textvariable.create () in
+    Textvariable.set tv to: "One";
+    let radf = Frame.create parent: right () in
+    let rads = List.map fun:(fun t ->
+      Radiobutton.create parent: radf text: t value: t variable: tv ())
+  	["One"; "Two"; "Three"] in
+    
+    (* Scale *)
+    let sca = Scale.create parent:right label: "Scale" length: (`Pix 100) 
+      showvalue: true () in
+    
+    (* Text and scrollbar *)
+    let texf = Frame.create parent:right () in 
+    
+      (* Text *)
+      let tex = Text.create parent:texf width: 20 height: 8 () in
+      Text.insert tex text: "This is a text widget." index: (`End,[])
+      	 tags: [];
+      
+      (* Scrollbar *)
+      let scr = Scrollbar.create parent:texf () in
+      
+      (* Text and Scrollbar widget link *)
+      let scroll_link sb tx =
+      	Text.configure tx yscrollcommand: (Scrollbar.set sb);
+      	Scrollbar.configure sb command: (Text.yview tx) in
+      scroll_link scr tex;
+      
+      pack [scr] side: `Right fill: `Y;
+      pack [tex] side: `Left fill: `Both expand: true;
+       
+    (* Pack them *)
+    pack [meb] side: `Left;
+    pack [coe but; coe can; coe che; coe ent; coe lab; coe lis; coe mes]; 
+    pack [coe radf; coe sca; coe texf];
+    pack rads;
+
+  (* Toplevel *)
+  let top2 = Toplevel.create parent:top () in
+  Wm.title_set top2 title:"LablTk demo control";
+  let defcol = `Color "#dfdfdf" in
+  let selcol = `Color "#ffdfdf" in
+  let buttons = 
+    List.map fun:(fun (w, t, c, a) ->
+        let b = Button.create parent:top2 text:t command:c () in
+        bind b events: [[], `Enter] 
+               action:(`Set ([], fun _ -> a selcol));
+        bind b events: [[], `Leave] 
+               action:(`Set ([], fun _ -> a defcol));
+        b)
+      [coe bar, "Frame", (fun () -> ()),
+       (fun background -> Frame.configure bar :background);
+       coe meb, "Menubutton", (fun () -> ()),
+       (fun background -> Menubutton.configure meb :background);
+       coe but, "Button", (fun () -> ()),
+       (fun background -> Button.configure but :background);
+       coe can, "Canvas", (fun () -> ()),
+       (fun background -> Canvas.configure can :background);
+       coe che, "CheckButton", (fun () -> ()),
+       (fun background -> Checkbutton.configure che :background);
+       coe ent, "Entry", (fun () -> ()),
+       (fun background -> Entry.configure ent :background);
+       coe lab, "Label", (fun () -> ()),
+       (fun background -> Label.configure lab :background);
+       coe lis, "Listbox", (fun () -> ()),
+       (fun background -> Listbox.configure lis :background);
+       coe mes, "Message", (fun () -> ()),
+       (fun background -> Message.configure mes :background);
+       coe radf, "Radiobox", (fun () -> ()),
+       (fun background ->
+      	 List.iter rads fun:(fun b -> Radiobutton.configure b :background));
+       coe sca, "Scale", (fun () -> ()),
+       (fun background -> Scale.configure sca :background);
+       coe tex, "Text", (fun () -> ()),
+       (fun background -> Text.configure tex :background);
+       coe scr, "Scrollbar", (fun () -> ()),
+       (fun background -> Scrollbar.configure scr :background)
+      ]
+  in
+    pack buttons fill: `X;
+
+(* Main Loop *)
+Printexc.print mainLoop () 
+
diff --git a/otherlibs/labltk/example/eyes.ml b/otherlibs/labltk/example/eyes.ml
new file mode 100644
index 000000000..1f281d66c
--- /dev/null
+++ b/otherlibs/labltk/example/eyes.ml
@@ -0,0 +1,43 @@
+open Tk
+
+let _ =
+ let top = openTk () in
+ let fw = Frame.create parent: top () in
+   pack [fw];
+   let c = Canvas.create parent: fw width: (`Pix 200) height: (`Pix 200) () in
+   let create_eye cx cy wx wy ewx ewy bnd =
+     let o2 = Canvas.create_oval c 
+       x1:(`Pix (cx - wx)) y1:(`Pix (cy - wy)) 
+       x2:(`Pix (cx + wx)) y2:(`Pix (cy + wy)) 
+         outline: (`Color "black") width: (`Pix 7) 
+      	 fill: (`Color "white") 
+     and o = Canvas.create_oval c 
+       x1:(`Pix (cx - ewx)) y1:(`Pix (cy - ewy)) 
+       x2:(`Pix (cx + ewx)) y2:(`Pix (cy + ewy)) 
+      	   fill: (`Color "black") in
+     let curx = ref cx
+     and cury = ref cy in
+       bind c events:[[], `Motion]
+         action: (`Extend ([`MouseX; `MouseY], (fun e ->
+       	   let nx, ny =
+      	     let xdiff = e.ev_MouseX - cx 
+	     and ydiff = e.ev_MouseY - cy in
+	     let diff = sqrt (((float xdiff) /. ((float wx) *. bnd)) ** 2.0 +. 
+               ((float ydiff) /. ((float wy) *. bnd)) ** 2.0) in
+	     if diff > 1.0 then
+      	       truncate ((float xdiff) *. (1.0 /. diff)) + cx,
+	       truncate ((float ydiff) *. (1.0 /. diff)) + cy
+	     else 
+               e.ev_MouseX, e.ev_MouseY
+	 in
+	   Canvas.move c tag: o 
+	     x: (`Pix (nx - !curx)) y: (`Pix (ny - !cury));
+	   curx := nx;
+	   cury := ny)))
+  in
+     create_eye 60 100 30 40 5 6 0.6;
+     create_eye 140 100 30 40 5 6 0.6;
+     pack [c] 
+
+let _ = Printexc.print mainLoop ()
+
diff --git a/otherlibs/labltk/example/hello.ml b/otherlibs/labltk/example/hello.ml
new file mode 100644
index 000000000..5e890aada
--- /dev/null
+++ b/otherlibs/labltk/example/hello.ml
@@ -0,0 +1,20 @@
+(* LablTk4 Demonstration by JPF *)
+
+(* First, open this modules for convenience *)
+open Tk
+
+(* initialization of Tk --- the result is a toplevel widget *)
+let top = openTk () 
+
+(* create a button on top *)
+(* Button.create : use of create function defined in button.ml *)
+(* But you shouldn't open Button module for other widget class modules use *)
+let b = Button.create parent: top text: "Hello, LablTk!" ()
+
+(* Lack of toplevel expressions in lsl, you must use dummy let exp. *)
+let _ = pack [coe b] 
+
+(* Last, you must call mainLoop *)
+(* You can write just let _ = mainLoop () *)
+(* But Printexc.print will help you *)
+let _ = Printexc.print mainLoop ()
diff --git a/otherlibs/labltk/example/hello.tcl b/otherlibs/labltk/example/hello.tcl
new file mode 100755
index 000000000..9e9985c15
--- /dev/null
+++ b/otherlibs/labltk/example/hello.tcl
@@ -0,0 +1,5 @@
+#!/usr/local/bin/wish4.0
+
+button .hello -text "Hello, TclTk!"
+
+pack .hello
diff --git a/otherlibs/labltk/example/tetris.ml b/otherlibs/labltk/example/tetris.ml
new file mode 100644
index 000000000..bfc60db07
--- /dev/null
+++ b/otherlibs/labltk/example/tetris.ml
@@ -0,0 +1,691 @@
+(* tetris.ml : a Tetris game for LablTk *)
+(* written by Jun P. Furuse             *)
+
+open Tk
+
+exception Done
+
+type falling_block = {
+    mutable pattern: int array list;
+    mutable bcolor: int;
+    mutable x: int;
+    mutable y: int;
+    mutable d: int;
+    mutable alive: bool
+  }
+
+let stop_a_bit = 300
+
+let field_width = 10
+let field_height = 20
+
+let colors = [|
+  `Color "red";
+  `Color "yellow";
+
+  `Color "blue";
+  `Color "orange";
+
+  `Color "magenta";
+  `Color "green";
+
+  `Color "cyan"
+|]
+
+(* Put here your favorite image files *)
+let backgrounds = [
+  "Lambda2.back.gif"
+]
+
+(* blocks *)
+let block_size = 16
+let cell_border = 2
+
+let blocks = [
+  [ [|"0000";
+      "0000";
+      "1111";
+      "0000" |];
+
+    [|"0010";
+      "0010";
+      "0010";
+      "0010" |];
+
+    [|"0000";
+      "0000";
+      "1111";
+      "0000" |];
+
+    [|"0010";
+      "0010";
+      "0010";
+      "0010" |] ];
+
+  [ [|"0000";
+      "0110";
+      "0110";
+      "0000" |];
+
+    [|"0000";
+      "0110";
+      "0110";
+      "0000" |];
+
+    [|"0000";
+      "0110";
+      "0110";
+      "0000" |];
+
+    [|"0000";
+      "0110";
+      "0110";
+      "0000" |] ];
+
+  [ [|"0000";
+      "0111";
+      "0100";
+      "0000" |]; 
+
+    [|"0000";
+      "0110";
+      "0010";
+      "0010" |];
+
+    [|"0000";
+      "0010";
+      "1110";
+      "0000" |];
+
+    [|"0100";
+      "0100";
+      "0110";
+      "0000" |] ];
+
+  [ [|"0000";
+      "0100";
+      "0111";
+      "0000" |]; 
+
+    [|"0000";
+      "0110";
+      "0100";
+      "0100" |];
+
+    [|"0000";
+      "1110";
+      "0010";
+      "0000" |];
+
+    [|"0010";
+      "0010";
+      "0110";
+      "0000" |] ];
+
+  [ [|"0000";
+      "1100";
+      "0110";
+      "0000" |];
+
+    [|"0010";
+      "0110";
+      "0100";
+      "0000" |];
+
+    [|"0000";
+      "1100";
+      "0110";
+      "0000" |];
+
+    [|"0010";
+      "0110";
+      "0100";
+      "0000" |] ];
+
+  [ [|"0000";
+      "0011";
+      "0110";
+      "0000" |];
+
+    [|"0100";
+      "0110";
+      "0010";
+      "0000" |];
+
+    [|"0000";
+      "0011";
+      "0110";
+      "0000" |];
+
+    [|"0000";
+      "0100";
+      "0110";
+      "0010" |] ];
+
+  [ [|"0000";
+      "0000";
+      "1110";
+      "0100" |];
+
+    [|"0000";
+      "0100";
+      "1100";
+      "0100" |];
+
+    [|"0000";
+      "0100";
+      "1110";
+      "0000" |];
+
+    [|"0000";
+      "0100";
+      "0110";
+      "0100" |] ]
+
+]
+
+let line_empty = int_of_string "0b1110000000000111"
+let line_full = int_of_string  "0b1111111111111111"
+
+let decode_block dvec =
+  let btoi d = int_of_string ("0b"^d) in
+  Array.map fun:btoi dvec
+
+class cell t1 t2 t3 :canvas :x :y = object
+  val mutable color = 0
+  method get = color
+  method set color:col =
+    if color = col then () else
+    if color <> 0 & col = 0 then begin
+      Canvas.move canvas tag: t1
+	x:(`Pix (- block_size * (x + 1) -10 - cell_border * 2))
+	y:(`Pix (- block_size * (y + 1) -10 - cell_border * 2));
+      Canvas.move canvas tag: t2
+	x:(`Pix (- block_size * (x + 1) -10 - cell_border * 2))
+	y:(`Pix (- block_size * (y + 1) -10 - cell_border * 2));
+      Canvas.move canvas tag: t3
+	x:(`Pix (- block_size * (x + 1) -10 - cell_border * 2))
+	y:(`Pix (- block_size * (y + 1) -10 - cell_border * 2))
+    end else begin
+      Canvas.configure_rectangle canvas tag: t2
+	fill: colors.(col - 1)
+	outline: colors.(col - 1);
+      Canvas.configure_rectangle canvas tag: t1
+	fill: `Black
+	outline: `Black;
+      Canvas.configure_rectangle canvas tag: t3
+	fill: (`Color "light gray")
+	outline: (`Color "light gray");
+      if color = 0 & col <> 0 then begin
+	Canvas.move canvas tag: t1
+      	  x: (`Pix (block_size * (x+1)+10+ cell_border*2))
+          y: (`Pix (block_size * (y+1)+10+ cell_border*2));
+	Canvas.move canvas tag: t2
+          x: (`Pix (block_size * (x+1)+10+ cell_border*2))
+          y: (`Pix (block_size * (y+1)+10+ cell_border*2));
+	Canvas.move canvas tag: t3
+          x: (`Pix (block_size * (x+1)+10+ cell_border*2))
+          y: (`Pix (block_size * (y+1)+10+ cell_border*2))
+      end     
+    end;
+    color <- col
+end
+    
+let cell_get (c, cf) x y = cf.(y).(x) #get
+
+let cell_set (c, cf) :x :y :color =
+  if x >= 0 & y >= 0 & Array.length cf > y & Array.length cf.(y) > x then
+    let cur = cf.(y).(x) in
+    if cur#get = color then () else cur#set :color
+
+let create_base_matrix :cols :rows =
+  let m = Array.create_matrix dimx:rows dimy:cols (0,0) in
+  for x = 0 to cols - 1 do for y = 0 to rows - 1 do
+    m.(y).(x) <- (x,y)
+  done done;
+  m
+
+let init fw =
+  let scorev = Textvariable.create ()
+  and linev = Textvariable.create ()
+  and levv = Textvariable.create ()
+  and namev = Textvariable.create ()
+  in
+  let f = Frame.create parent: fw borderwidth: (`Pix 2) () in
+  let c = Canvas.create parent: f width: (`Pix (block_size * 10))
+			          height: (`Pix (block_size * 20))
+				  borderwidth: (`Pix cell_border)
+				  relief: `Sunken
+				  background: `Black ()
+  and r = Frame.create parent:f ()
+  and r' = Frame.create parent:f () in
+
+  let nl = Label.create parent:r text: "Next"  font: "variable" () in
+  let nc = Canvas.create parent:r width: (`Pix (block_size * 4))
+                                  height: (`Pix (block_size * 4))
+				  borderwidth: (`Pix cell_border)
+				  relief: `Sunken
+                                  background: `Black () in
+  let scl = Label.create parent: r text: "Score" font: "variable" () in
+  let sc = Label.create parent:r textvariable: scorev font: "variable" () in
+  let lnl = Label.create parent:r text: "Lines" font: "variable" () in
+  let ln = Label.create parent: r textvariable: linev font: "variable" () in
+  let levl = Label.create parent: r text: "Level" font: "variable" () in
+  let lev = Label.create parent: r textvariable: levv font: "variable" () in 
+  let newg = Button.create parent: r text: "New Game" font: "variable" () in
+
+  pack [f];
+  pack [coe c; coe r; coe r'] side: `Left fill: `Y;
+  pack [coe nl; coe nc] side: `Top;
+  pack [coe scl; coe sc; coe lnl; coe ln; coe levl; coe lev; coe newg]
+    side: `Top;
+
+  let cells_src = create_base_matrix cols:field_width rows:field_height in
+  let cells =
+    Array.map cells_src fun:
+      (Array.map fun:
+	 begin fun (x,y) ->
+	   let t1 =
+	     Canvas.create_rectangle c 
+      	       x1:(`Pix (-block_size - 8)) y1:(`Pix (-block_size - 8))
+               x2:(`Pix (-9))              y2:(`Pix (-9))
+	   and t2 =
+	     Canvas.create_rectangle c 
+      	       x1:(`Pix (-block_size - 10)) y1:(`Pix (-block_size - 10))
+               x2:(`Pix (-11))              y2:(`Pix (-11))
+	   and t3 =
+	     Canvas.create_rectangle c
+      	       x1:(`Pix (-block_size - 12)) y1:(`Pix (-block_size - 12))
+               x2:(`Pix (-13))              y2:(`Pix (-13))
+	   in
+	   Canvas.raise c tag: t1;
+	   Canvas.raise c tag: t2;
+	   Canvas.lower c tag: t3;
+	   new cell canvas:c :x :y t1 t2 t3
+	 end)
+  in
+  let nexts_src = create_base_matrix cols:4 rows:4 in
+  let nexts =
+    Array.map nexts_src fun:
+      (Array.map fun:
+	 begin fun (x,y) ->
+	   let t1 =
+	     Canvas.create_rectangle nc 
+      	       x1:(`Pix (-block_size - 8)) y1:(`Pix (-block_size - 8))
+               x2:(`Pix (-9))              y2:(`Pix (-9))
+	   and t2 =
+	     Canvas.create_rectangle nc 
+      	       x1:(`Pix (-block_size - 10)) y1:(`Pix (-block_size - 10))
+               x2:(`Pix (-11))              y2:(`Pix (-11))
+	   and t3 =
+	     Canvas.create_rectangle nc 
+      	       x1:(`Pix (-block_size - 12)) y1:(`Pix (-block_size - 12))
+               x2:(`Pix (-13))              y2:(`Pix (-13))
+	   in
+	   Canvas.raise nc tag: t1;
+	   Canvas.raise nc tag: t2;
+	   Canvas.lower nc tag: t3;
+	   new cell canvas:nc :x :y t1 t2 t3
+	 end)
+  in
+  let game_over () = ()
+  in
+    (* What a mess ! *)
+  [ coe f; coe c; coe r; coe nl; coe nc; coe scl; coe sc; coe levl; coe lev; 
+    coe lnl; coe ln ],
+  newg, (c, cells), (nc, nexts), scorev, linev, levv, game_over
+  
+
+let draw_block field :color :block :x :y =
+  for iy = 0 to 3 do
+    let base = ref 1 in
+    let xd = block.(iy) in
+    for ix = 0 to 3 do
+      if xd land !base <> 0 then
+      	cell_set field x:(ix + x) y:(iy + y) :color;
+      base := !base lsl 1
+    done
+  done
+
+let timer_ref = (ref None : Timer.t option ref)
+(* I know, this should be timer ref, but I'm not sure what should be 
+   the initial value ... *)
+
+let remove_timer () =
+  match !timer_ref with
+    None -> ()
+  | Some t -> Timer.remove t (* ; prerr_endline "removed!" *)
+
+let do_after ms:milli do:f =
+  timer_ref := Some (Timer.add ms: milli callback: f)
+
+let copy_block c = 
+  { pattern= !c.pattern;
+    bcolor= !c.bcolor;
+    x= !c.x;
+    y= !c.y;
+    d= !c.d;
+    alive= !c.alive } 
+
+let _ =
+  let top = openTk () in
+  let lb = Label.create parent:top ()
+  and fw = Frame.create parent:top ()
+  in
+  let set_message s = Label.configure lb text:s in
+  pack [coe lb; coe fw] side: `Top; 
+  let score = ref 0 in
+  let line = ref 0 in
+  let level = ref 0 in
+  let time = ref 1000 in
+  let blocks = List.map fun:(List.map fun:decode_block) blocks in
+  let field = Array.create len:26 0 in
+  let widgets, button, cell_field, next_field, scorev, linev, levv, game_over
+      = init fw in
+  let canvas = fst cell_field in
+  
+  let init_field () =
+    for i = 0 to 25 do
+      field.(i) <- line_empty
+    done;
+    field.(23) <- line_full;
+    for i = 0 to 19 do
+      for j = 0 to 9 do
+ 	cell_set cell_field x:j y:i color:0
+      done
+    done;
+    for i = 0 to 3 do
+      for j = 0 to 3 do
+ 	cell_set next_field x:j y:i color:0
+      done
+    done 
+  in
+  
+  let draw_falling_block fb =
+    draw_block cell_field color: fb.bcolor 
+      block: (List.nth fb.pattern pos: fb.d) 
+      x:     (fb.x - 3) 
+      y:     (fb.y - 3)
+    
+  and erase_falling_block fb =
+    draw_block cell_field color: 0 
+      block: (List.nth fb.pattern pos: fb.d) 
+      x:     (fb.x - 3) 
+      y:     (fb.y - 3)
+  in
+
+  let stone fb =
+    for i=0 to 3 do
+      let cur = field.(i + fb.y) in
+      field.(i + fb.y) <-
+    	 cur lor ((List.nth fb.pattern pos: fb.d).(i) lsl fb.x)
+    done;
+    for i=0 to 2 do
+      field.(i) <- line_empty
+    done
+
+  and clear fb =
+    let l = ref 0 in
+    for i = 0 to 3 do
+      if i + fb.y >= 3 & i + fb.y <= 22 then 
+    	if field.(i + fb.y) = line_full then
+    	  begin
+	    incr l;
+    	    field.(i + fb.y) <- line_empty;
+    	    for j = 0 to 9 do
+    	      cell_set cell_field x:j y:(i + fb.y - 3) color:0 
+    	    done
+    	  end  
+    done;
+    !l
+    
+  and fall_lines () =
+    let eye = ref 22 (* bottom *)
+    and cur = ref 22 (* bottom *) 
+    in
+    try
+      while !eye >= 3 do
+    	while field.(!eye) = line_empty do
+    	  decr eye;
+    	  if !eye = 2 then raise Done
+    	done;
+    	field.(!cur) <- field.(!eye);
+    	for j = 0 to 9 do
+    	  cell_set cell_field x:j y:(!cur-3) 
+	    color:(cell_get cell_field j (!eye-3))
+    	done;
+    	decr eye;
+    	decr cur 
+      done
+    with Done -> ();
+      for i = 3 to !cur do
+    	field.(i) <- line_empty;
+    	for j = 0 to 9 do
+ 	  cell_set cell_field x:j y:(i-3) color:0
+ 	done
+      done
+  in
+
+  let next = ref 42 (* THE ANSWER *)
+  and current =
+    ref { pattern= [[|0;0;0;0|]]; bcolor=0; x=0; y=0; d=0; alive= false}
+  in
+     
+  let draw_next () =
+    draw_block next_field color: (!next+1) 
+      block: (List.hd (List.nth blocks pos: !next)) 
+      x: 0 y: 0 
+     
+  and erase_next () =
+    draw_block next_field color: 0 
+      block: (List.hd (List.nth blocks pos: !next)) 
+      x: 0 y: 0 
+  in
+
+  let set_nextblock () =
+    current := 
+       { pattern= (List.nth blocks pos: !next);
+ 	 bcolor= !next+1;
+ 	 x=6; y= 1; d= 0; alive= true};
+    erase_next ();
+    next := Random.int 7;
+    draw_next ()
+  in
+ 
+  let death_check fb =
+    try
+      for i=0 to 3 do
+ 	let cur = field.(i + fb.y) in
+ 	if cur land ((List.nth fb.pattern pos: fb.d).(i) lsl fb.x) <> 0 
+ 	then raise Done
+      done;
+      false
+    with 
+      Done -> true
+  in
+    
+  let try_to_move m =
+    if !current.alive then
+      let sub m = 
+ 	if death_check m then false
+ 	else
+ 	  begin
+ 	    erase_falling_block !current;
+ 	    draw_falling_block m;
+ 	    current := m;
+ 	    true
+ 	  end
+      in
+      if sub m then true
+      else 	  
+ 	begin
+ 	  m.x <- m.x + 1;
+ 	  if sub m then true
+ 	  else
+ 	    begin 
+ 	      m.x <- m.x - 2;
+ 	      sub m
+ 	    end  
+ 	end
+    else false 
+  in
+
+  let image_load =
+    let i = Canvas.create_image canvas 
+        x: (`Pix (block_size * 5 + block_size / 2)) 
+      	y: (`Pix (block_size * 10 + block_size / 2))
+        anchor: `Center in
+    Canvas.lower canvas tag: i;
+    let img = Imagephoto.create () in
+    fun file ->
+      try 
+	Imagephoto.configure img file: file;
+	Canvas.configure_image canvas tag: i image: img 
+      with
+	_ -> 
+	  begin
+	    Printf.eprintf "%s : No such image...\n" file;
+	    flush stderr
+	  end
+  in
+
+  let add_score l =
+    let pline = !line in
+    if l <> 0 then
+      begin
+      	line := !line + l; 
+        score := !score + l * l;
+        set_message (Printf.sprintf "%d pts" (1 lsl ((l - 1) * 2)))
+      end; 
+    Textvariable.set linev to: (string_of_int !line);
+    Textvariable.set scorev to: (string_of_int !score); 
+
+    if !line /10 <> pline /10 then 
+       (* undate the background every 10 lines. *)
+      begin
+       	let num_image = List.length backgrounds - 1 in
+        let n = !line/10 in
+      	let n = if n > num_image then num_image else n in
+      	let file = List.nth backgrounds pos: n in
+        image_load file;
+	incr level; 
+        Textvariable.set levv to: (string_of_int !level) 
+      end
+  in
+
+  let rec newblock () = 
+    set_message "TETRIS";
+    set_nextblock ();
+    draw_falling_block !current;
+    if death_check !current then 
+      begin
+        !current.alive <- false;
+        set_message "GAME OVER";
+	game_over ()
+      end
+    else
+      begin
+      	time := 1100 - (!level / 4 * 300) - ((!level mod 4) * 200);
+	if !time < 60 - !level * 3 then time := 60 - !level * 3;
+        do_after ms:stop_a_bit do:loop
+      end
+   
+  and loop () =
+    let m = copy_block current in
+    m.y <- m.y + 1;
+    if death_check m then
+      begin
+        !current.alive <- false;
+        stone !current;
+        do_after ms:stop_a_bit do:
+	  begin fun () ->
+            let l = clear !current in
+            if l > 0 then
+              do_after ms:stop_a_bit do:
+		begin fun () ->
+		  fall_lines ();
+		  add_score l;
+		  do_after ms:stop_a_bit do:newblock
+		end
+            else
+              newblock ()
+	  end
+      end
+    else
+      begin
+        erase_falling_block !current;
+        draw_falling_block m;
+        current := m;
+	do_after ms:!time do:loop
+      end
+  in
+
+  let bind_game w =
+    bind w events:[[],`KeyPress] action:(`Set ([`KeySymString],
+       fun e -> 
+   	 begin match e.ev_KeySymString with
+   	 | "h" ->
+	     let m = copy_block current in
+   	     m.x <- m.x - 1;
+   	     try_to_move m; ()
+   	 | "j" ->
+	     let m = copy_block current in
+   	     m.d <- m.d + 1;
+   	     if m.d = List.length m.pattern then m.d <- 0;
+   	     try_to_move m; ()  
+   	 | "k" ->
+	     let m = copy_block current in
+   	     m.d <- m.d - 1;
+   	     if m.d < 0 then m.d <- List.length m.pattern - 1;
+   	     try_to_move m; ()
+   	 | "l" ->
+	     let m = copy_block current in
+   	     m.x <- m.x + 1;
+   	     try_to_move m; ()
+   	 | "m" ->
+	     remove_timer ();
+   	     loop ()
+   	 | "space" ->
+   	     if !current.alive then
+   	       begin
+   		 let m = copy_block current
+   		 and n = copy_block current in
+   		 while 
+   		   m.y <- m.y + 1;
+   		   if death_check m then false
+   		   else begin n.y <- m.y; true end
+   		 do () done;
+   		 erase_falling_block !current;
+   		 draw_falling_block n;
+   		 current := n;
+   		 remove_timer ();
+   		 loop ()
+   	       end  
+   	 | _ -> ()	    
+   	 end))
+  in
+
+  let game_init () =
+     (* Game Initialization *)
+    set_message "Initializing ...";
+    remove_timer ();
+    image_load (List.hd backgrounds);
+    time := 1000;
+    score := 0;
+    line := 0;
+    level := 1;
+    add_score 0; 
+    init_field ();
+    next := Random.int 7;	
+    set_message "Welcome to TETRIS";
+    set_nextblock ();
+    draw_falling_block !current;
+    do_after ms:!time do:loop
+  in
+    (* As an applet, it was required... *)
+    (* List.iter fun: bind_game widgets; *)
+  bind_game top; 
+  Button.configure button command: game_init;
+  game_init ()
+
+let _ = Printexc.print mainLoop ()