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