10 files changed, 0 insertions, 1200 deletions
diff --git a/otherlibs/labltk/example/Lambda2.back.gif b/otherlibs/labltk/example/Lambda2.back.gif
deleted file mode 100644
index 7cb3d2c13..000000000
--- a/otherlibs/labltk/example/Lambda2.back.gif
+++ /dev/null
diff --git a/otherlibs/labltk/example/Makefile b/otherlibs/labltk/example/Makefile
deleted file mode 100644
index c30d2aa38..000000000
--- a/otherlibs/labltk/example/Makefile
+++ /dev/null
@@ -1,46 +0,0 @@
-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
deleted file mode 100644
index 71bbaca79..000000000
--- a/otherlibs/labltk/example/README
+++ /dev/null
@@ -1,18 +0,0 @@
-$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
deleted file mode 100644
index a330a9ecb..000000000
--- a/otherlibs/labltk/example/calc.ml
+++ /dev/null
@@ -1,112 +0,0 @@
-(* $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
deleted file mode 100644
index 0aa0ab74d..000000000
--- a/otherlibs/labltk/example/clock.ml
+++ /dev/null
@@ -1,115 +0,0 @@
-(* $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
deleted file mode 100644
index 897d4b9e4..000000000
--- a/otherlibs/labltk/example/demo.ml
+++ /dev/null
@@ -1,150 +0,0 @@
-(* 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
deleted file mode 100644
index 1f281d66c..000000000
--- a/otherlibs/labltk/example/eyes.ml
+++ /dev/null
@@ -1,43 +0,0 @@
-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
deleted file mode 100644
index 5e890aada..000000000
--- a/otherlibs/labltk/example/hello.ml
+++ /dev/null
@@ -1,20 +0,0 @@
-(* 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
deleted file mode 100755
index 9e9985c15..000000000
--- a/otherlibs/labltk/example/hello.tcl
+++ /dev/null
@@ -1,5 +0,0 @@
-#!/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
deleted file mode 100644
index bfc60db07..000000000
--- a/otherlibs/labltk/example/tetris.ml
+++ /dev/null
@@ -1,691 +0,0 @@
-(* 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 ()