diff options
-rw-r--r-- | otherlibs/labltk/example/taquin.ml | 142 |
1 files changed, 142 insertions, 0 deletions
diff --git a/otherlibs/labltk/example/taquin.ml b/otherlibs/labltk/example/taquin.ml new file mode 100644 index 000000000..4c90365ed --- /dev/null +++ b/otherlibs/labltk/example/taquin.ml @@ -0,0 +1,142 @@ +(*************************************************************************) +(* *) +(* Objective Caml LablTk library *) +(* *) +(* Pierre Weis, projet Cristal, INRIA Rocquencourt *) +(* Jacques Garrigue, Kyoto University RIMS *) +(* *) +(* 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. *) +(* *) +(*************************************************************************) + +(* $Id$ *) + +open Tk;; + +let d�coupe_image img nx ny = + let l = Imagephoto.width img + and h = Imagephoto.height img in + let tx = l / nx and ty = h / ny in + let pi�ces = ref [] in + for x = 0 to nx - 1 do + for y = 0 to ny - 1 do + let pi�ce = Imagephoto.create ~width:tx ~height:ty () in + Imagephoto.copy ~src:img + ~src_area:(x * tx, y * ty, (x + 1) * tx, (y + 1) * ty) pi�ce; + pi�ces := pi�ce :: !pi�ces + done + done; + (tx, ty, List.tl !pi�ces);; + +let remplir_taquin c nx ny tx ty pi�ces = + let trou_x = ref (nx - 1) + and trou_y = ref (ny - 1) in + let trou = + Canvas.create_rectangle + ~x1:(!trou_x * tx) ~y1:(!trou_y * ty) ~x2:tx ~y2:ty c in + let taquin = Array.make_matrix nx ny trou in + let p = ref pi�ces in + for x = 0 to nx - 1 do + for y = 0 to ny - 1 do + match !p with + | [] -> () + | pi�ce :: reste -> + taquin.(x).(y) <- + Canvas.create_image + ~x:(x * tx) ~y:(y * ty) + ~image:pi�ce ~anchor:`Nw ~tags:["pi�ce"] c; + p := reste + done + done; + let d�placer x y = + let pi�ce = taquin.(x).(y) in + Canvas.coords_set c pi�ce + ~xys:[!trou_x * tx, !trou_y * ty]; + Canvas.coords_set c trou + ~xys:[x * tx, y * ty; tx, ty]; + taquin.(!trou_x).(!trou_y) <- pi�ce; + taquin.(x).(y) <- trou; + trou_x := x; trou_y := y in + let jouer ei = + let x = ei.ev_MouseX / tx and y = ei.ev_MouseY / ty in + if x = !trou_x && (y = !trou_y - 1 || y = !trou_y + 1) + || y = !trou_y && (x = !trou_x - 1 || x = !trou_x + 1) + then d�placer x y in + Canvas.bind ~events:[`ButtonPress] + ~fields:[`MouseX; `MouseY] ~action:jouer c (`Tag "pi�ce");; + +let rec permutation = function + | [] -> [] + | l -> let n = Random.int (List.length l) in + let (�l�ment, reste) = partage l n in + �l�ment :: permutation reste + +and partage l n = + match l with + | [] -> failwith "partage" + | t�te :: reste -> + if n = 0 then (t�te, reste) else + let (�l�ment, reste') = partage reste (n - 1) in + (�l�ment, t�te :: reste');; + +let create_filled_text parent lines = + let lnum = List.length lines + and lwidth = + List.fold_right + (fun line max -> + let l = String.length line in + if l > max then l else max) + lines 1 in + let txtw = Text.create ~width:lwidth ~height:lnum parent in + List.iter + (fun line -> + Text.insert ~index:(`End, []) ~text:line txtw; + Text.insert ~index:(`End, []) ~text:"\n" txtw) + lines; + txtw;; + +let give_help parent lines () = + let help_window = Toplevel.create parent in + Wm.title_set help_window "Help"; + + let help_frame = Frame.create help_window in + + let help_txtw = create_filled_text help_frame lines in + + let quit_help () = destroy help_window in + let ok_button = Button.create ~text:"Ok" ~command:quit_help help_frame in + + pack ~side:`Bottom [help_txtw]; + pack ~side:`Bottom [ok_button ]; + pack [help_frame];; + +let taquin nom_fichier nx ny = + let fp = openTk () in + Wm.title_set fp "Taquin"; + let img = Imagephoto.create ~file:nom_fichier () in + let c = + Canvas.create ~background:`Black + ~width:(Imagephoto.width img) + ~height:(Imagephoto.height img) fp in + let (tx, ty, pi�ces) = d�coupe_image img nx ny in + remplir_taquin c nx ny tx ty (permutation pi�ces); + pack [c]; + + let quit = Button.create ~text:"Quit" ~command:closeTk fp in + let help_lines = + ["Pour jouer, cliquer sur une des pi�ces"; + "entourant le trou"; + ""; + "To play, click on a part around the hole"] in + let help = + Button.create ~text:"Help" ~command:(give_help fp help_lines) fp in + pack ~side:`Left ~fill:`X [quit] ; + pack ~side:`Left ~fill:`X [help] ; + mainLoop ();; + +if !Sys.interactive then () else +begin taquin "Lambda2.back.gif" 4 4; exit 0 end;; |