ApplyPlay.hs

module Tak.ApplyPlay where

import Data.Matrix hiding (trace)

import Tak.Types
import Tak.Win

play :: Play -> GameState -> Either GameState IllegalMove
play _ (GameState _ _ _ (Just finished) _ _) = Right (GameAlreadyWon finished)
play (Place stone loc) state
    | fst loc > nrows board = Right $ ExceededBounds PosX
    | fst loc < 1 = Right $ ExceededBounds NegX
    | snd loc >  ncols board = Right $ ExceededBounds PosY
    | snd loc < 1 = Right $ ExceededBounds NegY
    | otherwise = case square of
        [] -> Left $ GameState newBoard newWhite newBlack finished
            (oppositeColour $ stPlaysNext state) (stNextTurn state + 1)
        _ -> Right SquareNotEmpty
    where
        finished = won newBoard newWhite newBlack
        newBoard = setElem [(stone, colour)] loc board
        newWhite = case colour of
            White -> removeStone stone (stWhite state)
            Black -> stWhite state
        newBlack = case colour of
            White -> stBlack state
            Black -> removeStone stone (stBlack state)
        removeStone Flat player =
            player{stonesRemaing = stonesRemaing player - 1}
        removeStone Standing player = removeStone Flat player
        removeStone Cap player =
            player{capsRemaining = capsRemaining player - 1}
        square = board ! loc
        board = stBoard state
        colour = if stNextTurn state <= 2
            then oppositeColour $ stPlaysNext state
            else stPlaysNext state
play (Move loc dir drops) state
    | carry > carryLimit board = Right CarryLimitExceeded
    | carry > length square = Right StackTooSmall
    | length square == 0 = Right EmptySquare
    | snd (head square) /= colour = Right WrongColourStack
    | fst loc > nrows board = Right $ ExceededBounds PosX
    | fst loc < 1 = Right $ ExceededBounds NegX
    | snd loc > ncols board = Right $ ExceededBounds PosY
    | snd loc < 1 = Right $ ExceededBounds NegY
    | otherwise = case newBoardOrErr of
        Left newBoard -> Left state{stBoard = newBoard,
            stPlaysNext = oppositeColour colour,
            stNextTurn = stNextTurn state + 1,
            stFinished = won newBoard (stWhite state) (stBlack state)
        }
        Right err -> Right err
    where
        newBoardOrErr = foldr place (Left boardSub) (zip dropPieces dropLocs)
        dropPieces = snd $ foldl dropPieces' (carried, []) drops
        dropPieces' (carriedLeft, dropsSoFar) n =
            let (ds, carriedLeft') = splitAt n carriedLeft in 
            (carriedLeft', dropsSoFar ++ [reverse ds])
        dropLocs = map (step loc dir) [1..]
        boardSub = setElem (drop carry square) loc board
        carried = reverse $ take carry square
        carry = sum drops
        square = board ! loc
        board = stBoard state
        colour = stPlaysNext state

place :: ([Piece], Loc) -> (Either Board IllegalMove) -> Either Board IllegalMove
place stackLoc (Left board) = place' stackLoc board
place _ illegalMove = illegalMove

place' :: ([Piece], Loc) -> Board -> (Either Board IllegalMove)
place' (stack, loc) board
    | fst loc > nrows board = Right $ ExceededBounds PosX
    | fst loc < 1 = Right $ ExceededBounds NegX
    | snd loc > ncols board = Right $ ExceededBounds PosY
    | snd loc < 1 = Right $ ExceededBounds NegY
    | otherwise = case square of
        [] -> Left newBoard
        (Standing, _) : _-> case stack of
            (Cap, _) : [] -> Left $ newSquashedBoard
            _ -> Right PlaceOnStanding
        (Cap, _) : _ -> Right PlaceOnCapstone
        (Flat, _) : _ -> Left newBoard
    where
        newBoard = setElem newStack loc board
        newSquashedBoard = setElem newSquashedStack loc board
        newStack = stack ++ square
        newSquashedStack = stack ++ squashedSquare
        squashedSquare = case square of
            (Standing, colour) : ss -> (Flat, colour) : ss
            _ -> square
        square = board ! loc

carryLimit :: Board -> Int
carryLimit board = max (nrows board) (ncols board)

step :: Loc -> Dir -> Int -> Loc        
step (x, y) PosX n = (x + n, y)
step (x, y) NegX n = (x - n, y)
step (x, y) PosY n = (x, y + n)
step (x, y) NegY n = (x, y - n)

data IllegalMove =
    SquareNotEmpty
    | ExceededBounds Dir
    | CarryLimitExceeded
    | StackTooSmall
    | GameAlreadyWon Finished
    | PlaceOnStanding
    | PlaceOnCapstone
    | WrongColourStack
    | EmptySquare deriving Show