l4/pkg/ocaml/contrib/otherlibs/labltk/examples_labltk/tetris.ml

   1 (***********************************************************************)
   2 (*                                                                     *)
   3 (*                 MLTk, Tcl/Tk interface of Objective Caml            *)
   4 (*                                                                     *)
   5 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
   6 (*               projet Cristal, INRIA Rocquencourt                    *)
   7 (*            Jacques Garrigue, Kyoto University RIMS                  *)
   8 (*                                                                     *)
   9 (*  Copyright 2002 Institut National de Recherche en Informatique et   *)
  10 (*  en Automatique and Kyoto University.  All rights reserved.         *)
  11 (*  This file is distributed under the terms of the GNU Library        *)
  12 (*  General Public License, with the special exception on linking      *)
  13 (*  described in file LICENSE found in the Objective Caml source tree. *)
  14 (*                                                                     *)
  15 (***********************************************************************)
  16
  17 (* $Id: tetris.ml 6385 2004-06-12 03:20:00Z garrigue $ *)
  18
  19 (* A Tetris game for LablTk *)
  20 (* written by Jun P. Furuse *)
  21
  22 open StdLabels
  23 open Tk
  24
  25 exception Done
  26
  27 type falling_block = {
  28     mutable pattern: int array list;
  29     mutable bcolor: int;
  30     mutable x: int;
  31     mutable y: int;
  32     mutable d: int;
  33     mutable alive: bool
  34   }
  35
  36 let stop_a_bit = 300
  37
  38 let field_width = 10
  39 let field_height = 20
  40
  41 let colors = [|
  42   `Color "red";
  43   `Color "yellow";
  44
  45   `Color "blue";
  46   `Color "orange";
  47
  48   `Color "magenta";
  49   `Color "green";
  50
  51   `Color "cyan"
  52 |]
  53
  54 (* Put here your favorite image files *)
  55 let backgrounds = [
  56   "Lambda2.back.gif"
  57 ]
  58
  59 (* blocks *)
  60 let block_size = 16
  61 let cell_border = 2
  62
  63 let blocks = [
  64   [ [|"0000";
  65       "0000";
  66       "1111";
  67       "0000" |];
  68
  69     [|"0010";
  70       "0010";
  71       "0010";
  72       "0010" |];
  73
  74     [|"0000";
  75       "0000";
  76       "1111";
  77       "0000" |];
  78
  79     [|"0010";
  80       "0010";
  81       "0010";
  82       "0010" |] ];
  83
  84   [ [|"0000";
  85       "0110";
  86       "0110";
  87       "0000" |];
  88
  89     [|"0000";
  90       "0110";
  91       "0110";
  92       "0000" |];
  93
  94     [|"0000";
  95       "0110";
  96       "0110";
  97       "0000" |];
  98
  99     [|"0000";
 100       "0110";
 101       "0110";
 102       "0000" |] ];
 103
 104   [ [|"0000";
 105       "0111";
 106       "0100";
 107       "0000" |];
 108
 109     [|"0000";
 110       "0110";
 111       "0010";
 112       "0010" |];
 113
 114     [|"0000";
 115       "0010";
 116       "1110";
 117       "0000" |];
 118
 119     [|"0100";
 120       "0100";
 121       "0110";
 122       "0000" |] ];
 123
 124   [ [|"0000";
 125       "0100";
 126       "0111";
 127       "0000" |];
 128
 129     [|"0000";
 130       "0110";
 131       "0100";
 132       "0100" |];
 133
 134     [|"0000";
 135       "1110";
 136       "0010";
 137       "0000" |];
 138
 139     [|"0010";
 140       "0010";
 141       "0110";
 142       "0000" |] ];
 143
 144   [ [|"0000";
 145       "1100";
 146       "0110";
 147       "0000" |];
 148
 149     [|"0010";
 150       "0110";
 151       "0100";
 152       "0000" |];
 153
 154     [|"0000";
 155       "1100";
 156       "0110";
 157       "0000" |];
 158
 159     [|"0010";
 160       "0110";
 161       "0100";
 162       "0000" |] ];
 163
 164   [ [|"0000";
 165       "0011";
 166       "0110";
 167       "0000" |];
 168
 169     [|"0100";
 170       "0110";
 171       "0010";
 172       "0000" |];
 173
 174     [|"0000";
 175       "0011";
 176       "0110";
 177       "0000" |];
 178
 179     [|"0000";
 180       "0100";
 181       "0110";
 182       "0010" |] ];
 183
 184   [ [|"0000";
 185       "0000";
 186       "1110";
 187       "0100" |];
 188
 189     [|"0000";
 190       "0100";
 191       "1100";
 192       "0100" |];
 193
 194     [|"0000";
 195       "0100";
 196       "1110";
 197       "0000" |];
 198
 199     [|"0000";
 200       "0100";
 201       "0110";
 202       "0100" |] ]
 203
 204 ]
 205
 206 let line_empty = int_of_string "0b1110000000000111"
 207 let line_full = int_of_string  "0b1111111111111111"
 208
 209 let decode_block dvec =
 210   let btoi d = int_of_string ("0b"^d) in
 211   Array.map ~f:btoi dvec
 212
 213 class cell t1 t2 t3 ~canvas ~x ~y = object
 214   val mutable color = 0
 215   method get = color
 216   method set ~color:col =
 217     if color = col then () else
 218     if color <> 0 && col = 0 then begin
 219       Canvas.move canvas t1
 220         ~x:(- block_size * (x + 1) -10 - cell_border * 2)
 221         ~y:(- block_size * (y + 1) -10 - cell_border * 2);
 222       Canvas.move canvas t2
 223         ~x:(- block_size * (x + 1) -10 - cell_border * 2)
 224         ~y:(- block_size * (y + 1) -10 - cell_border * 2);
 225       Canvas.move canvas t3
 226         ~x:(- block_size * (x + 1) -10 - cell_border * 2)
 227         ~y:(- block_size * (y + 1) -10 - cell_border * 2)
 228     end else begin
 229       Canvas.configure_rectangle canvas t2
 230         ~fill: colors.(col - 1)
 231         ~outline: colors.(col - 1);
 232       Canvas.configure_rectangle canvas t1
 233         ~fill: `Black
 234         ~outline: `Black;
 235       Canvas.configure_rectangle canvas t3
 236         ~fill: (`Color "light gray")
 237         ~outline: (`Color "light gray");
 238       if color = 0 && col <> 0 then begin
 239         Canvas.move canvas t1
 240           ~x: (block_size * (x+1)+10+ cell_border*2)
 241           ~y: (block_size * (y+1)+10+ cell_border*2);
 242         Canvas.move canvas t2
 243           ~x: (block_size * (x+1)+10+ cell_border*2)
 244           ~y: (block_size * (y+1)+10+ cell_border*2);
 245         Canvas.move canvas t3
 246           ~x: (block_size * (x+1)+10+ cell_border*2)
 247           ~y: (block_size * (y+1)+10+ cell_border*2)
 248       end
 249     end;
 250     color <- col
 251 end
 252
 253 let cell_get (c, cf) x y = cf.(y).(x) #get
 254
 255 let cell_set (c, cf) ~x ~y ~color =
 256   if x >= 0 && y >= 0 && Array.length cf > y && Array.length cf.(y) > x then
 257     let cur = cf.(y).(x) in
 258     if cur#get = color then () else cur#set ~color
 259
 260 let create_base_matrix ~cols ~rows =
 261   let m = Array.create_matrix ~dimx:rows ~dimy:cols (0,0) in
 262   for x = 0 to cols - 1 do for y = 0 to rows - 1 do
 263     m.(y).(x) <- (x,y)
 264   done done;
 265   m
 266
 267 let init fw =
 268   let scorev = Textvariable.create ()
 269   and linev = Textvariable.create ()
 270   and levv = Textvariable.create ()
 271   and namev = Textvariable.create ()
 272   in
 273   let f = Frame.create fw ~borderwidth: 2 in
 274   let c = Canvas.create f ~width: (block_size * 10)
 275                           ~height: (block_size * 20)
 276                           ~borderwidth: cell_border
 277                           ~relief: `Sunken
 278                           ~background: `Black
 279   and r = Frame.create f
 280   and r' = Frame.create f in
 281
 282   let nl = Label.create r ~text: "Next"  ~font: "variable" in
 283   let nc = Canvas.create r ~width: (block_size * 4)
 284                            ~height: (block_size * 4)
 285                            ~borderwidth: cell_border
 286                            ~relief: `Sunken
 287                            ~background: `Black in
 288   let scl = Label.create r ~text: "Score" ~font: "variable" in
 289   let sc = Label.create r ~textvariable: scorev ~font: "variable" in
 290   let lnl = Label.create r ~text: "Lines" ~font: "variable" in
 291   let ln = Label.create r ~textvariable: linev ~font: "variable" in
 292   let levl = Label.create r ~text: "Level" ~font: "variable" in
 293   let lev = Label.create r ~textvariable: levv ~font: "variable" in
 294   let newg = Button.create r ~text: "New Game" ~font: "variable" in
 295
 296   pack [f];
 297   pack [coe c; coe r; coe r'] ~side: `Left ~fill: `Y;
 298   pack [coe nl; coe nc] ~side: `Top;
 299   pack [coe scl; coe sc; coe lnl; coe ln; coe levl; coe lev; coe newg]
 300     ~side: `Top;
 301
 302   let cells_src = create_base_matrix ~cols:field_width ~rows:field_height in
 303   let cells =
 304     Array.map cells_src ~f:
 305       (Array.map ~f:
 306          begin fun (x,y) ->
 307            let t1 =
 308              Canvas.create_rectangle c
 309                ~x1:(-block_size - 8) ~y1:(-block_size - 8)
 310                ~x2:(-9)              ~y2:(-9)
 311            and t2 =
 312              Canvas.create_rectangle c
 313                ~x1:(-block_size - 10) ~y1:(-block_size - 10)
 314                ~x2:(-11)              ~y2:(-11)
 315            and t3 =
 316              Canvas.create_rectangle c
 317                ~x1:(-block_size - 12) ~y1:(-block_size - 12)
 318                ~x2:(-13)              ~y2:(-13)
 319            in
 320            Canvas.raise c t1;
 321            Canvas.raise c t2;
 322            Canvas.lower c t3;
 323            new cell ~canvas:c ~x ~y t1 t2 t3
 324          end)
 325   in
 326   let nexts_src = create_base_matrix ~cols:4 ~rows:4 in
 327   let nexts =
 328     Array.map nexts_src ~f:
 329       (Array.map ~f:
 330          begin fun (x,y) ->
 331            let t1 =
 332              Canvas.create_rectangle nc
 333                ~x1:(-block_size - 8) ~y1:(-block_size - 8)
 334                ~x2:(-9)              ~y2:(-9)
 335            and t2 =
 336              Canvas.create_rectangle nc
 337                ~x1:(-block_size - 10) ~y1:(-block_size - 10)
 338                ~x2:(-11)              ~y2:(-11)
 339            and t3 =
 340              Canvas.create_rectangle nc
 341                ~x1:(-block_size - 12) ~y1:(-block_size - 12)
 342                ~x2:(-13)              ~y2:(-13)
 343            in
 344            Canvas.raise nc t1;
 345            Canvas.raise nc t2;
 346            Canvas.lower nc t3;
 347            new cell ~canvas:nc ~x ~y t1 t2 t3
 348          end)
 349   in
 350   let game_over () = ()
 351   in
 352     (* What a mess ! *)
 353   [ coe f; coe c; coe r; coe nl; coe nc; coe scl; coe sc; coe levl; coe lev;
 354     coe lnl; coe ln ],
 355   newg, (c, cells), (nc, nexts), scorev, linev, levv, game_over
 356
 357
 358 let draw_block field ~color ~block ~x ~y =
 359   for iy = 0 to 3 do
 360     let base = ref 1 in
 361     let xd = block.(iy) in
 362     for ix = 0 to 3 do
 363       if xd land !base <> 0 then
 364         cell_set field ~x:(ix + x) ~y:(iy + y) ~color;
 365       base := !base lsl 1
 366     done
 367   done
 368
 369 let timer_ref = (ref None : Timer.t option ref)
 370 (* I know, this should be timer ref, but I'm not sure what should be
 371    the initial value ... *)
 372
 373 let remove_timer () =
 374   match !timer_ref with
 375     None -> ()
 376   | Some t -> Timer.remove t (* ; prerr_endline "removed!" *)
 377
 378 let do_after ~ms ~callback =
 379   timer_ref := Some (Timer.add ~ms ~callback)
 380
 381 let copy_block c =
 382   { pattern= !c.pattern;
 383     bcolor= !c.bcolor;
 384     x= !c.x;
 385     y= !c.y;
 386     d= !c.d;
 387     alive= !c.alive }
 388
 389 let _ =
 390   let top = openTk () in
 391   let lb = Label.create top
 392   and fw = Frame.create top
 393   in
 394   let set_message s = Label.configure lb ~text:s in
 395   pack [coe lb; coe fw] ~side: `Top;
 396   let score = ref 0 in
 397   let line = ref 0 in
 398   let level = ref 0 in
 399   let time = ref 1000 in
 400   let blocks = List.map ~f:(List.map ~f:decode_block) blocks in
 401   let field = Array.create 26 0 in
 402   let widgets, button, cell_field, next_field, scorev, linev, levv, game_over
 403       = init fw in
 404   let canvas = fst cell_field in
 405
 406   let init_field () =
 407     for i = 0 to 25 do
 408       field.(i) <- line_empty
 409     done;
 410     field.(23) <- line_full;
 411     for i = 0 to 19 do
 412       for j = 0 to 9 do
 413         cell_set cell_field ~x:j ~y:i ~color:0
 414       done
 415     done;
 416     for i = 0 to 3 do
 417       for j = 0 to 3 do
 418         cell_set next_field ~x:j ~y:i ~color:0
 419       done
 420     done
 421   in
 422
 423   let draw_falling_block fb =
 424     draw_block cell_field ~color: fb.bcolor
 425       ~block: (List.nth fb.pattern fb.d)
 426       ~x:     (fb.x - 3)
 427       ~y:     (fb.y - 3)
 428
 429   and erase_falling_block fb =
 430     draw_block cell_field ~color: 0
 431       ~block: (List.nth fb.pattern fb.d)
 432       ~x:     (fb.x - 3)
 433       ~y:     (fb.y - 3)
 434   in
 435
 436   let stone fb =
 437     for i=0 to 3 do
 438       let cur = field.(i + fb.y) in
 439       field.(i + fb.y) <-
 440          cur lor ((List.nth fb.pattern fb.d).(i) lsl fb.x)
 441     done;
 442     for i=0 to 2 do
 443       field.(i) <- line_empty
 444     done
 445
 446   and clear fb =
 447     let l = ref 0 in
 448     for i = 0 to 3 do
 449       if i + fb.y >= 3 && i + fb.y <= 22 then
 450         if field.(i + fb.y) = line_full then
 451           begin
 452             incr l;
 453             field.(i + fb.y) <- line_empty;
 454             for j = 0 to 9 do
 455               cell_set cell_field ~x:j ~y:(i + fb.y - 3) ~color:0
 456             done
 457           end
 458     done;
 459     !l
 460
 461   and fall_lines () =
 462     let eye = ref 22 (* bottom *)
 463     and cur = ref 22 (* bottom *)
 464     in
 465     try
 466       while !eye >= 3 do
 467         while field.(!eye) = line_empty do
 468           decr eye;
 469           if !eye = 2 then raise Done
 470         done;
 471         field.(!cur) <- field.(!eye);
 472         for j = 0 to 9 do
 473           cell_set cell_field ~x:j ~y:(!cur-3)
 474             ~color:(cell_get cell_field j (!eye-3))
 475         done;
 476         decr eye;
 477         decr cur
 478       done
 479     with Done -> ();
 480       for i = 3 to !cur do
 481         field.(i) <- line_empty;
 482         for j = 0 to 9 do
 483           cell_set cell_field ~x:j ~y:(i-3) ~color:0
 484         done
 485       done
 486   in
 487
 488   let next = ref 42 (* THE ANSWER *)
 489   and current =
 490     ref { pattern= [[|0;0;0;0|]]; bcolor=0; x=0; y=0; d=0; alive= false}
 491   in
 492
 493   let draw_next () =
 494     draw_block next_field ~color: (!next+1)
 495       ~block: (List.hd (List.nth blocks !next))
 496       ~x: 0 ~y: 0
 497
 498   and erase_next () =
 499     draw_block next_field ~color: 0
 500       ~block: (List.hd (List.nth blocks !next))
 501       ~x: 0 ~y: 0
 502   in
 503
 504   let set_nextblock () =
 505     current :=
 506        { pattern= (List.nth blocks !next);
 507          bcolor= !next+1;
 508          x=6; y= 1; d= 0; alive= true};
 509     erase_next ();
 510     next := Random.int 7;
 511     draw_next ()
 512   in
 513
 514   let death_check fb =
 515     try
 516       for i=0 to 3 do
 517         let cur = field.(i + fb.y) in
 518         if cur land ((List.nth fb.pattern fb.d).(i) lsl fb.x) <> 0
 519         then raise Done
 520       done;
 521       false
 522     with
 523       Done -> true
 524   in
 525
 526   let try_to_move m =
 527     if !current.alive then
 528       let sub m =
 529         if death_check m then false
 530         else
 531           begin
 532             erase_falling_block !current;
 533             draw_falling_block m;
 534             current := m;
 535             true
 536           end
 537       in
 538       if sub m then true
 539       else
 540         begin
 541           m.x <- m.x + 1;
 542           if sub m then true
 543           else
 544             begin
 545               m.x <- m.x - 2;
 546               sub m
 547             end
 548         end
 549     else false
 550   in
 551
 552   let image_load =
 553     let i = Canvas.create_image canvas
 554         ~x: (block_size * 5 + block_size / 2)
 555         ~y: (block_size * 10 + block_size / 2)
 556         ~anchor: `Center in
 557     Canvas.lower canvas i;
 558     let img = Imagephoto.create () in
 559     fun file ->
 560       try
 561         Imagephoto.configure img ~file: file;
 562         Canvas.configure_image canvas i ~image: img
 563       with
 564         _ ->
 565           begin
 566             Printf.eprintf "%s : No such image...\n" file;
 567             flush stderr
 568           end
 569   in
 570
 571   let add_score l =
 572     let pline = !line in
 573     if l <> 0 then
 574       begin
 575         line := !line + l;
 576         score := !score + l * l;
 577         set_message (Printf.sprintf "%d pts" (1 lsl ((l - 1) * 2)))
 578       end;
 579     Textvariable.set linev (string_of_int !line);
 580     Textvariable.set scorev (string_of_int !score);
 581
 582     if !line /10 <> pline /10 then
 583       (* update the background every 10 lines. *)
 584       begin
 585         let num_image = List.length backgrounds - 1 in
 586         let n = !line/10 in
 587         let n = if n > num_image then num_image else n in
 588         let file = List.nth backgrounds n in
 589         image_load file;
 590         incr level;
 591         Textvariable.set levv (string_of_int !level)
 592       end
 593   in
 594
 595   let rec newblock () =
 596     set_message "TETRIS";
 597     set_nextblock ();
 598     draw_falling_block !current;
 599     if death_check !current then
 600       begin
 601         !current.alive <- false;
 602         set_message "GAME OVER";
 603         game_over ()
 604       end
 605     else
 606       begin
 607         time := 1100 - (!level / 4 * 300) - ((!level mod 4) * 200);
 608         if !time < 60 - !level * 3 then time := 60 - !level * 3;
 609         do_after ~ms:stop_a_bit ~callback:loop
 610       end
 611
 612   and loop () =
 613     let m = copy_block current in
 614     m.y <- m.y + 1;
 615     if death_check m then
 616       begin
 617         !current.alive <- false;
 618         stone !current;
 619         do_after ~ms:stop_a_bit ~callback:
 620           begin fun () ->
 621             let l = clear !current in
 622             if l > 0 then
 623               do_after ~ms:stop_a_bit ~callback:
 624                 begin fun () ->
 625                   fall_lines ();
 626                   add_score l;
 627                   do_after ~ms:stop_a_bit ~callback:newblock
 628                 end
 629             else
 630               newblock ()
 631           end
 632       end
 633     else
 634       begin
 635         erase_falling_block !current;
 636         draw_falling_block m;
 637         current := m;
 638         do_after ~ms:!time ~callback:loop
 639       end
 640   in
 641
 642   let bind_game w =
 643     bind w ~events:[`KeyPress] ~fields:[`KeySymString] ~action:
 644       begin fun e ->
 645         match e.ev_KeySymString with
 646         | "h"|"Left" ->
 647             let m = copy_block current in
 648             m.x <- m.x - 1;
 649             ignore (try_to_move m)
 650         | "j"|"Up" ->
 651             let m = copy_block current in
 652             m.d <- m.d + 1;
 653             if m.d = List.length m.pattern then m.d <- 0;
 654             ignore (try_to_move m)
 655         | "k"|"Down" ->
 656             let m = copy_block current in
 657             m.d <- m.d - 1;
 658             if m.d < 0 then m.d <- List.length m.pattern - 1;
 659             ignore (try_to_move m)
 660         | "l"|"Right" ->
 661             let m = copy_block current in
 662             m.x <- m.x + 1;
 663             ignore (try_to_move m)
 664         | "m" ->
 665             remove_timer ();
 666             loop ()
 667         | "space" ->
 668             if !current.alive then
 669               begin
 670                 let m = copy_block current
 671                 and n = copy_block current in
 672                 while
 673                   m.y <- m.y + 1;
 674                   if death_check m then false
 675                   else begin n.y <- m.y; true end
 676                 do () done;
 677                 erase_falling_block !current;
 678                 draw_falling_block n;
 679                 current := n;
 680                 remove_timer ();
 681                 loop ()
 682               end
 683         | _ -> ()
 684       end
 685   in
 686
 687   let game_init () =
 688     (* Game Initialization *)
 689     set_message "Initializing ...";
 690     remove_timer ();
 691     image_load (List.hd backgrounds);
 692     time := 1000;
 693     score := 0;
 694     line := 0;
 695     level := 1;
 696     add_score 0;
 697     init_field ();
 698     next := Random.int 7;
 699     set_message "Welcome to TETRIS";
 700     set_nextblock ();
 701     draw_falling_block !current;
 702     do_after ~ms:!time ~callback:loop
 703   in
 704     (* As an applet, it was required... *)
 705     (* List.iter f: bind_game widgets; *)
 706   bind_game top;
 707   Button.configure button ~command: game_init;
 708   game_init ()
 709
 710 let _ = Printexc.print mainLoop ()