Imported from caml_examples.

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@13325 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
author: Pierre Weis <Pierre.Weis@inria.fr> 2013-02-27 19:27:19 +0000
committer: Pierre Weis <Pierre.Weis@inria.fr> 2013-02-27 19:27:19 +0000
commit: fe12fa4993b5895f253d6ca3cc129c164da0cf23 (patch)
tree: a2bb2d8088efc06ec8c38d1a9b2b39a4c4deb0b4
parent: 982cce67214cc69006c9a06a09cf51cb0c2f1e58 (diff)
1 files changed, 261 insertions, 403 deletions
diff --git a/otherlibs/labltk/examples_camltk/tetris.ml b/otherlibs/labltk/examples_camltk/tetris.ml
index 14a9b648f..a46de602f 100644
--- a/otherlibs/labltk/examples_camltk/tetris.ml
+++ b/otherlibs/labltk/examples_camltk/tetris.ml
@@ -1,236 +1,136 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of OCaml                     *)
+(*                        Caml examples                                *)
 (*                                                                     *)
-(*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
-(*               projet Cristal, INRIA Rocquencourt                    *)
-(*            Jacques Garrigue, Kyoto University RIMS                  *)
+(*            Pierre Weis                                              *)
 (*                                                                     *)
-(*  Copyright 2002 Institut National de Recherche en Informatique et   *)
-(*  en Automatique and Kyoto University.  All rights reserved.         *)
-(*  This file is distributed under the terms of the GNU Library        *)
-(*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the OCaml source tree.          *)
+(*                        INRIA Rocquencourt                           *)
+(*                                                                     *)
+(*  Copyright (c) 1994-2011, INRIA                                     *)
+(*  All rights reserved.                                               *)
+(*                                                                     *)
+(*  Distributed under the BSD license.                                 *)
 (*                                                                     *)
 (***********************************************************************)
 
-(* A Tetris game for CamlTk *)
-(* written by Jun P. Furuse *)
+(* $Id: tetris.ml,v 1.6 2011-08-08 19:31:17 weis Exp $ *)
 
-open Camltk
+(* A Tetris game for CamlTk.
+   Written by Jun P. Furuse.
+   Adapted to the oc examples repository by P. Weis *)
 
-exception Done
+open Camltk;;
 
-type cell = {mutable color : int;
-             tag : tagOrId * tagOrId * tagOrId}
+(* The directory where images will be found. *)
+let baseurl = "images/";;
+
+exception Done;;
+
+type cell = {
+ mutable color : int;
+ tag : tagOrId * tagOrId * tagOrId;
+}
+;;
 
 type falling_block = {
-  mutable pattern: int array list;
-  mutable bcolor: int;
-  mutable x: int;
-  mutable y: int;
-  mutable d: int;
-  mutable alive: bool
+  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 stop_a_bit = 300;;
 
 let colors = [|
-  NamedColor "red";
-  NamedColor "yellow";
-
-  NamedColor "blue";
-  NamedColor "orange";
-
-  NamedColor "magenta";
-  NamedColor "green";
-
-  NamedColor "cyan"
+  NamedColor "red"; NamedColor "yellow"; NamedColor "blue";
+  NamedColor "orange"; NamedColor "magenta"; NamedColor "green";
+  NamedColor "cyan";
 |]
-
-let baseurl = "images/"
+;;
 
 let backgrounds =
   List.map (fun s -> baseurl ^ s)
-    [ "dojoji.back.gif";
-      "Lambda2back.gif";
-      "CamlBook.gif";
-    ]
+    [ "dojoji.back.gif"; "Lambda2.back.gif"; "CamlBook.gif"; ];;
 
 (* blocks *)
 let block_size = 16
-let cell_border = 2
+and 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" |] ]
-
+  [ [|"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"
+and line_full = int_of_string  "0b1111111111111111"
+;;
 
 let decode_block dvec =
-  let btoi d = int_of_string ("0b"^d) in
+  let btoi d = int_of_string ("0b" ^ d) in
   Array.map btoi dvec
+;;
 
 let init fw =
   let scorev = Textvariable.create ()
   and linev = Textvariable.create ()
   and levv = Textvariable.create ()
-  in
+  and _namev = Textvariable.create () in
   let f = Frame.create fw [BorderWidth (Pixels 2)] in
-  let c = Canvas.create f [Width (Pixels (block_size * 10));
-                           Height (Pixels (block_size * 20));
-                           BorderWidth (Pixels cell_border);
-                           Relief Sunken;
-                           Background Black]
+  let c =
+    Canvas.create f
+     [Width (Pixels (block_size * 10));
+      Height (Pixels (block_size * 20));
+      BorderWidth (Pixels cell_border);
+      Relief Sunken;
+      Background Black]
   and r = Frame.create f []
   and r' = Frame.create f [] in
 
   let nl = Label.create r [Text "Next"; Font "variable"] in
-  let nc = Canvas.create r [Width (Pixels (block_size * 4));
-                           Height (Pixels (block_size * 4));
-                           BorderWidth (Pixels cell_border);
-                           Relief Sunken;
-                           Background Black] in
+  let nc =
+    Canvas.create r
+     [Width (Pixels (block_size * 4));
+      Height (Pixels (block_size * 4));
+      BorderWidth (Pixels cell_border);
+      Relief Sunken;
+      Background Black] in
   let scl = Label.create r [Text "Score"; Font "variable"] in
   let sc = Label.create r [TextVariable scorev; Font "variable"] in
   let lnl = Label.create r [Text "Lines"; Font "variable"] in
@@ -245,139 +145,128 @@ let init fw =
   pack [nl; nc] [Side Side_Top];
   pack [scl; sc; lnl; ln; levl; lev; newg; exitg] [Side Side_Top];
 
-  let cells_src = Array.create 20 (Array.create 10 ()) in
+  let cells_src = Array.make_matrix 20 10 () in
   let cells = Array.map (Array.map (fun () ->
-    {tag=
-        (let t1, t2, t3 =
+    {tag =
+      (let t1, t2, t3 =
+         Canvas.create_rectangle c
+           (Pixels (-block_size - 8)) (Pixels (-block_size - 8))
+           (Pixels (-9)) (Pixels (-9)) [],
           Canvas.create_rectangle c
-             (Pixels (-block_size - 8)) (Pixels (-block_size - 8))
-             (Pixels (-9))          (Pixels (-9)) [],
+           (Pixels (-block_size - 10)) (Pixels (-block_size - 10))
+           (Pixels (-11)) (Pixels (-11)) [],
           Canvas.create_rectangle c
-             (Pixels (-block_size - 10)) (Pixels (-block_size - 10))
-             (Pixels (-11))          (Pixels (-11)) [],
-          Canvas.create_rectangle c
-             (Pixels (-block_size - 12)) (Pixels (-block_size - 12))
-             (Pixels (-13))          (Pixels (-13)) []
-        in
-          Canvas.raise_top c t1;
-          Canvas.raise_top c t2;
-          Canvas.lower_bot c t3;
-          t1,t2,t3);
-     color= 0})) cells_src
-  in
-  let nexts_src = Array.create 4 (Array.create 4 ()) in
+           (Pixels (-block_size - 12)) (Pixels (-block_size - 12))
+           (Pixels (-13)) (Pixels (-13)) [] in
+       Canvas.raise_top c t1;
+       Canvas.raise_top c t2;
+       Canvas.lower_bot c t3;
+       t1, t2, t3);
+     color = 0})) cells_src in
+  let nexts_src = Array.make_matrix 4 4 () in
   let nexts =
    Array.map (Array.map (fun () ->
-    {tag=
-       (let t1, t2, t3 =
-          Canvas.create_rectangle nc
-             (Pixels (-block_size - 8)) (Pixels (-block_size - 8))
-             (Pixels (-9))          (Pixels (-9)) [],
-          Canvas.create_rectangle nc
-             (Pixels (-block_size - 10)) (Pixels (-block_size - 10))
-             (Pixels (-11))          (Pixels (-11)) [],
-          Canvas.create_rectangle nc
-             (Pixels (-block_size - 12)) (Pixels (-block_size - 12))
-             (Pixels (-13))          (Pixels (-13)) []
-        in
-          Canvas.raise_top nc t1;
-          Canvas.raise_top nc t2;
-          Canvas.lower_bot nc t3;
-          t1, t2, t3);
-     color= 0})) nexts_src in
+    {tag =
+      (let t1, t2, t3 =
+         Canvas.create_rectangle nc
+           (Pixels (-block_size - 8)) (Pixels (-block_size - 8))
+           (Pixels (-9)) (Pixels (-9)) [],
+         Canvas.create_rectangle nc
+           (Pixels (-block_size - 10)) (Pixels (-block_size - 10))
+           (Pixels (-11)) (Pixels (-11)) [],
+         Canvas.create_rectangle nc
+           (Pixels (-block_size - 12)) (Pixels (-block_size - 12))
+           (Pixels (-13)) (Pixels (-13)) [] in
+       Canvas.raise_top nc t1;
+       Canvas.raise_top nc t2;
+       Canvas.lower_bot nc t3;
+       t1, t2, t3);
+     color = 0})) nexts_src in
   let game_over () = ()
   in
