type piece = Black | White
type move = Pass | Square of int

open Movetable
open Printf
  
let int_of_square = function
    Some Black -> 0
  | None -> 1
  | Some White -> 2

let square_of_int = 
  let squares = [|Some Black; None; Some White|] in
  function i -> squares.(i)

external int_of_piece : piece -> int = "%identity"
	
let piece_of_int =
  let pieces = [|Black; White|] in function i -> pieces.(i)

(*  nextSquare takes a direction -- 0 - 7, meaning north to northwest,
    clockwise -- and a square -- 0 - 63 -- and returns the next square
    in direction dir, or -1 if sqare is already at an edge.
*)
let nextSquare =
  let table = Array.create_matrix 8 64 None
  and ops = [|-1,0; -1,1; 0,1; 1,1; 1,0; 1,-1; 0,-1; -1,-1|] in
  for dir = 0 to 7 do
    let rd, cd = ops.(dir) in
    for row = 0 to 7 do
      for col = 0 to 7 do
	let square = row * 8 + col
	and rp = row + rd
	and cp = col + cd in
	if rp >= 0 && rp < 8 && cp >= 0 && cp < 8 then
	  table.(dir).(square) <- Some (rp * 8 + cp)
      done
    done
  done;
  fun dir square -> table.(dir).(square)

(* adding dirOffset.(dir) to a square index returns the next square in
   direction dir.
*)
let dirOffset = [|-8; -7; 1; 9; 8; 7; -1; -9|]

(* searchDirs : square -> dirs list
   Suppose you want to check if square is one side of a sandwich.
   This function returns all the directions to look in for a possible
   sandwich with square as one end of it.
*)    
let searchDirs =
  let tl = [2;3;4]			(*top left squares*)
  and t = [2;3;4;5;6]			(*top*)
  and tr = [4;5;6]			(*top right*)
  and l = [0;1;2;3;4]			(*left*)
  and r = [4;5;6;7;0]			(*right*)
  and c = [0;1;2;3;4;5;6;7]		(*center*)
  and bl = [0;1;2]			(*bottom left*)
  and b = [0;1;2;6;7]			(*bottom*)
  and br = [6;7;0] in			(*bottom right*)
  let dirs = [|tl; tl; t; t; t; t; tr; tr;
	       tl; tl; t; t; t; t; tr; tr;
	       l;  l;  c; c; c; c; r;  r;
	       l;  l;  c; c; c; c; r;  r;
	       l;  l;  c; c; c; c; r;  r;
	       l;  l;  c; c; c; c; r;  r;
	       bl; bl; b; b; b; b; br; br;
	       bl; bl; b; b; b; b; br; br|] in
  function square -> dirs.(square)
  
type board = piece option array

let createBoard () = Array.create 64 None
let copyBoard = Array.copy

(* Computes the index for each lane in brd, and returns an array
   containing the indices.  See the Movetable module for a description
   of lanes and indices.
*)
let computeIndices brd =
  let indices = Array.create 38 0 in
  (* rows *)
  for row = 0 to 7 do
    let lane = XArray.tabulate 8
	(function i -> int_of_square brd.(8*row + i)) in
    indices.(row) <- indexOfLane lane
  done;
  
  for col = 0 to 7 do
    let lane = XArray.tabulate 8
	(function i -> int_of_square brd.(i*8 + col)) in
    indices.(col + 8) <- indexOfLane lane
  done;

  (* sw-ne diagonals *)
  for diag = 0 to 10 do
    let lane = XArray.tabulate laneLength.(diag+16)
	(function i ->
	  let start = if diag < 6 then 16 + 8*diag else 51 + diag in
	  int_of_square brd.(-7*i + start)) in
    indices.(diag + 16) <- indexOfLane lane
  done;

  (* nw-se diagonals *)
  for diag = 0 to 10 do
    let lane = XArray.tabulate laneLength.(diag+27)
	(function i ->
	  let start = if diag < 6 then 5 - diag else (diag - 5) * 8 in
	  int_of_square brd.(9*i + start)) in
    indices.(diag + 27) <- indexOfLane lane
  done;
  indices
    
type t = { board: board;
	   turn: piece;
	   lastMove: move;
	   bPieces: int;		(* number of black pieces on board *)
	   wPieces: int;		(* ditto for white *)
	   indices: int array
	 }

let get brd square = brd.board.(square)
let set brd square pc = brd.board.(square) <- pc

