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
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
|
open Core
open Main
module G = struct
exception Invalid_pos
type loc1 = int * int
type loc = loc1 * loc1
type c = (* P1 <-> X || P2 <-> O *)
| Empty
| X
| O
| T
type 'a r = 'a * 'a * 'a
type 'a morpion = ('a r * 'a r * 'a r) * c
(* On enregistre dans une grille de morpion le résultat
pour cette grille : non attribué (Empty), X, O, ou nul (T)
Pour y acceder, utiliser reduct : 'a morpion -> c *)
let reduct (_, r) = r
type game = game_status * c morpion morpion * loc1 option
(* all_p1 : loc1 list *)
let all_p1 = [ 1,1; 1,2; 1,3; 2,1; 2,2; 2,3; 3,1; 3,2; 3,3 ]
(* all_w_s : loc1 list list *)
let all_w_p1l = [
[ 1,1; 1,2; 1,3 ];
[ 2,1; 2,2; 2,3 ];
[ 3,1; 3,2; 3,3 ];
[ 1,1; 2,1; 3,1 ];
[ 1,2; 2,2; 3,2 ];
[ 1,3; 2,3; 3,3 ];
[ 1,1; 2,2; 3,3 ];
[ 1,3; 2,2; 3,1 ];
]
(* encode : loc -> string *)
let encode ((xg, yg), (xp, yp)) =
Format.sprintf "%d %d %d %d" xg yg xp yp
(* decode : string -> loc *)
let decode s =
Scanf.sscanf s "%d %d %d %d"
(fun xg yg xp yp -> (xg, yg), (xp, yp))
(* getp0 : ('a, 'a, 'a) -> int -> 'a *)
let getp0 (a, b, c) x = match x with
| 1 -> a | 2 -> b | 3 -> c
| _ -> raise Invalid_pos
(* getp1 : 'a morpion -> loc1 -> 'a *)
let getp1 (m, _) (px, py) =
getp0 (getp0 m px) py
(* getp : 'a morpion morpion -> loc2 -> 'a *)
let getp m (pg, pp) =
getp1 (getp1 m pg) pp
(* reduce_m : ('a -> c) -> 'a morpion -> c *)
let reduce_m rf m =
match
all_w_p1l
|> List.map (List.map (fun x -> rf (getp1 m x)))
|> List.map (function
| l when List.for_all ((=) X) l -> X
| l when List.for_all ((=) O) l -> O
| l when List.exists ((=) X) l && List.exists ((=) O) l -> T
| l when List.exists ((=) T) l -> T
| _ -> Empty)
with
| l when List.exists ((=) X) l -> X
| l when List.exists ((=) O) l -> O
| l when List.exists ((=) Empty) l -> Empty
| _ -> T
(* setp0 : ('a, 'a, 'a) -> int -> 'a -> ('a, 'a, 'a) *)
let setp0 (a, b, c) x v = match x with
| 1 -> (v, b, c)
| 2 -> (a, v, c)
| 3 -> (a, b, v)
| _ -> raise Invalid_pos
(* setp1 : 'a morpion -> loc1 -> 'a -> ('a -> 'c) -> 'a morpion *)
let setp1 (m, r) (px, py) v rf =
let k = setp0 m px (setp0 (getp0 m px) py v) in
(k, if r = Empty then reduce_m rf (k, r) else r)
(* pourquoi ce if ? parce que si quelqu'un a déjà gagné un petit morpion,
alors même si l'adversaire aligne trois cases dedans APRES,
le petit morpion reste attribué à la même personne. *)
let setp1p (m, r) (px, py) v =
setp1 (m, r) (px, py) v (fun x -> x)
(* setp : 'a morpion morpion -> loc2 -> 'a -> 'a morpion morpion *)
let setp m (pg, pp) v =
let im = setp1p (getp1 m pg) pp v in
let om = setp1 m pg im reduct in
om
(* r : 'a -> ('a, 'a, 'a) *)
let r x = (x, x, x)
(* *************************** *)
(* Début du code intéressant ! *)
let id = "morpion_rec"
let name = "Morpion récursif!"
let new_game =
TurnOf P1, (r (r (r (r Empty), Empty)), Empty), None
let full_pm m =
List.for_all (fun p -> getp1 m p <> Empty) all_p1
let possibilities (s, m, lg) =
let pg_poss = match lg with
| None -> all_p1
| Some x -> [x]
in
List.flatten
(List.map (fun pg ->
all_p1
|> List.filter (fun pp -> getp m (pg, pp) = Empty)
|> List.map (fun pp -> (pg, pp)))
pg_poss)
|> List.map encode
let play (gs, m, pgo) act =
let (pg, pp) = decode act in
match gs with
| TurnOf player when
(match pgo with
| None -> true
| Some x -> pg = x)
&& getp m (pg, pp) = Empty
->
let op = other_player player in
let new_m = setp m (pg, pp) (match player with P1 -> X | P2 -> O) in
let new_s = match reduct new_m with
| Empty -> TurnOf op
| X -> Won P1
| O -> Won P2
| T -> Tie
in
(new_s, new_m, if full_pm (getp1 new_m pp) then None else Some pp)
| TurnOf x -> (Eliminated x, m, pgo)
| _ -> raise (Eliminated_ex "not someone's turn!")
let s (s, _, _) = s
(* ************************* *)
(* Visualisation graphique ! *)
open Graphics
open Main
open G_util
let subpos (x1, y1, x2, y2) (l, c) =
let dx, dy = (x2 - x1) / 3, (y2 - y1) / 3 in
x1 + (l-1) * dx, y1 + (c-1) * dy, x1 + l * dx, y1 + c * dy
let margin (x1, y1, x2, y2) m =
(x1+m, y1+m, x2-m, y2-m)
let disp_l lw pos =
let x1, y1, x2, y2 = pos in
function
| X ->
set_line_width lw;
set_color p1c;
draw_segments
[| x1, y1, x2, y2;
x1, y2, x2, y1 |];
set_line_width 1
| O ->
set_line_width lw;
set_color p2c;
draw_circle ((x1+x2)/2) ((y1+y2)/2) (min (x2-x1) (y2-y1) / 2);
set_line_width 1
| _ -> ()
let disp_r sdf box mor =
let x1, y1, x2, y2 = box in
let dx, dy = (x2 - x1) / 3, (y2 - y1) / 3 in
let x12, x23 = x1 + dx, x1 + 2 * dx in
let y12, y23 = y1 + dy, y1 + 2 * dy in
set_color black;
draw_segments
[| x12, y1, x12, y2;
x23, y1, x23, y2;
x1, y12, x2, y12;
x1, y23, x2, y23 |];
List.iter (fun p -> sdf (margin (subpos box p) 6) (getp1 mor p)) all_p1;
disp_l 2 box (reduct mor)
let gbox () =
let cx, cy = center() in
let box = cx - 200, cy - 200, cx + 200, cy + 200 in
box
let display_game (s, mor, q) (pn1, pn2) =
let box = gbox () in
disp_r (disp_r (disp_l 1)) box mor;
begin match q, s with
| Some p, TurnOf player ->
let x1, y1, x2, y2 = margin (subpos box p) 3 in
set_color (pc player);
draw_rect x1 y1 (x2-x1) (y2-y1)
| _ -> ()
end
let in_box (x1, y1, x2, y2) (x, y) =
(x >= x1 && x <= x2 && y >= y1 && y <= y2)
let gui_act_at g xy =
let box = gbox () in
try
let pg = List.find (fun p -> in_box (subpos box p) xy) all_p1 in
let sbox = subpos box pg in
let pp = List.find (fun p -> in_box (subpos sbox p) xy) all_p1 in
encode (pg, pp)
with Not_found -> ""
end
|