-    [f; c; r; nl; nc; scl; sc; levl; lev; lnl; ln], newg, exitg,
-      (c, cells), (nc, nexts), scorev, linev, levv, game_over
+  [f; c; r; nl; nc; scl; sc; levl; lev; lnl; ln], newg, exitg,
+  (c, cells), (nc, nexts), scorev, linev, levv, game_over
+;;
 
-let cell_get (c, cf) x y =
-  (Array.get (Array.get cf y) x).color
+let cell_get (c, cf) x y = cf.(y).(x).color;;
 
 let cell_set (c, cf) x y col =
-  let cur = Array.get (Array.get cf y) x in
-  let t1,t2,t3 = cur.tag in
-    if cur.color = col then ()
-    else
-    if cur.color <> 0 && col = 0 then
-      begin
+  let cur = cf.(y).(x) in
+  let t1, t2, t3 = cur.tag in
+  if cur.color = col then () else
+  if cur.color <> 0 && col = 0 then begin
+    Canvas.move c t1
+      (Pixels (- block_size * (x + 1) -10 - cell_border * 2))
+      (Pixels (- block_size * (y + 1) -10 - cell_border * 2));
+    Canvas.move c t2
+      (Pixels (- block_size * (x + 1) -10 - cell_border * 2))
+      (Pixels (- block_size * (y + 1) -10 - cell_border * 2));
+    Canvas.move c t3
+      (Pixels (- block_size * (x + 1) -10 - cell_border * 2))
+      (Pixels (- block_size * (y + 1) -10 - cell_border * 2))
+
+  end else begin
+    Canvas.configure_rectangle c t2
+      [FillColor (Array.get colors (col - 1));
+       Outline (Array.get colors (col - 1))];
+    Canvas.configure_rectangle c t1
+      [FillColor Black;
+       Outline Black];
+    Canvas.configure_rectangle c t3
+      [FillColor (NamedColor "light gray");
+       Outline (NamedColor "light gray")];
+    if cur.color = 0 && col <> 0 then begin
       Canvas.move c t1
