{-# LANGUAGE ScopedTypeVariables #-}

module Go where

import Data.List
import Control.Monad.State

class (Eq c, Ord c, Bounded c, Enum c, Show c) => Coord c where
  allcoords :: [c]
  allcoords = [minBound..maxBound]

data Point2D x y = Point2D x y deriving (Eq)
instance (Coord x, Coord y) => Show (Point2D x y) where
  show (Point2D x y) = show x ++ show y

neighbours2D :: (Coord x, Coord y) => Point2D x y -> [Point2D x y]
neighbours2D (Point2D x y) = [Point2D x y1 | y1<-neighbours1D y] ++
                             [Point2D x1 y | x1<-neighbours1D x] where
  neighbours1D z = [pred z | z/=minBound] ++ [succ z | z/=maxBound]

data Player = Black | White deriving (Eq, Enum, Show)

data Color = Empty | Stone Player deriving (Eq, Show)

newtype Position p = Position (p -> Color)

color :: Position p -> p -> Color
color (Position pos) p = pos p

class (Eq p, Show p) => Point p where
  neighbours :: p -> [p]
  allpoints :: [p]
  showpos :: Position p -> String

instance (Point p) => Eq (Position p) where
  p == q = all (\x -> color p x == color q x) allpoints 

instance (Coord x, Coord y) => Point (Point2D x y) where
  neighbours = neighbours2D
  allpoints = [Point2D x y | x<-allcoords, y<-allcoords]
  showpos = showpos2D -- to be defined later

string :: (Point p) => Position p -> p -> [p]
string pos point = join (expand [[point],[]]) where
 expand l@(curr:prev:_) = if (null next) then l else expand (next:l) where
   next = nub [nbr | nbr <- curr>>=neighbours, color pos nbr == color pos point] \\ prev

liberties :: (Point p) => Position p -> [p] -> [p]
liberties pos group = [nbr | nbr <- group>>=neighbours, color pos nbr == Empty]

data (Point p) => Turn p = Pass | Move p deriving (Eq, Show)

type Game p = [Turn p]

data GoError = Occupied | Superko Int deriving (Eq, Show) -- cycle length

type TurnOut = Either GoError String

type GameState p = State [Position p] -- remember list of previous positions

clear :: (Point p) => Position p -> [p] -> Position p
clear pos points = Position (\pt -> if pt `elem` captured then Empty else color pos pt) where
  captured = join [str | pt<-points, let str=string pos pt, null (liberties pos str)]

move :: (Point p) => Player -> p -> GameState p TurnOut
move player point = do
  past@(pos0:_) <- get
  if color pos0 point /= Empty then return (Left Occupied) else let
    pos1 = Position (\pt -> if pt==point then Stone player else color pos0 pt)
    opponent = [nbr|nbr<-neighbours point, (Stone p)<-[color pos1 nbr], p/=player]
    pos2 = clear pos1 opponent
    pos3 = clear pos2 [point]
    in case elemIndex pos3 past of
      Just i  -> return $ Left $ Superko (1+i)
      Nothing -> do
        put (pos3:past)
        return $ Right $ show (length past) ++ ". " ++ show player++" "++show point++"\n\n"++showpos pos3

pass :: (Point p) => Player -> GameState p TurnOut
pass player = do
  past@(pos:_) <- get
  put (pos:past)
  return $ Right $ show (length past) ++ ". " ++ show player ++ " pass\n" ++ gameover past

gameover :: (Point p) => [Position p] -> String
gameover (pos:past) = case past of
  (pos':_) | showpos pos == showpos pos' -> overmsg
  otherwise                              -> ""
  where
    overmsg = "\nGame Over. Black: " ++ show bscore ++ " White: " ++ show wscore ++ ". " ++ winner ++ "\n"
    (bscore, wscore) = (score pos Black, score pos White)
    winner = case compare bscore wscore of
      LT -> "White wins."
      EQ -> "It's a tie."
      GT -> "Black wins."

playgame :: (Point p) => Game p -> GameState p [TurnOut]
playgame game = sequence $ zipWith playturn (cycle [Black,White]) game where
  playturn player (Move point) = move player point
  playturn player Pass         = pass player

score :: (Point p) => Position p -> Player -> Int
score pos player = sum $ map scorepoint allpoints where
 scorepoint pt = case color pos pt of
   Stone p | p == player -> 1
           | otherwise -> 0
   Empty   | owners == [player] -> 1
           | otherwise ->0 where
     owners = nub [p|(Stone p)<-string pos pt>>=neighbours>>=return.color pos]

showgame :: forall p. (Point p) => Game p -> IO ()
showgame game = do
  putStrLn $ showpos emptypos
  mapM_ (putStrLn . (either (error.show) id)) turnouts where
    turnouts = evalState (playgame game) [emptypos]
    emptypos = Position (const Empty) :: Position p

showpos2D :: forall x y. (Coord x, Coord y) => Position (Point2D x y) -> String
showpos2D pos = unlines (map showrow (reverse allcoords)) ++ files where
  showrow y = show y ++ ' ' : intersperse ' ' [tochar (color pos (Point2D x y)) | x<-allcoords]
  tochar (Stone Black) = '@'
  tochar (Stone White) = 'O'
  tochar Empty = '.'
  files = "  " ++ unwords (map show (allcoords::[x])) ++ "\n"

mv :: (Coord x, Coord y) => (Int,Int) -> Turn (Point2D x y)
mv (x,y) = Move (Point2D (toEnum (x-1)) (toEnum (y-1)))

-- example 3x3 game
data XCoord3 = XA | XB | XC deriving (Eq, Ord, Bounded, Enum)
instance Show XCoord3 where show x = [['A'..]!!(fromEnum x)]
instance Coord XCoord3

data YCoord3 = Y1 | Y2 | Y3 deriving (Eq, Ord, Bounded, Enum)
instance Show YCoord3 where show y = show (1 + fromEnum y)
instance Coord YCoord3

game :: Game (Point2D XCoord3 YCoord3)
game = [mv (1,1), mv (1,2), mv (2,2), mv (3,1), mv (3,2), mv (2,1), mv (2,3), Pass, Pass]

main = showgame game