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 ()