X-Git-Url: http://matita.cs.unibo.it/gitweb/?p=helm.git;a=blobdiff_plain;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=0000000000000000000000000000000000000000;hp=ecf0dff3ab9ce366d8cd60590cc6385ca4c59096;hb=3ef089a4c58fbe429dd539af6215991ecbe11ee2;hpb=1c7fb836e2af4f2f3d18afd0396701f2094265ff 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 deleted file mode 100644 index ecf0dff3a..000000000 --- a/helm/DEVEL/lablgtk/lablgtk_20000829-0.1.0/examples/pousse.ml +++ /dev/null @@ -1,199 +0,0 @@ -(* $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 ()