-                       (Pixels (- block_size * (x + 1) -10 - cell_border * 2))
-                       (Pixels (- block_size * (y + 1) -10 - cell_border * 2));
+        (Pixels (block_size * (x + 1) + 10 + cell_border * 2))
+        (Pixels (block_size * (y + 1) + 10 + cell_border * 2));
       Canvas.move c t2
-                       (Pixels (- block_size * (x + 1) -10 - cell_border * 2))
-                       (Pixels (- block_size * (y + 1) -10 - cell_border * 2));
+        (Pixels (block_size * (x + 1) + 10 + cell_border * 2))
+        (Pixels (block_size * (y + 1) + 10 + cell_border * 2));
       Canvas.move c t3
-                       (Pixels (- block_size * (x + 1) -10 - cell_border * 2))
-                       (Pixels (- block_size * (y + 1) -10 - cell_border * 2))
-      end
-    else
-      begin
-        Canvas.configure_rectangle c t2
-              [FillColor (Array.get colors (col - 1));
-               Outline (Array.get colors (col - 1))];
-        Canvas.configure_rectangle c t1
-              [FillColor Black;
-               Outline Black];
-        Canvas.configure_rectangle c t3
-              [FillColor (NamedColor "light gray");
-               Outline (NamedColor "light gray")];
-        if cur.color = 0 && col <> 0 then
-          begin
-            Canvas.move c t1
-              (Pixels (block_size * (x+1)+10+ cell_border*2))
-              (Pixels (block_size * (y+1)+10+ cell_border*2));
-            Canvas.move c t2
-              (Pixels (block_size * (x+1)+10+ cell_border*2))
-              (Pixels (block_size * (y+1)+10+ cell_border*2));
-            Canvas.move c t3
-              (Pixels (block_size * (x+1)+10+ cell_border*2))
-              (Pixels (block_size * (y+1)+10+ cell_border*2))
-          end
-      end;
-    cur.color <- col
+        (Pixels (block_size * (x + 1) + 10 + cell_border * 2))
+        (Pixels (block_size * (y + 1) + 10 + cell_border * 2))
+    end
+  end;
+  cur.color <- col
+;;
 
 let draw_block field col d x y =
   for iy = 0 to 3 do
     let base = ref 1 in
     let xd = Array.get d iy in
     for ix = 0 to 3 do
