+++ /dev/null
-(* $Id$ *)
-
-(* The game logic *)
-
-type color = [`none|`white|`black]
-
-module type BoardSpec = sig
- type t
- val size : int
- val get : t -> x:int -> y:int -> color
- val set : t -> x:int -> y:int -> color:color -> unit
-end
-
-module Board (Spec : BoardSpec) = struct
- open Spec
- let size = size
-
- let on_board x y =
- x >= 0 && x < size && y >= 0 && y < size
-
- let rec string board ~x ~y ~dx ~dy ~color l =
- let x = x+dx and y = y+dy in
- if on_board x y then
- let col = get board ~x ~y in
- if col = (color : [`white|`black] :> color) then l else
- if col = `none then [] else
- string board ~x ~y ~dx ~dy ~color ((x,y)::l)
- else []
-
- let find_swaps board ~x ~y ~color =
- if get board ~x ~y <> `none then [] else
- List.fold_left [-1,-1; -1,0; -1,1; 0,-1; 0,1; 1,-1; 1,0; 1,1]
- ~init:[]
- ~f:(fun acc (dx,dy) -> string board ~x ~y ~dx ~dy ~color [] @ acc)
-
- let action board ~x ~y ~color =
- let swaps = find_swaps board ~x ~y ~color in
- if swaps = [] then false else begin
- List.iter ((x,y)::swaps)
- ~f:(fun (x,y) -> set board ~x ~y ~color:(color :> color));
- true
- end
-
- let check_impossible board ~color =
- try
- for x = 0 to size - 1 do for y = 0 to size - 1 do
- if find_swaps board ~x ~y ~color <> [] then raise Exit
- done done;
- true
- with Exit -> false
-
- let count_cells board =
- let w = ref 0 and b = ref 0 in
- for x = 0 to size - 1 do for y = 0 to size - 1 do
- match get board ~x ~y with
- `white -> incr w
- | `black -> incr b
- | `none -> ()
- done done;
- (!w,!b)
-end
-
-(* GUI *)
-
-open GMain
-
-(* Toplevel window *)
-
-let window = GWindow.window ~title:"pousse" ()
-
-(* Create pixmaps *)
-
-let pixdraw =
- GDraw.pixmap ~window ~width:40 ~height:40 ~mask:true ()
-let pixdraw1 =
- GDraw.pixmap ~window ~width:40 ~height:40 ~mask:true ()
-let pixdraw2 =
- GDraw.pixmap ~window ~width:40 ~height:40 ~mask:true ()
-
-let _ =
- pixdraw1#set_foreground `BLACK;
- pixdraw1#arc ~x:3 ~y:3 ~width:34 ~height:34 ~filled:true ();
- pixdraw2#set_foreground `WHITE;
- pixdraw2#arc ~x:3 ~y:3 ~width:34 ~height:34 ~filled:true ();
- pixdraw2#set_foreground `BLACK;
- pixdraw2#arc ~x:3 ~y:3 ~width:34 ~height:34 ()
-
-(* The cell class: a button with a pixmap on it *)
-
-class cell ?packing ?show () =
- let button = GButton.button ?packing ?show () in
-object (self)
- inherit GObj.widget button#as_widget
- method connect = button#connect
- val mutable color : color = `none
- val pm = GMisc.pixmap pixdraw ~packing:button#add ()
- method color = color
- method set_color col =
- if col <> color then begin
- color <- col;
- pm#set_pixmap
- (match col with `none -> pixdraw
- | `black -> pixdraw1
- | `white -> pixdraw2)
- end
-end
-
-module RealBoard = Board (
- struct
- type t = cell array array
- let size = 8
- let get (board : t) ~x ~y = board.(x).(y)#color
- let set (board : t) ~x ~y ~color = board.(x).(y)#set_color color
- end
-)
-
-(* Conducting a game *)
-
-open RealBoard
-
-class game ~(frame : #GContainer.container) ~(label : #GMisc.label)
- ~(statusbar : #GMisc.statusbar) =
- let table = GPack.table ~columns:size ~rows:size ~packing:frame#add () in
-object (self)
- val cells =
- Array.init size
- ~f:(fun i -> Array.init size
- ~f:(fun j -> new cell ~packing:(table#attach ~top:i ~left:j) ()))
- val label = label
- val turn = statusbar#new_context ~name:"turn"
- val messages = statusbar#new_context ~name:"messages"
- val mutable current_color = `black
- method board = cells
- method table = table
- method player = current_color
-
- method swap_players () =
- current_color <-
- match current_color with
- `white -> turn#pop (); turn#push "Player is black"; `black
- | `black -> turn#pop (); turn#push "Player is white"; `white
-
- method finish () =
- turn#pop ();
- let w, b = count_cells cells in
- turn#push
- (if w > b then "White wins" else
- if w < b then "Black wins" else
- "Game is a draw");
- ()
-
- method update_label () =
- let w, b = count_cells cells in
- label#set_text (Printf.sprintf "White: %d Black: %d " w b)
-
- method play x y =
- if action cells ~x ~y ~color:current_color then begin
- self#update_label ();
- self#swap_players ();
- if check_impossible cells ~color:current_color then begin
- self#swap_players ();
- if check_impossible cells ~color:current_color then self#finish ()
- end
- end else
- messages#flash "You cannot play there"
-
- initializer
- for i = 0 to size-1 do for j = 0 to size-1 do
- let cell = cells.(i).(j) in
- cell#connect#enter ~callback:cell#misc#grab_focus;
- cell#connect#clicked ~callback:(fun () -> self#play i j)
- done done;
- List.iter ~f:(fun (x,y,col) -> cells.(x).(y)#set_color col)
- [ 3,3,`black; 4,4,`black; 3,4,`white; 4,3,`white ];
- self#update_label ();
- turn#push "Player is black";
- ()
-end
-
-(* Graphical elements *)
-
-let vbox = GPack.vbox ~packing:window#add ()
-let frame = GBin.frame ~shadow_type:`IN ~packing:vbox#add ()
-let hbox = GPack.hbox ~packing:vbox#pack ()
-
-let bar = GMisc.statusbar ~packing:hbox#add ()
-
-let frame2 = GBin.frame ~shadow_type:`IN ~packing:hbox#pack ()
-let label =
- GMisc.label ~justify:`LEFT ~xpad:5 ~xalign:0.0 ~packing:frame2#add ()
-
-let game = new game ~frame ~label ~statusbar:bar
-
-(* Start *)
-
-let _ =
- window#connect#destroy ~callback:Main.quit;
- window#show ();
- Main.main ()
projects / helm.git / blobdiff