(* creates a board in the start-game configuration *)     
let initial () =
  let brd = createBoard() in
  brd.(28) <- Some Black;
  brd.(35) <- Some Black;
  brd.(27) <- Some White;
  brd.(36) <- Some White;
  { board = brd;
    turn = Black;
    lastMove = Pass;
    bPieces = 2;
    wPieces = 2;
    indices = computeIndices brd
  } 

(* create a board from an array representation of a board. *)
let of_array a turn last =
  let bl, wh = Array.fold_left
      (fun (b, w) p ->
    	match p with
	  Some Black -> (b+1, w)
    	| Some White -> (b, w+1)
    	| None -> (b, w)) (0, 0) a in
  { board = Array.copy a;
    turn = turn;
    lastMove = last;
    bPieces = bl;
    wPieces = wh;
    indices = computeIndices a
  }

let copy brd =
  { board = copyBoard brd.board;
    turn = brd.turn;
    lastMove = brd.lastMove;
    bPieces = brd.bPieces;
    wPieces = brd.wPieces;
    indices = Array.copy brd.indices
  }
    
let blackPieces brd = brd.bPieces
let whitePieces brd = brd.wPieces
let turn brd = brd.turn
let lastMove brd = brd.lastMove
let indices brd = brd.indices
    
let opponent = function
    Black -> White
  | White -> Black
	
let iter f brd = Array.iter f brd.board
let iteri f brd = Array.iteri f brd.board

(* return true if player has any moves on brd *)
let canMove brd player =
  XArray.exists
    (if player = Black then
      (fun i ind ->
      	if Array.length legalMovesTable.(i).(ind).black > 0 then true 
	else false)
    else
      (fun i ind ->
      	if Array.length legalMovesTable.(i).(ind).white > 0 then true
	else false))
    brd.indices
      
(* return true if move is legal for player *)
let legalMove brd player move =
  match move with
    Pass -> not (canMove brd player)
  | Square s ->
      XArray.exists
	(if player = Black then
	  (fun i ind ->
      	    if XArray.mem s legalMovesTable.(i).(ind).black then true
	    else false)
	else
	  (fun i ind ->
      	    if XArray.mem s legalMovesTable.(i).(ind).white then true
	    else false))
	brd.indices

(*
let legalMoves =
  let rec union l1 l2 =
    match l1 with
      [] -> l2
    | h1::t1 -> begin
	match l2 with
	  [] -> l1
	| h2::t2 ->
	    if h1 < h2 then h1 :: (union t1 l2)
	    else if h1 = h2 then h1 :: (union t1 t2)
	    else h2 :: (union l1 t2)
    end in
  fun brd player ->
    let moves =
      if player = Black then
      	XArray.fold_lefti
      	  (fun i mvs ind ->
	    union legalMovesTable.(i).(ind).black mvs)
      	  [] brd.indices
      else
      	XArray.fold_lefti
      	  (fun i mvs ind ->
	    union legalMovesTable.(i).(ind).white mvs)
      	  [] brd.indices in
    if moves = [] then [Pass]
    else List.map (function m -> Square m) moves
*)

(*
let legalMoves =
  let table = Array.create 64 false in  
  let f m = table.(m) <- true in
  fun brd player ->
    for i = 0 to 63 do table.(i) <- false done;
    if player = Black then
      for i = 0 to 37 do
      	Array.iter f legalMovesTable.(i).(brd.indices.(i)).black
      done
    else
      for i = 0 to 37 do
      	Array.iter f legalMovesTable.(i).(brd.indices.(i)).white
      done;
    let moves = XArray.fold_lefti
      	(fun i mvs s -> if s then (Square i)::mvs else mvs)
      	[] table in
    if moves = [] then [Pass]
    else moves
*)

let legalMoves brd player =
  let moves = ref [] in
  if player = Black then
    for i = 0 to 37 do
      let a = legalMovesTable.(i).(brd.indices.(i)).black in
      for m = 0 to Array.length a - 1 do
	moves := XList.adjoin a.(m) !moves
      done
    done
  else
    for i = 0 to 37 do
      let a = legalMovesTable.(i).(brd.indices.(i)).white in
      for m = 0 to Array.length a - 1 do
	moves := XList.adjoin a.(m) !moves
      done
    done;
  if !moves = [] then [Pass]
  else List.map (function m -> Square m) !moves
    