-      if xd land !base <> 0 then
-        begin
-          try cell_set field (ix + x) (iy + y) col with _ -> ()
-        end
-      else
-        begin
-        (* cell_set field (ix + x) (iy + y) 0 *) ()
-        end;
+      if xd land !base <> 0 then begin
+        try cell_set field (ix + x) (iy + y) col with _ -> ()
+      end;
       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 timer_ref = (ref None : Timer.t option ref);;
 
 let remove_timer () =
   match !timer_ref with
   | None -> ()
-  | Some t -> Timer.remove t (* ; prerr_endline "removed!" *)
+  | Some t -> Timer.remove t
+;;
 
-let do_after milli f =
-  timer_ref := Some (Timer.add milli f)
+let do_after milli f = timer_ref := Some (Timer.add milli 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
+  { pattern = !c.pattern;
+    bcolor = !c.bcolor;
+    x = !c.x;
+    y = !c.y;
+    d = !c.d;
+    alive = !c.alive }
+;;
+
+let start_game () =
+  let top = openTk () in
+  Wm.title_set top "";
   let lb = Label.create top []
-  and fw = Frame.create top []
-  in
+  and fw = Frame.create top [] in
   let set_message s = Label.configure lb [Text s] in
   pack [lb; fw] [Side Side_Top];
   let score = ref 0 in
@@ -385,10 +274,9 @@ let _ =
   let level = ref 0 in
   let time = ref 1000 in
   let blocks = List.map (List.map decode_block) blocks in
-  let field = Array.create 26 0 in
+  let field = Array.make 26 0 in
   let widgets, newg, exitg, cell_field, next_field,
-      scorev, linev, levv, game_over =
-        init fw in
+      scorev, linev, levv, game_over = init fw in
   let canvas = fst cell_field in
 
   let init_field () =
@@ -405,46 +293,37 @@ let _ =
       for j = 0 to 3 do
         cell_set next_field j i 0
       done
-    done
-  in
+    done in
 
   let draw_falling_block fb =
     draw_block cell_field fb.bcolor
       (List.nth fb.pattern fb.d) (fb.x - 3) (fb.y - 3)
-
   and erase_falling_block fb =
-    draw_block cell_field 0 (List.nth fb.pattern fb.d) (fb.x - 3) (fb.y - 3)
-  in
+    draw_block cell_field 0 (List.nth fb.pattern fb.d) (fb.x - 3) (fb.y - 3) in
 
   let stone fb =
-    for i=0 to 3 do
+    for i = 0 to 3 do
       let cur = field.(i + fb.y) in
       field.(i + fb.y) <-
          cur lor ((List.nth fb.pattern fb.d).(i) lsl fb.x)
     done;
-    for i=0 to 2 do
-      field.(i) <- line_empty
-    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 j (i + fb.y - 3) 0
-            done
-          end
+      if i + fb.y >= 3 && i + fb.y <= 22 &&
+         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 j (i + fb.y - 3) 0 done
+      end
     done;
     !l
 
   and fall_lines () =
     let eye = ref 22 (* bottom *)
-    and cur = ref 22 (* bottom *)
-    in
+    and cur = ref 22 (* bottom *) in
     try
       while !eye >= 3 do
         while field.(!eye) = line_empty do
@@ -461,33 +340,28 @@ let _ =
     with Done -> ();
       for i = 3 to !cur do
         field.(i) <- line_empty;
-        for j = 0 to 9 do
-          cell_set cell_field j (i-3) 0
-        done
-      done
- in
+        for j = 0 to 9 do cell_set cell_field j (i - 3) 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
+    ref { pattern= [[|0; 0; 0; 0|]];
+          bcolor = 0; x = 0; y = 0; d = 0; alive = false} in
 
   let draw_next () =
-    draw_block next_field (!next+1) (List.hd (List.nth blocks !next)) 0 0
+    draw_block next_field (!next + 1) (List.hd (List.nth blocks !next)) 0 0
 
   and erase_next () =
-    draw_block next_field 0 (List.hd (List.nth blocks !next)) 0 0
-  in
+    draw_block next_field 0 (List.hd (List.nth blocks !next)) 0 0 in
 
   let set_nextblock () =
     current :=
-       { pattern= (List.nth blocks !next);
-         bcolor= !next+1;
-         x=6; y= 1; d= 0; alive= true};
+       { pattern = (List.nth blocks !next);
+         bcolor = !next + 1;
+         x = 6; y = 1; d = 0; alive = true};
     erase_next ();
     next := Random.int 7;
-    draw_next ()
-  in
+    draw_next () in
 
   let death_check fb =
     try
@@ -498,8 +372,7 @@ let _ =
       done;
       false
     with
-      Done -> true
-  in
+      Done -> true in
 
   let try_to_move m =
     if !current.alive then
@@ -511,40 +384,29 @@ let _ =
             draw_falling_block m;
             current := m;
             true
-          end
-      in
-      if sub m then ()
-      else
-        begin
-          m.x <- m.x + 1;
-          if sub m then ()
-          else
-            begin
-              m.x <- m.x - 2;
-              ignore (sub m)
-            end
+          end in
+      if sub m then () else begin
+        m.x <- m.x + 1;
+        if sub m then () else begin
+          m.x <- m.x - 2;
+          ignore (sub m)
         end
-    else ()
-  in
+      end
+    else () in
 
   let image_load =
-    let i = Canvas.create_image canvas
-            (Pixels (block_size * 5 + block_size / 2))
-            (Pixels (block_size * 10 + block_size / 2))
-                [Anchor Center] in
+    let i =
+      Canvas.create_image canvas
+        (Pixels (block_size * 5 + block_size / 2))
+        (Pixels (block_size * 10 + block_size / 2))
+        [Anchor Center] in
     Canvas.lower_bot canvas i;
     let img = Imagephoto.create [] in
     fun file ->
       try
         Imagephoto.configure img [File file];
         Canvas.configure_image canvas i [ImagePhoto img]
-      with
-        _ ->
-          begin
-            Printf.eprintf "%s : No such image...\n" file;
-            flush stderr
-          end
-  in
+      with _ -> Printf.eprintf "%s : No such image...\n" file; flush stderr in
 
   let add_score l =
     let pline = !line in
@@ -557,62 +419,53 @@ let _ =
     Textvariable.set linev (string_of_int !line);
     Textvariable.set scorev (string_of_int !score);
 
-    if !line /10 <> pline /10 then
+    if !line / 10 <> pline / 10 then
       (* update the background every 10 lines. *)
       begin
         let num_image = List.length backgrounds - 1 in
-        let n = !line/10 in
+        let n = !line / 10 in
         let n = if n > num_image then num_image else n in
         let file = List.nth backgrounds n in
         image_load file;
         (* Future work: We should gain level after an image is put... *)
         incr level;
         Textvariable.set levv (string_of_int !level)
-      end
-  in
+      end in
 
   let rec newblock () =
     set_message "TETRIS";
     set_nextblock ();
     draw_falling_block !current;
-    if death_check !current then
-      begin
+    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 stop_a_bit loop
-      end
+    end else begin
+      time := 1100 - (!level / 4 * 300) - ((!level mod 4) * 200);
+      if !time < 60 - !level * 3 then time := 60 - !level * 3;
+      do_after stop_a_bit 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 stop_a_bit (fun () ->
-          let l = clear !current in
-            if l > 0 then
-              do_after stop_a_bit (fun () ->
-                fall_lines ();
-                add_score l;
-                do_after stop_a_bit newblock)
-            else
-              newblock ())
-      end
-    else
-      begin
-        erase_falling_block !current;
-        draw_falling_block m;
-        current := m;
-        do_after !time loop
-      end
-  in
+    if death_check m then begin
+      !current.alive <- false;
+      stone !current;
+      do_after stop_a_bit (fun () ->
+        let l = clear !current in
+        if l > 0 then
+          do_after stop_a_bit (fun () ->
+            fall_lines ();
+            add_score l;
+            do_after stop_a_bit newblock)
+        else newblock ())
+    end else begin
+      erase_falling_block !current;
+      draw_falling_block m;
+      current := m;
+      do_after !time loop
+    end in
 
   let bind_game w =
     bind w [([], KeyPress)] (BindSet ([Ev_KeySymString],
@@ -656,8 +509,7 @@ let _ =
                 loop ()
               end
         | _ -> ()
-      ))
-  in
+      )) in
 
   let game_init () =
     (* Game Initialization *)
@@ -674,11 +526,17 @@ let _ =
     set_message "Welcome to TETRIS";
     set_nextblock ();
     draw_falling_block !current;
-    do_after !time loop
-  in
-   bind_game top;
-   Button.configure newg [Command game_init];
-   Button.configure exitg [Command (fun () -> closeTk (); exit 0)];
-   game_init ()
+    do_after !time loop in
+
+  bind_game top;
+  Button.configure newg [Command game_init];
+  Button.configure exitg [Command (fun () -> exit 0)];
+  game_init ()
+;;
+
+let tetris () =
+ start_game ();
+ Printexc.print mainLoop ()
+;;
 
-let _ = Printexc.print mainLoop ()
+if !Sys.interactive then () else begin tetris (); exit 0 end;;
author	Pierre Weis <Pierre.Weis@inria.fr>	2013-02-27 19:27:19 +0000
committer	Pierre Weis <Pierre.Weis@inria.fr>	2013-02-27 19:27:19 +0000
commit	fe12fa4993b5895f253d6ca3cc129c164da0cf23 (patch)
tree	a2bb2d8088efc06ec8c38d1a9b2b39a4c4deb0b4
parent	982cce67214cc69006c9a06a09cf51cb0c2f1e58 (diff)