]> matita.cs.unibo.it Git - helm.git/blob - helm/DEVEL/lablgtk/lablgtk_20000829-0.1.0/examples/pousse.ml
* new semantics with 2 continuations
[helm.git] / helm / DEVEL / lablgtk / lablgtk_20000829-0.1.0 / examples / pousse.ml
1 (* $Id$ *)
2
3 (* The game logic *)
4
5 type color = [`none|`white|`black]
6
7 module type BoardSpec = sig
8   type t
9   val size : int
10   val get : t -> x:int -> y:int -> color
11   val set : t -> x:int -> y:int -> color:color -> unit
12 end
13
14 module Board (Spec : BoardSpec) = struct
15   open Spec
16   let size = size
17
18   let on_board x y =
19     x >= 0 && x < size && y >= 0 && y < size
20
21   let rec string board ~x ~y ~dx ~dy ~color l =
22     let x = x+dx and y = y+dy in
23     if on_board x y then
24       let col = get board ~x ~y in 
25       if col = (color : [`white|`black] :> color) then l else
26       if col = `none then [] else
27       string board ~x ~y ~dx ~dy ~color ((x,y)::l)
28     else []
29
30   let find_swaps board ~x ~y ~color =
31     if get board ~x ~y <> `none then [] else
32     List.fold_left [-1,-1; -1,0; -1,1; 0,-1; 0,1; 1,-1; 1,0; 1,1]
33       ~init:[]
34       ~f:(fun acc (dx,dy) -> string board ~x ~y ~dx ~dy ~color [] @ acc)
35
36   let action board ~x ~y ~color =
37     let swaps = find_swaps board ~x ~y ~color in
38     if swaps = [] then false else begin
39       List.iter ((x,y)::swaps)
40         ~f:(fun (x,y) -> set board ~x ~y ~color:(color :> color));
41       true
42     end
43
44   let check_impossible board ~color =
45     try
46       for x = 0 to size - 1 do for y = 0 to size - 1 do
47         if find_swaps board ~x ~y ~color <> [] then raise Exit
48       done done;
49       true
50     with Exit -> false
51
52   let count_cells board =
53     let w = ref 0 and b = ref 0 in
54     for x = 0 to size - 1 do for y = 0 to size - 1 do
55       match get board ~x ~y with
56         `white -> incr w
57       | `black -> incr b
58       | `none -> ()
59     done done;
60     (!w,!b)
61 end
62
63 (* GUI *)
64
65 open GMain
66
67 (* Toplevel window *)
68
69 let window = GWindow.window ~title:"pousse" ()
70
71 (* Create pixmaps *)
72
73 let pixdraw =
74   GDraw.pixmap ~window ~width:40 ~height:40 ~mask:true ()
75 let pixdraw1 =
76   GDraw.pixmap ~window ~width:40 ~height:40 ~mask:true ()
77 let pixdraw2 =
78   GDraw.pixmap ~window ~width:40 ~height:40 ~mask:true ()
79
80 let _ =
81   pixdraw1#set_foreground `BLACK;
82   pixdraw1#arc ~x:3 ~y:3 ~width:34 ~height:34 ~filled:true ();
83   pixdraw2#set_foreground `WHITE;
84   pixdraw2#arc ~x:3 ~y:3 ~width:34 ~height:34 ~filled:true ();
85   pixdraw2#set_foreground `BLACK;
86   pixdraw2#arc ~x:3 ~y:3 ~width:34 ~height:34 ()
87
88 (* The cell class: a button with a pixmap on it *)
89
90 class cell ?packing ?show () =
91   let button = GButton.button ?packing ?show () in
92 object (self)
93   inherit GObj.widget button#as_widget
94   method connect = button#connect
95   val mutable color : color = `none
96   val pm = GMisc.pixmap pixdraw ~packing:button#add ()
97   method color = color
98   method set_color col =
99     if col <> color then begin
100       color <- col;
101       pm#set_pixmap
102         (match col with `none -> pixdraw
103         | `black -> pixdraw1
104         | `white -> pixdraw2)
105     end
106 end
107
108 module RealBoard = Board (
109   struct
110     type t = cell array array
111     let size = 8
112     let get (board : t) ~x ~y = board.(x).(y)#color
113     let set (board : t) ~x ~y ~color = board.(x).(y)#set_color color
114   end
115 )
116
117 (* Conducting a game *)
118
119 open RealBoard
120
121 class game ~(frame : #GContainer.container) ~(label : #GMisc.label)
122     ~(statusbar : #GMisc.statusbar) =
123   let table = GPack.table ~columns:size ~rows:size ~packing:frame#add () in
124 object (self)
125   val cells =
126     Array.init size
127       ~f:(fun i -> Array.init size
128           ~f:(fun j -> new cell ~packing:(table#attach ~top:i ~left:j) ()))
129   val label = label
130   val turn = statusbar#new_context ~name:"turn"
131   val messages = statusbar#new_context ~name:"messages"
132   val mutable current_color = `black
133   method board = cells
134   method table = table
135   method player = current_color
136
137   method swap_players () =
138     current_color <-
139       match current_color with
140         `white -> turn#pop (); turn#push "Player is black"; `black
141       | `black -> turn#pop (); turn#push "Player is white"; `white
142
143   method finish () =
144     turn#pop ();
145     let w, b = count_cells cells in
146     turn#push
147       (if w > b then "White wins" else
148        if w < b then "Black wins" else
149        "Game is a draw");
150     ()
151
152   method update_label () =
153     let w, b = count_cells cells in
154     label#set_text (Printf.sprintf "White: %d Black: %d " w b)
155
156   method play x y =
157     if action cells ~x ~y ~color:current_color then begin
158       self#update_label ();
159       self#swap_players ();
160       if check_impossible cells ~color:current_color then begin
161         self#swap_players ();
162         if check_impossible cells ~color:current_color then self#finish ()
163       end
164     end else
165       messages#flash "You cannot play there"
166
167   initializer
168     for i = 0 to size-1 do for j = 0 to size-1 do
169       let cell = cells.(i).(j) in
170       cell#connect#enter ~callback:cell#misc#grab_focus;
171       cell#connect#clicked ~callback:(fun () -> self#play i j)
172     done done;
173     List.iter ~f:(fun (x,y,col) -> cells.(x).(y)#set_color col)
174       [ 3,3,`black; 4,4,`black; 3,4,`white; 4,3,`white ];
175     self#update_label ();
176     turn#push "Player is black";
177     ()
178 end
179
180 (* Graphical elements *)
181
182 let vbox = GPack.vbox ~packing:window#add ()
183 let frame = GBin.frame ~shadow_type:`IN ~packing:vbox#add ()
184 let hbox = GPack.hbox ~packing:vbox#pack ()
185
186 let bar = GMisc.statusbar ~packing:hbox#add ()
187
188 let frame2 = GBin.frame ~shadow_type:`IN ~packing:hbox#pack ()
189 let label =
190   GMisc.label ~justify:`LEFT ~xpad:5 ~xalign:0.0 ~packing:frame2#add ()
191
192 let game = new game ~frame ~label ~statusbar:bar
193
194 (* Start *)
195
196 let _ =
197   window#connect#destroy ~callback:Main.quit;
198   window#show ();
199   Main.main ()