1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
|
(***********************************************************************)
(* *)
(* MLTk, Tcl/Tk interface of OCaml *)
(* *)
(* Francois Rouaix, Francois Pessaux, Jun Furuse and 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 found in the OCaml source tree. *)
(* *)
(***********************************************************************)
(* $Id$ *)
open Tk;;
let dcoupe_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 pices = ref [] in
for x = 0 to nx - 1 do
for y = 0 to ny - 1 do
let pice = Imagephoto.create ~width:tx ~height:ty () in
Imagephoto.copy ~src:img
~src_area:(x * tx, y * ty, (x + 1) * tx, (y + 1) * ty) pice;
pices := pice :: !pices
done
done;
(tx, ty, List.tl !pices);;
let remplir_taquin c nx ny tx ty pices =
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 pices in
for x = 0 to nx - 1 do
for y = 0 to ny - 1 do
match !p with
| [] -> ()
| pice :: reste ->
taquin.(x).(y) <-
Canvas.create_image
~x:(x * tx) ~y:(y * ty)
~image:pice ~anchor:`Nw ~tags:["pice"] c;
p := reste
done
done;
let dplacer x y =
let pice = taquin.(x).(y) in
Canvas.coords_set c pice
~xys:[!trou_x * tx, !trou_y * ty];
Canvas.coords_set c trou
~xys:[x * tx, y * ty; tx, ty];
taquin.(!trou_x).(!trou_y) <- pice;
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 dplacer x y in
Canvas.bind ~events:[`ButtonPress]
~fields:[`MouseX; `MouseY] ~action:jouer c (`Tag "pice");;
let rec permutation = function
| [] -> []
| l -> let n = Random.int (List.length l) in
let (lment, reste) = partage l n in
lment :: permutation reste
and partage l n =
match l with
| [] -> failwith "partage"
| tte :: reste ->
if n = 0 then (tte, reste) else
let (lment, reste') = partage reste (n - 1) in
(lment, tte :: 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, pices) = dcoupe_image img nx ny in
remplir_taquin c nx ny tx ty (permutation pices);
pack [c];
let quit = Button.create ~text:"Quit" ~command:closeTk fp in
let help_lines =
["Pour jouer, cliquer sur une des pices";
"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;;
|
