X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;ds=sidebyside;f=helm%2FDEVEL%2Flablgtk%2Flablgtk_20000829-0.1.0%2Fexamples%2Fpousse.ml;fp=helm%2FDEVEL%2Flablgtk%2Flablgtk_20000829-0.1.0%2Fexamples%2Fpousse.ml;h=ecf0dff3ab9ce366d8cd60590cc6385ca4c59096;hb=2ee84a2a641938988703e329aef9fc3c5eb5aacf;hp=0000000000000000000000000000000000000000;hpb=34d83812af9b7064cc8f735c2a78169881140010;p=helm.git

diff --git a/helm/DEVEL/lablgtk/lablgtk_20000829-0.1.0/examples/pousse.ml b/helm/DEVEL/lablgtk/lablgtk_20000829-0.1.0/examples/pousse.ml
new file mode 100644
index 000000000..ecf0dff3a
--- /dev/null
+++ b/helm/DEVEL/lablgtk/lablgtk_20000829-0.1.0/examples/pousse.ml
@@ -0,0 +1,199 @@
+(* $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 ()