{-|
Module      : Game
Description : Provides some data types and auxiliary functions for the "connect two sides game".
Maintainer  : Manuel Eberl

This module provides some data types and auxiliary functions for the "connect two sides game". 
A game board is represented by the data type @Board@. A @Board@ has positions from @(1,1)@ to 
@(boardWidth, boardHeight)@, i.e. from @(1,1)@ to @(11,11)@. Every position can either contain a red stone, 
a blue stone, or no stone at all. This is represented by @Nothing@, @Just Red@, and @Just Blue@, respectively.

Every position is a hexagon and therefore has up to 6 neighbours. Axial coordinates are used, so the neighbours of 
a position @(x,y)@ are @(x-1,y)@, @(x+1,y)@, @(x,y-1)@, @(x,y+1)@, @(x+1,y-1)@, @(x-1,y+1)@.

The player @Red@ has to connect the left-hand side of the board and the right-hand side of the board with a path of 
neighbouring stones of his colours; the player @Blue@ has to connect the top with the bottom. Starting with @Red@, the 
players alternate in placing a single stone of their colour on an empty position until one player has successfully 
constructed her path.
-}

{-# LANGUAGE RankNTypes, ScopedTypeVariables #-}
module Game (
    -- * Game representation
    -- ** Types
    Position, Player (Red, Blue), Board (Board),
    -- ** Inspecting and modifying boards
    otherPlayer, boardWidth, boardHeight, boardBounds, emptyBoard, isValidPosition, neighbors, isNeighborOf, playerAt,
    setPlayerAt, isValidMove, makeMove, showBoard, readBoard, dfs, hasWon,
    -- * Strategies
    Strategy (Strategy, initialState, computeMove), simpleStrategy,
    -- ** Auxiliary functions
    selectRandom, randomPosition
  ) where

import Control.Arrow
import Control.Monad
import Data.Char
import Data.Maybe
import Data.Ord
import Data.List
import Data.Set (Set)
import qualified Data.Set as S
import Data.Array (Array, (!), (//))
import Data.Ix
import qualified Data.Array as A
import System.Random

{- Representation of players and the board -}

type Position   = (Int, Int)

-- | A player in the game.
data Player     = Red | Blue deriving (Eq, Ord, Show, Read)

-- | A board of stones, each position containing either @Just@ a @Player@ or @Nothing@.
newtype Board   = Board (Array Position (Maybe Player)) deriving (Eq)

-- | Returns the opposite player.
otherPlayer :: Player -> Player
otherPlayer Red  = Blue
otherPlayer Blue = Red

-- | The width and height of the board.
boardDimensions :: (Int, Int)
boardDimensions = (11, 11)

-- | The width of the board.
boardWidth = fst boardDimensions

-- | The height of the board.
boardHeight = snd boardDimensions

-- | Lower/upper bound of the game.
boardBounds :: ((Int,Int), (Int,Int))
boardBounds = ((1, 1), boardDimensions)

-- | The empty board.
emptyBoard :: Board
emptyBoard = Board (A.listArray boardBounds (take (rangeSize boardBounds) (repeat Nothing)))

-- | Returns whether a position is within the bounds of the board.
isValidPosition :: Position -> Bool
isValidPosition = inRange boardBounds

-- | The list of neighbours of a position.
neighbors :: Position -> [Position]
neighbors (x,y) = filter isValidPosition [(x+1,y), (x-1,y), (x,y+1), (x,y-1), (x+1,y-1), (x-1,y+1)]

-- | Whether two positions are neighboured.
isNeighborOf :: Position -> Position -> Bool
p `isNeighborOf` q = p `elem` neighbors q

-- | Returns the player who owns the stone at the given position (or Nothing if there is no stone).
playerAt :: Position -> Board -> Maybe Player
playerAt p (Board a) = if isValidPosition p then a ! p else Nothing

-- | Sets the stone at the given position.
setPlayerAt :: Position -> Maybe Player -> Board -> Maybe Board
setPlayerAt pos pl (Board a)
  | isValidPosition pos = Just (Board (a // [(pos, pl)]))
  | otherwise           = Nothing

-- | Displays a board as a String. Empty circles denote an empty position, 
--   solid circles denote a red stone and striped circles denote a blue stone.
showBoard board = intercalate "\n" [showLine y | y <- [boardHeight, boardHeight - 1 .. 1]]
    where showLine y = replicate (y - 1) ' ' ++ intercalate " " [showPos (x,y) | x <- [1..boardWidth]]
          showPos pos = case playerAt pos board of
                          Nothing   -> "○"
                          Just Red  -> "●"
                          Just Blue -> "◍"
                          
readBoard s = 
  Board . A.listArray boardBounds . concat . transpose . reverse . map (map f . filter (not . isSpace)) $ lines s
  where f '○' = Nothing
        f '●' = Just Red
        f '◍' = Just Blue
        f _   = error "Game.readBoard: No parse."
                          
instance Show Board where
  show = showBoard

-- | Returns whether putting a stone at the given position is a valid move.
isValidMove :: Position -> Board -> Bool
isValidMove p board = isValidPosition p && isNothing (playerAt p board)

-- | Puts a stone of the given player's color at the given position.
makeMove :: Player -> Position -> Board -> Maybe Board
makeMove pl pos board
  | isValidMove pos board = setPlayerAt pos (Just pl) board
  | otherwise             = Nothing
  
-- | Performs a depth-first search starting at the given positions along the stones of the given player.
dfs :: Player -> [Position] -> Board ->  Set Position
dfs pl xs board = dfs' xs (S.fromList xs)
  where dfs' [] visited = visited
        dfs' (x:xs) visited =
          let ns = [x' | x' <- neighbors x, playerAt x' board == Just pl, x' `S.notMember` visited]
          in  dfs' (ns ++ xs) (S.union (S.fromList ns) visited)

-- | Returns true if the given player has a connecting path on the board.
hasWon :: Player -> Board -> Bool
hasWon pl board = any isFinal (S.toList (dfs pl initial board))
  where initial = case pl of Red  -> [(1,i) | i <- [1..boardHeight], playerAt (1,i) board == Just pl]
                             Blue -> [(i,1) | i <- [1..boardWidth ], playerAt (i,1) board == Just pl]
        isFinal (x,y) = (pl == Red && x == boardWidth) || (pl == Blue && y == boardHeight)


{- Some randomisation functions -}

-- | Returns a random position on the board (uniformly-distributed), using the given random generator.
randomPosition :: RandomGen g => g -> (Position, g)
randomPosition g = case randomR (1, boardWidth) g of
                     (x, g') -> case randomR (1, boardHeight) g' of
                                  (y, g'') -> ((x,y), g'')
                                  
-- | Returns a random element of the given list (uniformly-distributed), using the given random generator.
selectRandom :: RandomGen g => [a] -> g -> (a, g)
selectRandom xs g = case randomR (0, length xs - 1) g of
                      (i, g') -> (xs !! i, g')


{- Strategies -}

-- | AI players are represented by a @Strategy@. The simple interface for @Strategy@ is a deterministic, stateless function 
-- of the type @Player -> Board -> Position@; this function is given the information of what player it is and the current 
-- board and then computes the next move.
-- 
-- The advanced interface for @Strategy@ is a probabilistic, stateful function. A Strategy must provide functions
-- 
-- @
-- initialState :: RandomGen g => g -> Player -> a
-- computeMove  :: RandomGen g => g -> a -> Player -> Board -> (Position, a)
-- @
-- 
-- A strategy maintains an internal state of arbitrary type @s@. @initialState@ must then return some value of 
-- type @s@ which will be passed to the strategy for its first move. The @computeMove@ function again receives the 
-- current board along with the current state of the strategy and must return the next move and the new state.
-- Both functions are given the information of what player they are playing as, and a fresh random generator with 
-- every invocation in order to make random decisions.
-- 
-- Possible uses for the state are keeping a history of turns, or maintaining expensive data structures, 
-- such as precomputed game trees or good moves.
data Strategy a = Strategy {initialState :: forall g. RandomGen g => g -> Player -> a,
                            computeMove  :: forall g. RandomGen g => g -> a -> Player -> Board -> (Position, a)}

-- | Lifts a given deterministic, stateless strategy to a ‘proper’ strategy
simpleStrategy :: (Player -> Board -> Position) -> Strategy ()
simpleStrategy s = Strategy (\ _ _ -> ()) (\_ _ pl f -> (s pl f, ()))