module HFiaR (
HFiaRT, HFiaR, play,
Player(..), HFiaRError(..), HFiaRResult(..),
dropIn, currentPlayer, board, result
) where
import Control.Monad.State
data HFiaRError = GameEnded | GameNotEnded | InvalidColumn | FullColumn
deriving (Eq)
instance Show HFiaRError where
show GameEnded = "Game ended"
show GameNotEnded = "Game is on curse yet"
show InvalidColumn = "That column doesn't exist"
show FullColumn = "That column is full"
data Player = Red | Green
deriving (Eq, Show)
data HFiaRResult = Tie | WonBy Player
deriving (Eq, Show)
data Game = Game {gameEnded :: Bool,
gameResult :: HFiaRResult,
gamePlayer :: Player,
gameBoard :: [[Player]]
}
deriving (Eq, Show)
newtype HFiaRT m a = HFT {state :: StateT Game m a}
deriving (Monad, MonadIO, MonadTrans)
instance Monad m => MonadState Game (HFiaRT m) where
get = HFT $ get
put = HFT . put
type HFiaR = HFiaRT IO
play :: Monad m => HFiaRT m a -> m a
play actions = (state actions) `evalStateT` Game{gamePlayer = Green,
gameBoard = replicate 7 [],
gameEnded = False,
gameResult = Tie}
dropIn :: Int
-> HFiaR (Either HFiaRError ())
dropIn c | c < 0 = return $ Left InvalidColumn
| 6 < c = return $ Left InvalidColumn
| otherwise =
do
game <- get
if (gameEnded game)
then return $ Left GameEnded
else if (length $ (gameBoard game) !! c) == 7
then return $ Left FullColumn
else
let player = gamePlayer game
newBoard = insertAt c player $ gameBoard game
newResult= if (isWinner c player newBoard) then WonBy player else Tie
newEnded = (newResult == WonBy player) || full newBoard
in put game{gameBoard = newBoard,
gamePlayer= otherPlayer $ gamePlayer game,
gameEnded = newEnded,
gameResult= newResult
} >>= return . Right
where insertAt :: Int -> a -> [[a]] -> [[a]]
insertAt i x xss = (take i xss) ++ ( (x : (xss !! i)) : drop (i+1) xss)
otherPlayer :: Player -> Player
otherPlayer Green = Red
otherPlayer Red = Green
full :: [[a]] -> Bool
full = all (\x -> 7 == length x)
isWinner :: Int -> Player -> [[Player]] -> Bool
isWinner c p b =
let col = b !! c
in ([p,p,p,p] == take 4 col) ||
fourIn (getRow (length col 1) b) ||
fourIn (getDiagUpRight c (length col 1) b) ||
fourIn (getDiagUpLeft c (length col 1) b)
getRow :: Int -> [[Player]] -> [Maybe Player]
getRow r = map (cell r)
getDiagUpRight :: Int -> Int -> [[Player]] -> [Maybe Player]
getDiagUpRight c r xss = map (\i -> cell (i+rc) (xss !! i)) [0..6]
getDiagUpLeft :: Int -> Int -> [[Player]] -> [Maybe Player]
getDiagUpLeft c r xss = map (\i -> cell (r+ci) (xss !! i)) [0..6]
cell :: Int -> [Player] -> Maybe Player
cell c xs = if (c >= 0 && c < length xs)
then Just $ (reverse xs) !! c
else Nothing
fourIn :: [Maybe Player] -> Bool
fourIn [] = False
fourIn (Nothing:xs) = fourIn xs
fourIn (Just p :xs) = ([Just p, Just p, Just p] == take 3 xs) || fourIn xs
currentPlayer :: HFiaR (Either HFiaRError Player)
currentPlayer = get >>= \Game{gameEnded = e,
gamePlayer= p} ->
return $ if e
then Left GameEnded
else Right p
board :: HFiaR [[Player]]
board = get >>= return . gameBoard
result :: HFiaR (Either HFiaRError HFiaRResult)
result = get >>= \Game{gameEnded = e,
gameResult= r} ->
return $ if (not e)
then Left GameNotEnded
else Right r