|
Packit |
bd2e5d |
(***********************************************************************)
|
|
Packit |
bd2e5d |
(* *)
|
|
Packit |
bd2e5d |
(* Caml examples *)
|
|
Packit |
bd2e5d |
(* *)
|
|
Packit |
bd2e5d |
(* Pierre Weis *)
|
|
Packit |
bd2e5d |
(* *)
|
|
Packit |
bd2e5d |
(* INRIA Rocquencourt *)
|
|
Packit |
bd2e5d |
(* *)
|
|
Packit |
bd2e5d |
(* Copyright (c) 1994-2011, INRIA *)
|
|
Packit |
bd2e5d |
(* All rights reserved. *)
|
|
Packit |
bd2e5d |
(* *)
|
|
Packit |
bd2e5d |
(* Distributed under the BSD license. *)
|
|
Packit |
bd2e5d |
(* *)
|
|
Packit |
bd2e5d |
(***********************************************************************)
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
(* $Id: tetris.ml,v 1.6 2011-08-08 19:31:17 weis Exp $ *)
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
(* A Tetris game for CamlTk.
|
|
Packit |
bd2e5d |
Written by Jun P. Furuse.
|
|
Packit |
bd2e5d |
Adapted to the oc examples repository by P. Weis *)
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
open Camltk;;
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
(* The directory where images will be found. *)
|
|
Packit |
bd2e5d |
let baseurl = "images/";;
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
exception Done;;
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
type cell = {
|
|
Packit |
bd2e5d |
mutable color : int;
|
|
Packit |
bd2e5d |
tag : tagOrId * tagOrId * tagOrId;
|
|
Packit |
bd2e5d |
}
|
|
Packit |
bd2e5d |
;;
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
type falling_block = {
|
|
Packit |
bd2e5d |
mutable pattern : int array list;
|
|
Packit |
bd2e5d |
mutable bcolor : int;
|
|
Packit |
bd2e5d |
mutable x : int;
|
|
Packit |
bd2e5d |
mutable y : int;
|
|
Packit |
bd2e5d |
mutable d : int;
|
|
Packit |
bd2e5d |
mutable alive: bool;
|
|
Packit |
bd2e5d |
}
|
|
Packit |
bd2e5d |
;;
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
let stop_a_bit = 300;;
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
let colors = [|
|
|
Packit |
bd2e5d |
NamedColor "red"; NamedColor "yellow"; NamedColor "blue";
|
|
Packit |
bd2e5d |
NamedColor "orange"; NamedColor "magenta"; NamedColor "green";
|
|
Packit |
bd2e5d |
NamedColor "cyan";
|
|
Packit |
bd2e5d |
|]
|
|
Packit |
bd2e5d |
;;
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
let backgrounds =
|
|
Packit |
bd2e5d |
List.map (fun s -> baseurl ^ s)
|
|
Packit |
bd2e5d |
[ "dojoji.back.gif"; "Lambda2.back.gif"; "CamlBook.gif"; ];;
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
(* blocks *)
|
|
Packit |
bd2e5d |
let block_size = 16
|
|
Packit |
bd2e5d |
and cell_border = 2
|
|
Packit |
bd2e5d |
;;
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
let blocks = [
|
|
Packit |
bd2e5d |
[ [|"0000"; "0000"; "1111"; "0000" |];
|
|
Packit |
bd2e5d |
[|"0010"; "0010"; "0010"; "0010" |];
|
|
Packit |
bd2e5d |
[|"0000"; "0000"; "1111"; "0000" |];
|
|
Packit |
bd2e5d |
[|"0010"; "0010"; "0010"; "0010" |] ];
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
[ [|"0000"; "0110"; "0110"; "0000" |];
|
|
Packit |
bd2e5d |
[|"0000"; "0110"; "0110"; "0000" |];
|
|
Packit |
bd2e5d |
[|"0000"; "0110"; "0110"; "0000" |];
|
|
Packit |
bd2e5d |
[|"0000"; "0110"; "0110"; "0000" |] ];
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
[ [|"0000"; "0111"; "0100"; "0000" |];
|
|
Packit |
bd2e5d |
[|"0000"; "0110"; "0010"; "0010" |];
|
|
Packit |
bd2e5d |
[|"0000"; "0010"; "1110"; "0000" |];
|
|
Packit |
bd2e5d |
[|"0100"; "0100"; "0110"; "0000" |] ];
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
[ [|"0000"; "0100"; "0111"; "0000" |];
|
|
Packit |
bd2e5d |
[|"0000"; "0110"; "0100"; "0100" |];
|
|
Packit |
bd2e5d |
[|"0000"; "1110"; "0010"; "0000" |];
|
|
Packit |
bd2e5d |
[|"0010"; "0010"; "0110"; "0000" |] ];
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
[ [|"0000"; "1100"; "0110"; "0000" |];
|
|
Packit |
bd2e5d |
[|"0010"; "0110"; "0100"; "0000" |];
|
|
Packit |
bd2e5d |
[|"0000"; "1100"; "0110"; "0000" |];
|
|
Packit |
bd2e5d |
[|"0010"; "0110"; "0100"; "0000" |] ];
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
[ [|"0000"; "0011"; "0110"; "0000" |];
|
|
Packit |
bd2e5d |
[|"0100"; "0110"; "0010"; "0000" |];
|
|
Packit |
bd2e5d |
[|"0000"; "0011"; "0110"; "0000" |];
|
|
Packit |
bd2e5d |
[|"0000"; "0100"; "0110"; "0010" |] ];
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
[ [|"0000"; "0000"; "1110"; "0100" |];
|
|
Packit |
bd2e5d |
[|"0000"; "0100"; "1100"; "0100" |];
|
|
Packit |
bd2e5d |
[|"0000"; "0100"; "1110"; "0000" |];
|
|
Packit |
bd2e5d |
[|"0000"; "0100"; "0110"; "0100" |] ];
|
|
Packit |
bd2e5d |
]
|
|
Packit |
bd2e5d |
;;
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
let line_empty = int_of_string "0b1110000000000111"
|
|
Packit |
bd2e5d |
and line_full = int_of_string "0b1111111111111111"
|
|
Packit |
bd2e5d |
;;
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
let decode_block dvec =
|
|
Packit |
bd2e5d |
let btoi d = int_of_string ("0b" ^ d) in
|
|
Packit |
bd2e5d |
Array.map btoi dvec
|
|
Packit |
bd2e5d |
;;
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
let init fw =
|
|
Packit |
bd2e5d |
let scorev = Textvariable.create ()
|
|
Packit |
bd2e5d |
and linev = Textvariable.create ()
|
|
Packit |
bd2e5d |
and levv = Textvariable.create ()
|
|
Packit |
bd2e5d |
and _namev = Textvariable.create () in
|
|
Packit |
bd2e5d |
let f = Frame.create fw [BorderWidth (Pixels 2)] in
|
|
Packit |
bd2e5d |
let c =
|
|
Packit |
bd2e5d |
Canvas.create f
|
|
Packit |
bd2e5d |
[Width (Pixels (block_size * 10));
|
|
Packit |
bd2e5d |
Height (Pixels (block_size * 20));
|
|
Packit |
bd2e5d |
BorderWidth (Pixels cell_border);
|
|
Packit |
bd2e5d |
Relief Sunken;
|
|
Packit |
bd2e5d |
Background Black]
|
|
Packit |
bd2e5d |
and r = Frame.create f []
|
|
Packit |
bd2e5d |
and r' = Frame.create f [] in
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
let nl = Label.create r [Text "Next"; Font "variable"] in
|
|
Packit |
bd2e5d |
let nc =
|
|
Packit |
bd2e5d |
Canvas.create r
|
|
Packit |
bd2e5d |
[Width (Pixels (block_size * 4));
|
|
Packit |
bd2e5d |
Height (Pixels (block_size * 4));
|
|
Packit |
bd2e5d |
BorderWidth (Pixels cell_border);
|
|
Packit |
bd2e5d |
Relief Sunken;
|
|
Packit |
bd2e5d |
Background Black] in
|
|
Packit |
bd2e5d |
let scl = Label.create r [Text "Score"; Font "variable"] in
|
|
Packit |
bd2e5d |
let sc = Label.create r [TextVariable scorev; Font "variable"] in
|
|
Packit |
bd2e5d |
let lnl = Label.create r [Text "Lines"; Font "variable"] in
|
|
Packit |
bd2e5d |
let ln = Label.create r [TextVariable linev; Font "variable"] in
|
|
Packit |
bd2e5d |
let levl = Label.create r [Text "Level"; Font "variable"] in
|
|
Packit |
bd2e5d |
let lev = Label.create r [TextVariable levv; Font "Variable"] in
|
|
Packit |
bd2e5d |
let newg = Button.create r [Text "New Game"; Font "variable"] in
|
|
Packit |
bd2e5d |
let exitg = Button.create r [Text "Quit"; Font "variable"] in
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
pack [f] [];
|
|
Packit |
bd2e5d |
pack [c; r; r'] [Side Side_Left; Fill Fill_Y];
|
|
Packit |
bd2e5d |
pack [nl; nc] [Side Side_Top];
|
|
Packit |
bd2e5d |
pack [scl; sc; lnl; ln; levl; lev; newg; exitg] [Side Side_Top];
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
let cells_src = Array.make_matrix 20 10 () in
|
|
Packit |
bd2e5d |
let cells = Array.map (Array.map (fun () ->
|
|
Packit |
bd2e5d |
{tag =
|
|
Packit |
bd2e5d |
(let t1, t2, t3 =
|
|
Packit |
bd2e5d |
Canvas.create_rectangle c
|
|
Packit |
bd2e5d |
(Pixels (-block_size - 8)) (Pixels (-block_size - 8))
|
|
Packit |
bd2e5d |
(Pixels (-9)) (Pixels (-9)) [],
|
|
Packit |
bd2e5d |
Canvas.create_rectangle c
|
|
Packit |
bd2e5d |
(Pixels (-block_size - 10)) (Pixels (-block_size - 10))
|
|
Packit |
bd2e5d |
(Pixels (-11)) (Pixels (-11)) [],
|
|
Packit |
bd2e5d |
Canvas.create_rectangle c
|
|
Packit |
bd2e5d |
(Pixels (-block_size - 12)) (Pixels (-block_size - 12))
|
|
Packit |
bd2e5d |
(Pixels (-13)) (Pixels (-13)) [] in
|
|
Packit |
bd2e5d |
Canvas.raise_top c t1;
|
|
Packit |
bd2e5d |
Canvas.raise_top c t2;
|
|
Packit |
bd2e5d |
Canvas.lower_bot c t3;
|
|
Packit |
bd2e5d |
t1, t2, t3);
|
|
Packit |
bd2e5d |
color = 0})) cells_src in
|
|
Packit |
bd2e5d |
let nexts_src = Array.make_matrix 4 4 () in
|
|
Packit |
bd2e5d |
let nexts =
|
|
Packit |
bd2e5d |
Array.map (Array.map (fun () ->
|
|
Packit |
bd2e5d |
{tag =
|
|
Packit |
bd2e5d |
(let t1, t2, t3 =
|
|
Packit |
bd2e5d |
Canvas.create_rectangle nc
|
|
Packit |
bd2e5d |
(Pixels (-block_size - 8)) (Pixels (-block_size - 8))
|
|
Packit |
bd2e5d |
(Pixels (-9)) (Pixels (-9)) [],
|
|
Packit |
bd2e5d |
Canvas.create_rectangle nc
|
|
Packit |
bd2e5d |
(Pixels (-block_size - 10)) (Pixels (-block_size - 10))
|
|
Packit |
bd2e5d |
(Pixels (-11)) (Pixels (-11)) [],
|
|
Packit |
bd2e5d |
Canvas.create_rectangle nc
|
|
Packit |
bd2e5d |
(Pixels (-block_size - 12)) (Pixels (-block_size - 12))
|
|
Packit |
bd2e5d |
(Pixels (-13)) (Pixels (-13)) [] in
|
|
Packit |
bd2e5d |
Canvas.raise_top nc t1;
|
|
Packit |
bd2e5d |
Canvas.raise_top nc t2;
|
|
Packit |
bd2e5d |
Canvas.lower_bot nc t3;
|
|
Packit |
bd2e5d |
t1, t2, t3);
|
|
Packit |
bd2e5d |
color = 0})) nexts_src in
|
|
Packit |
bd2e5d |
let game_over () = ()
|
|
Packit |
bd2e5d |
in
|
|
Packit |
bd2e5d |
[f; c; r; nl; nc; scl; sc; levl; lev; lnl; ln], newg, exitg,
|
|
Packit |
bd2e5d |
(c, cells), (nc, nexts), scorev, linev, levv, game_over
|
|
Packit |
bd2e5d |
;;
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
let cell_get (c, cf) x y = cf.(y).(x).color;;
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
let cell_set (c, cf) x y col =
|
|
Packit |
bd2e5d |
let cur = cf.(y).(x) in
|
|
Packit |
bd2e5d |
let t1, t2, t3 = cur.tag in
|
|
Packit |
bd2e5d |
if cur.color = col then () else
|
|
Packit |
bd2e5d |
if cur.color <> 0 && col = 0 then begin
|
|
Packit |
bd2e5d |
Canvas.move c t1
|
|
Packit |
bd2e5d |
(Pixels (- block_size * (x + 1) -10 - cell_border * 2))
|
|
Packit |
bd2e5d |
(Pixels (- block_size * (y + 1) -10 - cell_border * 2));
|
|
Packit |
bd2e5d |
Canvas.move c t2
|
|
Packit |
bd2e5d |
(Pixels (- block_size * (x + 1) -10 - cell_border * 2))
|
|
Packit |
bd2e5d |
(Pixels (- block_size * (y + 1) -10 - cell_border * 2));
|
|
Packit |
bd2e5d |
Canvas.move c t3
|
|
Packit |
bd2e5d |
(Pixels (- block_size * (x + 1) -10 - cell_border * 2))
|
|
Packit |
bd2e5d |
(Pixels (- block_size * (y + 1) -10 - cell_border * 2))
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
end else begin
|
|
Packit |
bd2e5d |
Canvas.configure_rectangle c t2
|
|
Packit |
bd2e5d |
[FillColor (Array.get colors (col - 1));
|
|
Packit |
bd2e5d |
Outline (Array.get colors (col - 1))];
|
|
Packit |
bd2e5d |
Canvas.configure_rectangle c t1
|
|
Packit |
bd2e5d |
[FillColor Black;
|
|
Packit |
bd2e5d |
Outline Black];
|
|
Packit |
bd2e5d |
Canvas.configure_rectangle c t3
|
|
Packit |
bd2e5d |
[FillColor (NamedColor "light gray");
|
|
Packit |
bd2e5d |
Outline (NamedColor "light gray")];
|
|
Packit |
bd2e5d |
if cur.color = 0 && col <> 0 then begin
|
|
Packit |
bd2e5d |
Canvas.move c t1
|
|
Packit |
bd2e5d |
(Pixels (block_size * (x + 1) + 10 + cell_border * 2))
|
|
Packit |
bd2e5d |
(Pixels (block_size * (y + 1) + 10 + cell_border * 2));
|
|
Packit |
bd2e5d |
Canvas.move c t2
|
|
Packit |
bd2e5d |
(Pixels (block_size * (x + 1) + 10 + cell_border * 2))
|
|
Packit |
bd2e5d |
(Pixels (block_size * (y + 1) + 10 + cell_border * 2));
|
|
Packit |
bd2e5d |
Canvas.move c t3
|
|
Packit |
bd2e5d |
(Pixels (block_size * (x + 1) + 10 + cell_border * 2))
|
|
Packit |
bd2e5d |
(Pixels (block_size * (y + 1) + 10 + cell_border * 2))
|
|
Packit |
bd2e5d |
end
|
|
Packit |
bd2e5d |
end;
|
|
Packit |
bd2e5d |
cur.color <- col
|
|
Packit |
bd2e5d |
;;
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
let draw_block field col d x y =
|
|
Packit |
bd2e5d |
for iy = 0 to 3 do
|
|
Packit |
bd2e5d |
let base = ref 1 in
|
|
Packit |
bd2e5d |
let xd = Array.get d iy in
|
|
Packit |
bd2e5d |
for ix = 0 to 3 do
|
|
Packit |
bd2e5d |
if xd land !base <> 0 then begin
|
|
Packit |
bd2e5d |
try cell_set field (ix + x) (iy + y) col with _ -> ()
|
|
Packit |
bd2e5d |
end;
|
|
Packit |
bd2e5d |
base := !base lsl 1
|
|
Packit |
bd2e5d |
done
|
|
Packit |
bd2e5d |
done
|
|
Packit |
bd2e5d |
;;
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
let timer_ref = (ref None : Timer.t option ref);;
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
let remove_timer () =
|
|
Packit |
bd2e5d |
match !timer_ref with
|
|
Packit |
bd2e5d |
| None -> ()
|
|
Packit |
bd2e5d |
| Some t -> Timer.remove t
|
|
Packit |
bd2e5d |
;;
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
let do_after milli f = timer_ref := Some (Timer.add milli f);;
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
let copy_block c =
|
|
Packit |
bd2e5d |
{ pattern = !c.pattern;
|
|
Packit |
bd2e5d |
bcolor = !c.bcolor;
|
|
Packit |
bd2e5d |
x = !c.x;
|
|
Packit |
bd2e5d |
y = !c.y;
|
|
Packit |
bd2e5d |
d = !c.d;
|
|
Packit |
bd2e5d |
alive = !c.alive }
|
|
Packit |
bd2e5d |
;;
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
let start_game () =
|
|
Packit |
bd2e5d |
let top = openTk () in
|
|
Packit |
bd2e5d |
Wm.title_set top "";
|
|
Packit |
bd2e5d |
let lb = Label.create top []
|
|
Packit |
bd2e5d |
and fw = Frame.create top [] in
|
|
Packit |
bd2e5d |
let set_message s = Label.configure lb [Text s] in
|
|
Packit |
bd2e5d |
pack [lb; fw] [Side Side_Top];
|
|
Packit |
bd2e5d |
let score = ref 0 in
|
|
Packit |
bd2e5d |
let line = ref 0 in
|
|
Packit |
bd2e5d |
let level = ref 0 in
|
|
Packit |
bd2e5d |
let time = ref 1000 in
|
|
Packit |
bd2e5d |
let blocks = List.map (List.map decode_block) blocks in
|
|
Packit |
bd2e5d |
let field = Array.make 26 0 in
|
|
Packit |
bd2e5d |
let widgets, newg, exitg, cell_field, next_field,
|
|
Packit |
bd2e5d |
scorev, linev, levv, game_over = init fw in
|
|
Packit |
bd2e5d |
let canvas = fst cell_field in
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
let init_field () =
|
|
Packit |
bd2e5d |
for i = 0 to 25 do
|
|
Packit |
bd2e5d |
field.(i) <- line_empty
|
|
Packit |
bd2e5d |
done;
|
|
Packit |
bd2e5d |
field.(23) <- line_full;
|
|
Packit |
bd2e5d |
for i = 0 to 19 do
|
|
Packit |
bd2e5d |
for j = 0 to 9 do
|
|
Packit |
bd2e5d |
cell_set cell_field j i 0
|
|
Packit |
bd2e5d |
done
|
|
Packit |
bd2e5d |
done;
|
|
Packit |
bd2e5d |
for i = 0 to 3 do
|
|
Packit |
bd2e5d |
for j = 0 to 3 do
|
|
Packit |
bd2e5d |
cell_set next_field j i 0
|
|
Packit |
bd2e5d |
done
|
|
Packit |
bd2e5d |
done in
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
let draw_falling_block fb =
|
|
Packit |
bd2e5d |
draw_block cell_field fb.bcolor
|
|
Packit |
bd2e5d |
(List.nth fb.pattern fb.d) (fb.x - 3) (fb.y - 3)
|
|
Packit |
bd2e5d |
and erase_falling_block fb =
|
|
Packit |
bd2e5d |
draw_block cell_field 0 (List.nth fb.pattern fb.d) (fb.x - 3) (fb.y - 3) in
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
let stone fb =
|
|
Packit |
bd2e5d |
for i = 0 to 3 do
|
|
Packit |
bd2e5d |
let cur = field.(i + fb.y) in
|
|
Packit |
bd2e5d |
field.(i + fb.y) <-
|
|
Packit |
bd2e5d |
cur lor ((List.nth fb.pattern fb.d).(i) lsl fb.x)
|
|
Packit |
bd2e5d |
done;
|
|
Packit |
bd2e5d |
for i = 0 to 2 do field.(i) <- line_empty done
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
and clear fb =
|
|
Packit |
bd2e5d |
let l = ref 0 in
|
|
Packit |
bd2e5d |
for i = 0 to 3 do
|
|
Packit |
bd2e5d |
if i + fb.y >= 3 && i + fb.y <= 22 &&
|
|
Packit |
bd2e5d |
field.(i + fb.y) = line_full then begin
|
|
Packit |
bd2e5d |
incr l;
|
|
Packit |
bd2e5d |
field.(i + fb.y) <- line_empty;
|
|
Packit |
bd2e5d |
for j = 0 to 9 do cell_set cell_field j (i + fb.y - 3) 0 done
|
|
Packit |
bd2e5d |
end
|
|
Packit |
bd2e5d |
done;
|
|
Packit |
bd2e5d |
!l
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
and fall_lines () =
|
|
Packit |
bd2e5d |
let eye = ref 22 (* bottom *)
|
|
Packit |
bd2e5d |
and cur = ref 22 (* bottom *) in
|
|
Packit |
bd2e5d |
try
|
|
Packit |
bd2e5d |
while !eye >= 3 do
|
|
Packit |
bd2e5d |
while field.(!eye) = line_empty do
|
|
Packit |
bd2e5d |
decr eye;
|
|
Packit |
bd2e5d |
if !eye = 2 then raise Done
|
|
Packit |
bd2e5d |
done;
|
|
Packit |
bd2e5d |
field.(!cur) <- field.(!eye);
|
|
Packit |
bd2e5d |
for j = 0 to 9 do
|
|
Packit |
bd2e5d |
cell_set cell_field j (!cur-3) (cell_get cell_field j (!eye-3))
|
|
Packit |
bd2e5d |
done;
|
|
Packit |
bd2e5d |
decr eye;
|
|
Packit |
bd2e5d |
decr cur
|
|
Packit |
bd2e5d |
done
|
|
Packit |
bd2e5d |
with Done -> ();
|
|
Packit |
bd2e5d |
for i = 3 to !cur do
|
|
Packit |
bd2e5d |
field.(i) <- line_empty;
|
|
Packit |
bd2e5d |
for j = 0 to 9 do cell_set cell_field j (i - 3) 0 done
|
|
Packit |
bd2e5d |
done in
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
let next = ref 42 (* THE ANSWER *)
|
|
Packit |
bd2e5d |
and current =
|
|
Packit |
bd2e5d |
ref { pattern= [[|0; 0; 0; 0|]];
|
|
Packit |
bd2e5d |
bcolor = 0; x = 0; y = 0; d = 0; alive = false} in
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
let draw_next () =
|
|
Packit |
bd2e5d |
draw_block next_field (!next + 1) (List.hd (List.nth blocks !next)) 0 0
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
and erase_next () =
|
|
Packit |
bd2e5d |
draw_block next_field 0 (List.hd (List.nth blocks !next)) 0 0 in
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
let set_nextblock () =
|
|
Packit |
bd2e5d |
current :=
|
|
Packit |
bd2e5d |
{ pattern = (List.nth blocks !next);
|
|
Packit |
bd2e5d |
bcolor = !next + 1;
|
|
Packit |
bd2e5d |
x = 6; y = 1; d = 0; alive = true};
|
|
Packit |
bd2e5d |
erase_next ();
|
|
Packit |
bd2e5d |
next := Random.int 7;
|
|
Packit |
bd2e5d |
draw_next () in
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
let death_check fb =
|
|
Packit |
bd2e5d |
try
|
|
Packit |
bd2e5d |
for i=0 to 3 do
|
|
Packit |
bd2e5d |
let cur = field.(i + fb.y) in
|
|
Packit |
bd2e5d |
if cur land ((List.nth fb.pattern fb.d).(i) lsl fb.x) <> 0
|
|
Packit |
bd2e5d |
then raise Done
|
|
Packit |
bd2e5d |
done;
|
|
Packit |
bd2e5d |
false
|
|
Packit |
bd2e5d |
with
|
|
Packit |
bd2e5d |
Done -> true in
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
let try_to_move m =
|
|
Packit |
bd2e5d |
if !current.alive then
|
|
Packit |
bd2e5d |
let sub m =
|
|
Packit |
bd2e5d |
if death_check m then false
|
|
Packit |
bd2e5d |
else
|
|
Packit |
bd2e5d |
begin
|
|
Packit |
bd2e5d |
erase_falling_block !current;
|
|
Packit |
bd2e5d |
draw_falling_block m;
|
|
Packit |
bd2e5d |
current := m;
|
|
Packit |
bd2e5d |
true
|
|
Packit |
bd2e5d |
end in
|
|
Packit |
bd2e5d |
if sub m then () else begin
|
|
Packit |
bd2e5d |
m.x <- m.x + 1;
|
|
Packit |
bd2e5d |
if sub m then () else begin
|
|
Packit |
bd2e5d |
m.x <- m.x - 2;
|
|
Packit |
bd2e5d |
ignore (sub m)
|
|
Packit |
bd2e5d |
end
|
|
Packit |
bd2e5d |
end
|
|
Packit |
bd2e5d |
else () in
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
let image_load =
|
|
Packit |
bd2e5d |
let i =
|
|
Packit |
bd2e5d |
Canvas.create_image canvas
|
|
Packit |
bd2e5d |
(Pixels (block_size * 5 + block_size / 2))
|
|
Packit |
bd2e5d |
(Pixels (block_size * 10 + block_size / 2))
|
|
Packit |
bd2e5d |
[Anchor Center] in
|
|
Packit |
bd2e5d |
Canvas.lower_bot canvas i;
|
|
Packit |
bd2e5d |
let img = Imagephoto.create [] in
|
|
Packit |
bd2e5d |
fun file ->
|
|
Packit |
bd2e5d |
try
|
|
Packit |
bd2e5d |
Imagephoto.configure img [File file];
|
|
Packit |
bd2e5d |
Canvas.configure_image canvas i [ImagePhoto img]
|
|
Packit |
bd2e5d |
with _ -> Printf.eprintf "%s : No such image...\n" file; flush stderr in
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
let add_score l =
|
|
Packit |
bd2e5d |
let pline = !line in
|
|
Packit |
bd2e5d |
if l <> 0 then
|
|
Packit |
bd2e5d |
begin
|
|
Packit |
bd2e5d |
line := !line + l;
|
|
Packit |
bd2e5d |
score := !score + l * l;
|
|
Packit |
bd2e5d |
set_message (Printf.sprintf "%d pts" (1 lsl ((l - 1) * 2)))
|
|
Packit |
bd2e5d |
end;
|
|
Packit |
bd2e5d |
Textvariable.set linev (string_of_int !line);
|
|
Packit |
bd2e5d |
Textvariable.set scorev (string_of_int !score);
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
if !line / 10 <> pline / 10 then
|
|
Packit |
bd2e5d |
(* update the background every 10 lines. *)
|
|
Packit |
bd2e5d |
begin
|
|
Packit |
bd2e5d |
let num_image = List.length backgrounds - 1 in
|
|
Packit |
bd2e5d |
let n = !line / 10 in
|
|
Packit |
bd2e5d |
let n = if n > num_image then num_image else n in
|
|
Packit |
bd2e5d |
let file = List.nth backgrounds n in
|
|
Packit |
bd2e5d |
image_load file;
|
|
Packit |
bd2e5d |
(* Future work: We should gain level after an image is put... *)
|
|
Packit |
bd2e5d |
incr level;
|
|
Packit |
bd2e5d |
Textvariable.set levv (string_of_int !level)
|
|
Packit |
bd2e5d |
end in
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
let rec newblock () =
|
|
Packit |
bd2e5d |
set_message "TETRIS";
|
|
Packit |
bd2e5d |
set_nextblock ();
|
|
Packit |
bd2e5d |
draw_falling_block !current;
|
|
Packit |
bd2e5d |
if death_check !current then begin
|
|
Packit |
bd2e5d |
!current.alive <- false;
|
|
Packit |
bd2e5d |
set_message "GAME OVER";
|
|
Packit |
bd2e5d |
game_over ()
|
|
Packit |
bd2e5d |
end else begin
|
|
Packit |
bd2e5d |
time := 1100 - (!level / 4 * 300) - ((!level mod 4) * 200);
|
|
Packit |
bd2e5d |
if !time < 60 - !level * 3 then time := 60 - !level * 3;
|
|
Packit |
bd2e5d |
do_after stop_a_bit loop
|
|
Packit |
bd2e5d |
end
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
and loop () =
|
|
Packit |
bd2e5d |
let m = copy_block current in
|
|
Packit |
bd2e5d |
m.y <- m.y + 1;
|
|
Packit |
bd2e5d |
if death_check m then begin
|
|
Packit |
bd2e5d |
!current.alive <- false;
|
|
Packit |
bd2e5d |
stone !current;
|
|
Packit |
bd2e5d |
do_after stop_a_bit (fun () ->
|
|
Packit |
bd2e5d |
let l = clear !current in
|
|
Packit |
bd2e5d |
if l > 0 then
|
|
Packit |
bd2e5d |
do_after stop_a_bit (fun () ->
|
|
Packit |
bd2e5d |
fall_lines ();
|
|
Packit |
bd2e5d |
add_score l;
|
|
Packit |
bd2e5d |
do_after stop_a_bit newblock)
|
|
Packit |
bd2e5d |
else newblock ())
|
|
Packit |
bd2e5d |
end else begin
|
|
Packit |
bd2e5d |
erase_falling_block !current;
|
|
Packit |
bd2e5d |
draw_falling_block m;
|
|
Packit |
bd2e5d |
current := m;
|
|
Packit |
bd2e5d |
do_after !time loop
|
|
Packit |
bd2e5d |
end in
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
let bind_game w =
|
|
Packit |
bd2e5d |
bind w [([], KeyPress)] (BindSet ([Ev_KeySymString],
|
|
Packit |
bd2e5d |
fun e ->
|
|
Packit |
bd2e5d |
match e.ev_KeySymString with
|
|
Packit |
bd2e5d |
| "h" ->
|
|
Packit |
bd2e5d |
let m = copy_block current in
|
|
Packit |
bd2e5d |
m.x <- m.x - 1;
|
|
Packit |
bd2e5d |
try_to_move m
|
|
Packit |
bd2e5d |
| "j" ->
|
|
Packit |
bd2e5d |
let m = copy_block current in
|
|
Packit |
bd2e5d |
m.d <- m.d + 1;
|
|
Packit |
bd2e5d |
if m.d = List.length m.pattern then m.d <- 0;
|
|
Packit |
bd2e5d |
try_to_move m
|
|
Packit |
bd2e5d |
| "k" ->
|
|
Packit |
bd2e5d |
let m = copy_block current in
|
|
Packit |
bd2e5d |
m.d <- m.d - 1;
|
|
Packit |
bd2e5d |
if m.d < 0 then m.d <- List.length m.pattern - 1;
|
|
Packit |
bd2e5d |
try_to_move m
|
|
Packit |
bd2e5d |
| "l" ->
|
|
Packit |
bd2e5d |
let m = copy_block current in
|
|
Packit |
bd2e5d |
m.x <- m.x + 1;
|
|
Packit |
bd2e5d |
try_to_move m
|
|
Packit |
bd2e5d |
| "m" ->
|
|
Packit |
bd2e5d |
remove_timer ();
|
|
Packit |
bd2e5d |
loop ()
|
|
Packit |
bd2e5d |
| "space" ->
|
|
Packit |
bd2e5d |
if !current.alive then
|
|
Packit |
bd2e5d |
begin
|
|
Packit |
bd2e5d |
let m = copy_block current
|
|
Packit |
bd2e5d |
and n = copy_block current in
|
|
Packit |
bd2e5d |
while
|
|
Packit |
bd2e5d |
m.y <- m.y + 1;
|
|
Packit |
bd2e5d |
if death_check m then false
|
|
Packit |
bd2e5d |
else begin n.y <- m.y; true end
|
|
Packit |
bd2e5d |
do () done;
|
|
Packit |
bd2e5d |
erase_falling_block !current;
|
|
Packit |
bd2e5d |
draw_falling_block n;
|
|
Packit |
bd2e5d |
current := n;
|
|
Packit |
bd2e5d |
remove_timer ();
|
|
Packit |
bd2e5d |
loop ()
|
|
Packit |
bd2e5d |
end
|
|
Packit |
bd2e5d |
| _ -> ()
|
|
Packit |
bd2e5d |
)) in
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
let game_init () =
|
|
Packit |
bd2e5d |
(* Game Initialization *)
|
|
Packit |
bd2e5d |
set_message "Initializing ...";
|
|
Packit |
bd2e5d |
remove_timer ();
|
|
Packit |
bd2e5d |
image_load (List.hd backgrounds);
|
|
Packit |
bd2e5d |
time := 1000;
|
|
Packit |
bd2e5d |
score := 0;
|
|
Packit |
bd2e5d |
line := 0;
|
|
Packit |
bd2e5d |
level := 1;
|
|
Packit |
bd2e5d |
add_score 0;
|
|
Packit |
bd2e5d |
init_field ();
|
|
Packit |
bd2e5d |
next := Random.int 7;
|
|
Packit |
bd2e5d |
set_message "Welcome to TETRIS";
|
|
Packit |
bd2e5d |
set_nextblock ();
|
|
Packit |
bd2e5d |
draw_falling_block !current;
|
|
Packit |
bd2e5d |
do_after !time loop in
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
bind_game top;
|
|
Packit |
bd2e5d |
Button.configure newg [Command game_init];
|
|
Packit |
bd2e5d |
Button.configure exitg [Command (fun () -> exit 0)];
|
|
Packit |
bd2e5d |
game_init ()
|
|
Packit |
bd2e5d |
;;
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
let tetris () =
|
|
Packit |
bd2e5d |
start_game ();
|
|
Packit |
bd2e5d |
Printexc.print mainLoop ()
|
|
Packit |
bd2e5d |
;;
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
if !Sys.interactive then () else begin tetris (); exit 0 end;;
|