signature GAME =
sig
  datatype player = Player | Opponent
  type board

  val initialBoard : board                   (* no moves means player loses *)
  val moves : player -> board -> board list  (* approximate, between -1 and 1 *)
  val evaluate : player -> board -> real

  val toString : board -> string
end;  (* signature GAME *)

signature PLAY =
sig
  structure Game : GAME (* parameter *)
  val play : int -> Game.player
             -> Game.board -> (Game.board option * real)
end;  (* signature PLAY *)

(***************************)
(*** Pruning Tree Search ***)
(***************************)
functor Play (structure Game : GAME) : PLAY =
struct

structure Game = Game
structure G = Game  (* abbreviation *)

(* val eval : G.player -> int -> int -> G.board -> real *)
(* d >= 0 search to depth d, d < 0 searches whole tree *)
(* prune is the cut-off value from sibling nodes *)
fun eval p 0 prune board = G.evaluate p board
  | eval G.Player d prune board =
     evalList G.Player d prune ~1.0 (G.moves G.Player board)
  | eval G.Opponent d prune board = 
     evalList G.Opponent d prune 1.0 (G.moves G.Opponent board)

(* val evalList : G.player -> int -> int -> int -> G.board list
                  -> real *)
(* evalList p d prune v moves >=> value *)
(* p is the player making the choice, d is depth to search *)
(* prune is the cut-off value from sibling nodes *)
(* v is the preliminary value for this level *)
and evalList G.Player d prune maxv nil = maxv
  | evalList G.Player d prune maxv (m::ms) =
    let val v = eval G.Opponent (d-1) maxv m
    in if v > prune then v (* prune *)
       else evalList G.Player d prune (Real.max(maxv,v)) ms
    end
  | evalList G.Opponent d prune minv nil = minv
  | evalList G.Opponent d prune minv (m::ms) =
    let val v = eval G.Player (d-1) minv m
    in if v < prune then v (* prune *)
       else evalList G.Opponent d prune (Real.min(minv,v)) ms
    end

fun maxVal (l) = foldr Real.max ~1.0 l
fun minVal (l) = foldr Real.min 1.0 l

(* val pick : real -> real list -> G.board list
              -> G.board option *)
