343 lines
13 KiB
Haskell
343 lines
13 KiB
Haskell
module PatienceBoard
|
|
( Game (..)
|
|
, Board (..)
|
|
, amountOfGameStacks
|
|
, amountOfEndingStacks
|
|
, gameStacksCoord
|
|
, endingStacksCoord
|
|
, pileCoord
|
|
|
|
, handleInputs
|
|
, initGame
|
|
|
|
, isInGame
|
|
, isInEnding
|
|
, isInPile
|
|
) where
|
|
|
|
import CardDeck
|
|
import Selector
|
|
|
|
import InputHandler
|
|
|
|
----------------------------- Constants ------------------------------
|
|
|
|
-- Prepresentation of a Patience game
|
|
data Game = Game {
|
|
-- The playboard
|
|
board :: Board,
|
|
-- The selector
|
|
selector :: Selector
|
|
} deriving (Show)
|
|
|
|
-- Representation of a Patience board
|
|
data Board = Board {
|
|
-- 7 colums of cards (the 'playing field')
|
|
gameStacks :: [Stack],
|
|
-- 4 ending stacks (top right corner, usually)
|
|
endingStacks :: [Stack],
|
|
-- Stack of cards that are not yet on the board
|
|
pile :: Stack
|
|
} deriving (Show)
|
|
|
|
-- The zones of the board. Represents either the pile, the endingStacks
|
|
-- or the gameStacks. It can also be out of the board.
|
|
data Zone = Pile | ES | GS | Out
|
|
|
|
amountOfGameStacks :: Int
|
|
amountOfGameStacks = 7
|
|
|
|
amountOfEndingStacks :: Int
|
|
amountOfEndingStacks = 4
|
|
|
|
-- Coordinate of the GameStacks
|
|
gameStacksCoord :: Coordinate
|
|
gameStacksCoord = (0, 0)
|
|
|
|
-- Coordinate of the EndingStacks
|
|
endingStacksCoord :: Coordinate
|
|
endingStacksCoord = (x, 1)
|
|
where x = amountOfGameStacks - amountOfEndingStacks
|
|
|
|
-- Coordinate of the Pile
|
|
pileCoord :: Coordinate
|
|
pileCoord = (0, 1)
|
|
|
|
-- Step size to rotate the pile of the game
|
|
rotateStep :: Int
|
|
rotateStep = 3
|
|
|
|
------------------------------- Init ---------------------------------
|
|
|
|
-- Split a full deck into 7 gameStacks and one pile of unused cards.
|
|
splitDeck :: Stack -> [Stack]
|
|
splitDeck = reverse . splitDeck' amountOfGameStacks
|
|
where splitDeck' :: Int -> Stack -> [Stack]
|
|
splitDeck' 0 cs = [cs]
|
|
splitDeck' n cs = let (stack,rest) = splitAt n cs
|
|
in showFirst stack : splitDeck' (n - 1) rest
|
|
|
|
-- The initial board consisting of a stack of yet-to-be-turned cards
|
|
-- and n stacks of increasingly large amount of cards (1, ..., n)
|
|
initBoard :: Board
|
|
initBoard = Board {
|
|
gameStacks = stacks,
|
|
endingStacks = replicate amountOfEndingStacks [],
|
|
pile = map showCard pile
|
|
}
|
|
where pile:stacks = splitDeck generateShuffledDeck
|
|
|
|
-- The initial state of the playboard, with a board and a cursor.
|
|
initGame :: Game
|
|
initGame = Game {
|
|
board = initBoard,
|
|
selector = initSelector
|
|
}
|
|
|
|
------------------- Coordinate to Card conversion --------------------
|
|
|
|
-- Check if a coordinate is in the pile.
|
|
isInPile :: Coordinate -> Bool
|
|
isInPile = (pileCoord == )
|
|
|
|
-- Check if a coordinate is in an endingStack.
|
|
isInEnding :: Coordinate -> Bool
|
|
isInEnding (x, y) = leftBound && rightBound && yCheck
|
|
where leftBound = fst endingStacksCoord <= x
|
|
rightBound = x < amountOfGameStacks
|
|
yCheck = y == snd endingStacksCoord
|
|
|
|
-- Check if a coordinate is in a GameStack.
|
|
isInGame :: Coordinate -> Game -> Bool
|
|
isInGame (x, y) g = horizontalCheck && verticalCheck
|
|
where horizontalCheck = leftBound && rightBound
|
|
verticalCheck = upBound && downBound
|
|
leftBound = fst gameStacksCoord <= x
|
|
rightBound = x < amountOfGameStacks
|
|
upBound = y <= snd gameStacksCoord
|
|
downBound = negate y < length (gameStacks (board g) !! x)
|
|
|
|
-- Get the zone number from a coordinate.
|
|
getZoneFromCoord :: Game -> Coordinate -> Zone
|
|
getZoneFromCoord game (x, y)
|
|
| isInPile (x, y) = Pile
|
|
| isInEnding (x, y) = ES
|
|
| isInGame (x, y) game = GS
|
|
| otherwise = Out
|
|
|
|
-- Based on a coordinate, return a stack.
|
|
getStackFromCoord :: Game -> Coordinate -> Stack
|
|
getStackFromCoord game (x, y)
|
|
| isInPile (x, y) = pile $ board game
|
|
| isInEnding (x, y) = endingStacks (board game) !! (x - (amountOfGameStacks - amountOfEndingStacks))
|
|
| isInGame (x, y) game = gameStacks (board game) !! x
|
|
| otherwise = pile $ board game
|
|
|
|
-- Based on a coordinate, return a card.
|
|
getCardFromCoord :: Game -> Coordinate -> Card
|
|
getCardFromCoord game (x, y)
|
|
| isInPile (x, y) = head $ pile (board game)
|
|
| isInEnding (x, y) = head $ endingStacks (board game) !! (x - (amountOfGameStacks - amountOfEndingStacks))
|
|
| isInGame (x, y) game = (gameStacks (board game) !! x ) !! negate y
|
|
| otherwise = (NoneType, NoneValue, Hidden)
|
|
|
|
--------------------------- Change cards -----------------------------
|
|
|
|
-- Show the first of a stack of cards.
|
|
showFirst :: Stack -> Stack
|
|
showFirst [] = []
|
|
showFirst (c:cs) = showCard c : cs
|
|
|
|
-- Rotate the pile n times.
|
|
rotatePile :: Game -> Game
|
|
rotatePile g@Game{ board = b } = g{ board = rotatedBoard }
|
|
where rotatedBoard = b{ pile = tail ++ head }
|
|
(head, tail) = splitAt rotateStep $ pile b
|
|
|
|
-- Check if a card can be placed ontop of a gameStack.
|
|
canPlayOn :: Card -> Stack -> Bool
|
|
canPlayOn (_,King,_) [] = True
|
|
canPlayOn (t1,v1,_) ((t2,v2,_):cs) = differentColor && predValue
|
|
where differentColor = t1 /= t2 && (fromEnum t1 + fromEnum t2) `elem` [1,2,4,5]
|
|
predValue = succ v1 == v2
|
|
canPlayOn _ _ = False
|
|
|
|
-- Check if a card can be played ontop of an EndingStack.
|
|
canFinishOn :: Card -> Stack -> Bool
|
|
canFinishOn (_,Ace,_) [] = True
|
|
canFinishOn (t1,v1,_) ((t2,v2,_):cs) = sameType && succValue
|
|
where sameType = t1 == t2
|
|
succValue = v1 == succ v2
|
|
canFinishOn _ _ = False
|
|
|
|
-- Move a card to a GameStack. Move all the cards below the given card
|
|
-- on the 'from' stack as well.
|
|
moveBetweenGS :: Int -> Stack -> Stack -> (Stack,Stack)
|
|
moveBetweenGS index from to
|
|
| canPlayOn (from !! index) to = (showFirst removed, added)
|
|
| otherwise = (from,to)
|
|
where (diff,removed) = splitAt (index + 1) from
|
|
added = diff ++ to
|
|
|
|
-- Move a card to an EndingStack. This can only be a single card at once.
|
|
moveToES :: Int -> Stack -> Stack -> (Stack,Stack)
|
|
moveToES _ from to
|
|
| canFinishOn (head from) to = (showFirst removed, added)
|
|
| otherwise = (from,to)
|
|
where (diff,removed) = splitAt 1 from
|
|
added = diff ++ to
|
|
|
|
-- Move from an EndingStack to GameStack.
|
|
moveESToGS :: Int -> Stack -> Stack -> (Stack,Stack)
|
|
moveESToGS _ from to
|
|
| canPlayOn (head from) to = (cs, added)
|
|
| otherwise = (from, to)
|
|
where (c:cs) = from
|
|
added = c:to
|
|
|
|
-- Move from one gameStack to another.
|
|
moveGS2GS :: Coordinate -> Int -> Board -> Board
|
|
moveGS2GS fromCoord toStackNr board
|
|
| canPlayOn (from !! (index - 1)) to = newBoard
|
|
| otherwise = board
|
|
where (fromStackNr, negIndex) = fromCoord
|
|
fromAmount = length from
|
|
oldGS = gameStacks board
|
|
from = oldGS !! fromStackNr
|
|
to = oldGS !! toStackNr
|
|
index = fromAmount - negate negIndex
|
|
(diff, newFrom) = splitAt index from
|
|
newTo = diff ++ to
|
|
tempGS = switchStack oldGS fromStackNr (showFirst newFrom)
|
|
newGS = switchStack tempGS toStackNr newTo
|
|
newBoard = board{ gameStacks = newGS }
|
|
|
|
moveGS2ES :: Coordinate -> Int -> Board -> Board
|
|
moveGS2ES fromCoord toIndex board
|
|
| canFinishOn (head from) to = newBoard
|
|
| otherwise = board
|
|
where (fromIndex, _) = fromCoord
|
|
oldGS = gameStacks board
|
|
oldES = endingStacks board
|
|
from = oldGS !! fromIndex
|
|
to = oldES !! toIndex
|
|
(card:newGSStack) = from
|
|
newESStack = card:to
|
|
newGS = switchStack oldGS fromIndex (showFirst newGSStack)
|
|
newES = switchStack oldES toIndex newESStack
|
|
newBoard = board{ endingStacks = newES, gameStacks = newGS }
|
|
|
|
-- Move a card between pile and endingStacks.
|
|
moveP2ES :: Coordinate -> Int -> Board -> Board
|
|
moveP2ES _ toIndex board
|
|
| canFinishOn (head oldPile) to = newBoard
|
|
| otherwise = board
|
|
where oldPile = pile board
|
|
oldES = endingStacks board
|
|
to = oldES !! toIndex
|
|
(card:newPile) = oldPile
|
|
newESStack = card:to
|
|
newES = switchStack oldES toIndex newESStack
|
|
newBoard = board{ pile = newPile, endingStacks = newES }
|
|
|
|
-- Move a card between pile and gameStacks.
|
|
moveP2GS :: Coordinate -> Int -> Board -> Board
|
|
moveP2GS _ toStackNr board
|
|
| canPlayOn (head oldPile) to = newBoard
|
|
| otherwise = board
|
|
where oldPile = pile board
|
|
oldGS = gameStacks board
|
|
to = oldGS !! toStackNr
|
|
(card:newPile) = oldPile
|
|
newGSStack = card:to
|
|
newGS = switchStack oldGS toStackNr newGSStack
|
|
newBoard = board{ gameStacks = newGS, pile = newPile }
|
|
|
|
moveES2GS :: Coordinate -> Int -> Board -> Board
|
|
moveES2GS fromCoord toStackNr board
|
|
| canPlayOn (head from) to = newBoard
|
|
| otherwise = board
|
|
where (tempIndex, _) = fromCoord
|
|
fromIndex = tempIndex - (amountOfGameStacks - amountOfEndingStacks)
|
|
oldES = endingStacks board
|
|
oldGS = gameStacks board
|
|
from = oldES !! fromIndex
|
|
to = oldGS !! toStackNr
|
|
(card:newESStack) = from
|
|
newGSStack = card:to
|
|
newES = switchStack oldES fromIndex newESStack
|
|
newGS = switchStack oldGS toStackNr newGSStack
|
|
newBoard = board{ gameStacks = newGS, endingStacks = newES }
|
|
|
|
|
|
-- Switch a stack for another stack in a list of stacks.
|
|
switchStack :: [Stack] -> Int -> Stack -> [Stack]
|
|
switchStack ss index new = front ++ new:back
|
|
where (front, back') = splitAt index ss
|
|
back = tail back'
|
|
|
|
-- Get the stack that is located in the given zone at the given index.
|
|
getStackFromZone :: Game -> Zone -> Int -> Stack
|
|
getStackFromZone game Pile index = pile (board game)
|
|
getStackFromZone game ES index = endingStacks (board game) !! index
|
|
getStackFromZone game GS index = gameStacks (board game) !! index
|
|
|
|
-- Move between to zones with two indexes
|
|
getMoveFunction2 :: Zone -> Zone -> Coordinate -> Int -> Board -> Board
|
|
getMoveFunction2 Pile ES coord index = moveP2ES coord index
|
|
getMoveFunction2 Pile GS coord index = moveP2GS coord index
|
|
getMoveFunction2 GS GS coord index = moveGS2GS coord index
|
|
getMoveFunction2 GS ES coord index = moveGS2ES coord index
|
|
getMoveFunction2 ES GS coord index = moveES2GS coord index
|
|
getMoveFunction2 _ _ _ _ = id
|
|
|
|
transformIndex :: Zone -> Int -> Int
|
|
transformIndex ES index = index - (amountOfGameStacks - amountOfEndingStacks)
|
|
transformIndex Pile _ = 0
|
|
transformIndex _ index = index
|
|
|
|
-- Move a card from Coordinate to Coordinate.
|
|
moveCard :: Game -> Coordinate -> Coordinate -> Game
|
|
moveCard game fromCoord toCoord = game{ board = newBoard }
|
|
where originalBoard = board game
|
|
(x, _) = fromCoord
|
|
(index, _) = toCoord
|
|
properIndex = transformIndex toZone index
|
|
fromZone = getZoneFromCoord game fromCoord
|
|
toZone = getZoneFromCoord game toCoord
|
|
fromStack = getStackFromZone game fromZone x
|
|
toStack = getStackFromZone game toZone x
|
|
moveFunction = getMoveFunction2 fromZone toZone fromCoord properIndex
|
|
newBoard = moveFunction originalBoard
|
|
|
|
------------------------------ Input ---------------------------------
|
|
|
|
-- Check if moving in a direction is legal.
|
|
isLegalMove :: Direction -> Game -> Bool
|
|
isLegalMove dir g = isInPile coord || isInEnding coord || isInGame coord g
|
|
where coord = position $ move dir $ selector g
|
|
|
|
-- Move the selector of the game. (Wrapper)
|
|
moveSelector :: Direction -> Game -> Game
|
|
moveSelector dir g@Game{ selector = s }
|
|
| isLegalMove dir g = g{ selector = move dir s }
|
|
| otherwise = g
|
|
|
|
-- Toggle selector. If a card was already selected, try to move it.
|
|
toggleSelector :: Game -> Game
|
|
toggleSelector g@Game{ selector = s@Selector{ selected = Nothing } } = toggled
|
|
where toggled = g{ selector = toggleSelection s }
|
|
toggleSelector g@Game{ selector = s@Selector{ selected = Just coord } } = moved
|
|
where moved = moveCard g{ selector = toggleSelection s } (getSelected s) (position s)
|
|
|
|
-- Handle all the inputs necessary for patience.
|
|
handleInputs :: Event -> Game -> Game
|
|
handleInputs = composeInputHandler [
|
|
handleUp (moveSelector U),
|
|
handleDown (moveSelector D),
|
|
handleLeft (moveSelector L),
|
|
handleRight (moveSelector R),
|
|
|
|
handleSpace toggleSelector,
|
|
handleEnter rotatePile
|
|
]
|