let sandwich brd player dir square =
  let rec sand = function
      None -> None
    | Some sq -> begin
      	match brd.(sq) with
	  None -> None
      	| Some p ->
	    if p = player then Some sq
	    else sand (nextSquare dir sq)
    end in
  
  match (nextSquare dir square) with
    None -> None
  | Some sq -> begin
      match brd.(sq) with
	None -> None
      |	Some p ->
	  if p = player then None
	  else sand (nextSquare dir sq)
  end
	  
let makeMove brd player move =
  match move with
    Pass ->
      { board = copyBoard brd.board;
      	turn = opponent player;
      	lastMove = Pass;
      	bPieces = brd.bPieces;
      	wPieces = brd.wPieces;
      	indices = Array.copy brd.indices
      }
  | Square sq -> begin
      let newbrd = copyBoard brd.board
      and indices = Array.copy brd.indices
      and myop = if player = Black then (-) else (+)
      and me = Some player in
      
      newbrd.(sq) <- me;
      let square = squareIndexes.(sq) in
      Array.iteri
	(fun i ind ->
	  if ind >= 0 then
	    indices.(ind) <- myop indices.(ind) square.placeOffsets.(i))
	square.lanes;
	    
      let count = ref 0 in
      List.iter (function dir ->
	match (sandwich newbrd player dir sq) with
	  None -> ()
	| Some s ->
	    let from = ref (sq + dirOffset.(dir)) in
	    while !from <> s do		(* flip pieces *)
	      newbrd.(!from) <- me;
	      let square = squareIndexes.(!from) in
	      Array.iteri
		(fun i ind ->
		  if ind >= 0 then
		    indices.(ind) <- myop indices.(ind) square.flipOffsets.(i))
		square.lanes;
	      incr count;
	      from := !from + dirOffset.(dir);
	    done)
	(searchDirs sq);
      { board = newbrd;
	turn = opponent player;
	lastMove = move;
	bPieces = if player = Black then brd.bPieces + !count + 1
                  else brd.bPieces - !count;
	wPieces = if player = White then brd.wPieces + !count + 1 
                  else brd.wPieces - !count;
	indices = indices
      }
  end
      
let string_of_piece = function
    Black -> "BLACK"
  | White -> "WHITE"

let string_of_move =
  let cols = "ABCDEFGH" in
  function 
      Pass -> "PA"
    | Square s -> sprintf "%c%d" cols.[s mod 8] (s / 8 + 1)

let printBoard =
  let squareSym = function
    | None -> "."
    | Some p -> if p = Black then "*" else "O" in
  function brd ->
    let player = turn brd in
    let op = opponent player in
    Printf.printf "%s   (%s)                 A B C D E F G H     %s   (%s)\n"
      (string_of_piece player) (squareSym (Some player))
      (string_of_piece op) (squareSym (Some op));
    for row = 0 to 7 do
      Printf.printf "%26s%d " " " (row + 1);
      for col = 0 to 7 do
 	Printf.printf "%s " (squareSym (get brd (row * 8 + col)))
      done;
      Printf.printf "%d\n" (row + 1)
    done;
    Printf.printf "%48sLast move: %s\n" " " (string_of_move (lastMove brd));;
 	 
let printBoardTop =
  let squareSym = function
      None -> "."
    | Some Black -> "*"
    | Some White -> "O"
  and spc x = String.make x ' ' in
  function brd ->
    let player = turn brd in
    let op = opponent player in
    Format.open_box 0;
    Format.print_string (Printf.sprintf "%-20s"
 			   (Printf.sprintf "%s  (%s)" (string_of_piece player)
 			      (squareSym (Some player))));
    Format.print_string "  A B C D E F G H  ";
    Format.print_string (spc 4);
    Format.print_string (Printf.sprintf "%s  (%s)" (string_of_piece op)
 			   (squareSym (Some op)));
    Format.force_newline();
    for row = 0 to 7 do
      Format.print_string (Printf.sprintf "%20s%d " " " (row + 1));
      for col = 0 to 7 do
 	Format.print_string (Printf.sprintf "%s "
 			       (squareSym (get brd (row * 8 + col))))
      done;
      Format.print_int (row + 1);
      Format.force_newline();
    done;
    Format.print_string ((spc 20) ^ "  A B C D E F G H  " ^ (spc 4));
    Format.print_string (Printf.sprintf "Last move: %s"
 			   (string_of_move (lastMove brd)));
    Format.force_newline();
    Format.close_box()