(* pick v vs ms  where |vs| = |ms| *)
fun pick v (nil) (nil) = NONE
  | pick v (v'::vs) (m::ms) =
       if v = v' then SOME(m) else pick v vs ms

(* val play : int -> G.player -> G.board
              -> (G.board option * real) *)
(* play d player b  where d > 0 searches to depth d *)
(* d = 0 searches to arbitrary depth *)
fun play d G.Player board =
      let
        val moves = G.moves G.Player board
        val values = map (eval G.Opponent (d-1) ~1.0) moves
        val maxv = maxVal values
      in
        (pick maxv values moves, maxv)
      end
  | play d G.Opponent board =
      let
        val moves = G.moves G.Opponent board
        val values = map (eval G.Player (d-1) 1.0) moves
        val minv = minVal values
      in
        (pick minv values moves, minv)
      end

end;

(*********************)
(*** Connect4 Game ***)
(*********************)
functor Connect4 () : GAME =
struct

datatype player = Player | Opponent

type square = int * int
(* sq = (i,j) with 1 <= i,j <= 7 *)

datatype direction = Horizontal | Rising | Vertical | Falling
(* printed as -,/,|,\, respectively *)

(* val adjacent : direction -> square * square -> bool *)
(* adjacent d (left,right) returns true *)
(* if left and right are adjacent in direction d *)
fun adjacent Horizontal ((i,j),(i',j')) = (i+1=i' andalso j=j')
  | adjacent Rising ((i,j),(i',j')) = (i+1=i' andalso j+1=j')
  | adjacent Vertical ((i,j),(i',j')) = (i=i' andalso j+1=j')
  | adjacent Falling ((i,j),(i',j')) = (i+1=i' andalso j-1=j')

(* Line(d,p,n,(left,right)) : line *)
(* consisting of the direction d, player p, length n and *)
(* left and right endpoints *)
datatype line =
  Line of direction * player * int * (square * square)

(* board consisting of the top of each of the 7 columns *)
(* and a list of current connections *)
type board = int list * line list

val initialBoard : board = ([0,0,0,0,0,0,0], [])

(*************)
(*** Moves ***)
(*************)

(* exception Lost *)
(* raised when the other player has a line of 4 or more *)
exception Lost

(*
   val findNeighbors : square -> player -> line list
                       -> (line list * line list)
                       -> (line list * line list)
   findNeighbors sq p l (accN,accO) >=> (neighbors, others)
   where neighbors are the lines which would be extended by sq,
   others are the remaining lines.  accN and accO accumulate
   the result.
   Raises exception Lost if other player has line of length
   4 or greater.
*)
fun findNeighbors sq p (nil) (neighbors,others) =
       (neighbors,others)
  | findNeighbors sq p
       ((l as Line(d', p', n', (left, right)))::lines)
       (neighbors,others) =
      findNeighbors sq p lines
        (if p = p'
           then if adjacent d' (right,sq)
                   orelse adjacent d' (sq, left)
                  then (l::neighbors, others)
                else (neighbors, l::others)
         else if n' >= 4 then raise Lost
              else (neighbors,l::others))

(* val extendR : square -> direction -> player -> line list
                 -> line *)
(*
   extendR sq d p lines, where each line in lines is from
   player p, returns a new line which extends a given at the
   right in direction d by adding sq, or creates a new
   singleton line if no such line exists.
*)
fun extendR sq d p nil = Line(d, p, 1, (sq,sq))
  | extendR sq d p (Line(d', p', n, (left,right))::lines) =
      if d = d' (* p = p' guaranteed by invariant *)
         andalso adjacent d (right,sq)
        then Line(d', p', n+1, (left,sq))
      else extendR sq d p lines

(* extendL like extendR, but extend on left *)
fun extendL sq d p nil = Line(d, p, 1, (sq,sq))
  | extendL sq d p (Line(d', p', n, (left,right))::lines) =
      if d=d' (* p = p' guaranteed by invariant *)
         andalso adjacent d (sq,left)
        then Line(d', p', n+1, (sq,right))
      else extendL sq d p lines

(* join : line * line -> line *)
(* Join two lines (leftLine, rightLine) adjacent lines *)
(* with same player and direction *)
fun join (Line(d1, p1, n1, (left1,right1)),
          Line(d2, p2, n2, (left2,right2))) =
  (* d1 = d2, p1 = p2, right1 = left2 *)
  Line(d1, p1, n1+n2-1, (left1,right2))

(* incTop : int list * int -> int list *)
(* incTop (tops,i) increments i'th element of tops *)
(* 1 <= i <= |tops| *)
fun incTop (j::tops,1) = (j+1)::tops
  | incTop (j::tops,i) = j::incTop(tops,i-1)


(* move : square -> player -> board -> board *)
(*
   move sq p board >=> board', which results from player p
   moving on square p.  We assume the move is legal.  Exception
   Lost is raised, if other player has line of 4 or more
*)
fun move (sq as (i,j)) p (tops,lines) =
    let
      val (neighbors,others) =
	  findNeighbors sq p lines (nil,nil)
      val newLines =
          List.map (fn d => join (extendR sq d p neighbors,
                                  extendL sq d p neighbors))
                   [Horizontal,Rising,Vertical,Falling]
      val tops' = incTop(tops,i)
    in (tops', newLines @ others) end
(* moves : player -> board -> board list *)
(* Return list of possible moves of player on given board *)
fun moves p (tops,lines) = 
    let fun tryCol i nil = nil
          | tryCol i (7::tops') = tryCol (i+1) tops'
          | tryCol i (j::tops') = 
               move (i,j+1) p (tops,lines)::tryCol (i+1) tops'
    in
      tryCol 1 tops
      handle Lost => nil
    end


(******************)
(*** Evaluation ***)
(******************)

(* val findMax : player -> int -> line list -> int *)
(* findMax p lmax lines *)
(* find maximum of lmax and length player p's lines *)
fun findMax p lmax (nil) = lmax
  | findMax p lmax (Line(_, p', n, _)::lines) =
    if p = p' then findMax p (Int.max(lmax,n)) lines
    else findMax p lmax lines

(* bonus for player whose turn it is *)
fun turnBonus (Player) = 0.1
  | turnBonus (Opponent) = ~0.1

(* evaluate : player -> board -> real *)
(* approximately evaluate board assuming it's player's move *)
fun evaluate p (tops,lines) =
    let
      val lmaxPlayer = findMax Player 0 lines
      and lmaxOpp = findMax Opponent 0 lines
    in
      if lmaxPlayer >= 4 then 1.0
      else if lmaxOpp >= 4 then ~1.0
           else real(lmaxPlayer-lmaxOpp)/2.5 + turnBonus(p)
    end

(****************)
(*** Printing ***)
(****************)

fun topsToString (j::nil) = Int.toString(j)
  | topsToString (j::tops) =
      Int.toString(j) ^ topsToString tops

fun dirToString (Horizontal) = "-"
  | dirToString (Rising) = "/"
  | dirToString (Vertical) = "|"
  | dirToString (Falling) = "\\"

fun playerToString (Player) = "x"
  | playerToString (Opponent) = "o"

fun squareToString (i,j) = Int.toString i ^ Int.toString j

fun lineToString (Line(d,p,n,(left,right))) =
    "Line(" ^ playerToString(p) ^ ")" ^ Int.toString(n) ^ ":"
    ^ squareToString left ^ dirToString(d)
    ^ squareToString right ^ ".\n"

fun linesToString lines =
    String.concat (List.map lineToString lines)

fun toString (tops,lines) =
    linesToString(lines) ^ "\n"
    ^ "{" ^ topsToString(tops) ^ "}" ^ "\n"

end;  (* functor Connect4 *)

(***************************)
(*** Creating structures ***)
(***************************)
structure Connect4 :> GAME = Connect4 ();

structure PlayConnect4 :> PLAY =
   Play (structure Game = Connect4);