diff --git a/lib/Patience.hs b/lib/Patience.hs new file mode 100644 index 0000000..021da57 --- /dev/null +++ b/lib/Patience.hs @@ -0,0 +1,26 @@ +module Patience +( playPatience +) where + +import PatienceBoard +import PatienceRenderer + +import Graphics.Gloss (green, play) + +--------------------------------------------------------------------- +-- Single module to play patience. -- +-- Includes all logic and rendering. -- +--------------------------------------------------------------------- + +----------------------------- Constants ------------------------------ + +-- Framerate of the game +type FPS = Int + +--------------------------------------------------------------------- + +-- Play a game of patience. +playPatience :: FPS -> IO() +playPatience fps = do play window green fps initGame render handleInputs step + where window = getWindow + step _ g = g diff --git a/lib/PatienceBoard.hs b/lib/PatienceBoard.hs index 3253241..c33d1f6 100644 --- a/lib/PatienceBoard.hs +++ b/lib/PatienceBoard.hs @@ -1,10 +1,34 @@ module PatienceBoard -( Board +( Game (..) +, Board (..) +, amountOfGameStacks +, amountOfEndingStacks +, gameStacksCoord +, endingStacksCoord +, pileCoord -,initBoard +, 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 { @@ -16,27 +40,287 @@ data Board = Board { pile :: Stack } deriving (Show) --- Show the first of a stack of cards. -showFirst :: Stack -> Stack -showFirst (c:cs) = (showCard c):cs +-- 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' 7 +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) + in showFirst stack : splitDeck' (n - 1) rest --- Return the initial board consisting of a stack of yet-to-be-turned --- cards and 7 stacks of increasingly large amount of cards (1, ..., 7) +-- 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 = let pile:stacks = splitDeck generateShuffledDeck - in Board { - gameStacks = stacks, - endingStacks = [[],[],[],[]], - pile = pile - } +initBoard = Board { + gameStacks = stacks, + endingStacks = replicate amountOfEndingStacks [], + pile = map showCard pile + } + where pile:stacks = splitDeck generateShuffledDeck -moveBetweenStacks :: Stack -> Int -> Stack -> Stack -moveBetweenStacks from index to = undefined +-- 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 + xStack = gameStacks (board g) !! x + downBound = zero || negate y < length xStack + zero = y == 0 && length xStack == 0 + +-- 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 :: Stack -> Int -> Stack -> Bool +canPlayOn [] _ _ = False +canPlayOn cs index [] = v1 == King && vis == Visible + where (_,v1,vis) = cs !! index +canPlayOn cs index ((t2,v2,_):_) = differentColor && predValue && visibility + where (t1,v1,vis) = cs !! index + differentColor = t1 /= t2 && (fromEnum t1 + fromEnum t2) `elem` [1,2,4,5] + predValue = succ v1 == v2 + visibility = vis == Visible + +-- Check if a card can be played ontop of an EndingStack. +canFinishOn :: Stack -> Int -> Stack -> Bool +canFinishOn [] _ _ = False +canFinishOn cs index [] = v1 == Ace && vis == Visible + where (_,v1,vis) = cs !! index +canFinishOn cs index ((t2,v2,_):_) = sameType && succValue && visibility + where (t1,v1,vis) = cs !! index + sameType = t1 == t2 + succValue = v1 == succ v2 + visibility = vis == Visible + +-- 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 from 0 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 oldPile 0 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 oldPile 0 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 from 0 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 + ] diff --git a/lib/PatienceRenderer.hs b/lib/PatienceRenderer.hs new file mode 100644 index 0000000..8af09c6 --- /dev/null +++ b/lib/PatienceRenderer.hs @@ -0,0 +1,117 @@ +module PatienceRenderer +( render +, getWindow +) where + +import PatienceBoard +import Selector + +import CardRenderer +import PNGRenderer +import SelectorRenderer + +import InputHandler + +import Graphics.Gloss( + Display(..) + , green + , play + ) + +----------------------------- Constants ------------------------------ + +-- Distance between cards that are on top of each other +cardDistance :: Float +cardDistance = 20 + +-- Distance between neighbouring stacks +stackDistance :: Float +stackDistance = 10 + +-- Distance between different zones of the board +zoneDistance :: Float +zoneDistance = 25 + +---------------------------------------------------------------------- + +-- Render the GameStacks zone. +renderGS :: Board -> Picture +renderGS = renderStacks stackDistance (negate cardDistance) . gameStacks + +-- Render the EndingStacks zone. +renderES :: Board -> Picture +renderES = renderStacks stackDistance 0 . endingStacks + +-- X axis render difference for EndingStacks +esXDiff :: Float +esXDiff = fromIntegral esX * cardDistance + where cardDistance = cardWidth + stackDistance + (esX, _) = endingStacksCoord + +-- Y axis render difference for EndingStacks +esYDiff :: Float +esYDiff = fromIntegral esY * (zoneDistance + cardHeight) + where (_, esY) = endingStacksCoord + +-- Render the Pile zone. +renderPile :: Board -> Picture +renderPile = renderStack 0 . pile + +-- X axis render difference for Pile +pileXDiff :: Float +pileXDiff = 0 + +-- Y axis render difference for Pile +pileYDiff :: Float +pileYDiff = esYDiff + +-- Get the diff based on a coordinate because different 'zones' have +-- different offsets. +getDiff :: Coordinate -> (Float, Float) +getDiff coord + | isInEnding coord = (width, esYDiff) + | isInPile coord = (pileXDiff, pileYDiff) + | otherwise = (width, cardDistance) + where width = cardWidth + stackDistance + +-- The board consists of three parts: +-- the gamestacks, the endingstacks and the pile. +-- Pile is located at (0,1). +-- EndingStacks are located at (n,1) - see calculations. +-- GameStacks are located at (0,0). +renderBoard :: Board -> Picture +renderBoard board = compose [ + pile, + endingStacks, + gameStacks + ] + where pile = translate pileXDiff pileYDiff $ renderPile board + endingStacks = translate esXDiff esYDiff $ renderES board + gameStacks = renderGS board + +-- Render the PatienceGameSelector. +renderPSelector :: Selector -> Picture +renderPSelector ps = compose [ + selector, + selected + ] + where selector = renderSelector xd1 yd1 ps + selected = renderSelected xd2 yd2 ps + (xd1, yd1) = getDiff (position ps) + (xd2, yd2) = getDiff $ getSelected ps + +getSelected :: Selector -> Coordinate +getSelected s@Selector{ selected = Just c } = c +getSelected s@Selector{ selected = Nothing } = (0,0) + +render :: Game -> Picture +render game = translate centerX centerY $ compose [ + renderBoard $ board game, + renderPSelector $ selector game + ] + where centerX = negate $ (cardWidth + stackDistance) * (fromIntegral amountOfGameStacks - 1) / 2 + centerY = 0 -- TODO Different center + +-- The default window to play patience. +getWindow :: Display +getWindow = InWindow "Patience" (1200,800) (50,50) diff --git a/lib/Selector.hs b/lib/Selector.hs new file mode 100644 index 0000000..97218e8 --- /dev/null +++ b/lib/Selector.hs @@ -0,0 +1,90 @@ +module Selector +( Selector (..) +, Direction (..) + +, initSelector +, move +, moveBy +, select +, deselect +, toggleSelection + +, moveUp +, moveDown +, moveLeft +, moveRight +) where + +---------------------------------------------------------------------- +-- Base of a general purpose selector. -- +-- Can be used to show a selector, move up, down, left and right, -- +-- to 'hold' the currently selected card and remember that held. -- +-- card. -- +---------------------------------------------------------------------- + +----------------------------- Constants ------------------------------ + +-- A position on the playboard. +type Coordinate = (Int, Int) + +-- The direction in which the selector can move. +data Direction = U | D | L | R deriving (Show) + +diff = [(0,1), (0,-1), (-1,0), (1,0)] + +-- A selector can highlight a coordinate. +data Selector = Selector { + -- The current position of the selector. + position :: Coordinate, + -- The card(s) that the selector currently holds. + selected :: Maybe Coordinate +} deriving (Show) + +---------------------------------------------------------------------- + +-- Get the default selector. +initSelector :: Selector +initSelector = Selector { + position = (0,0), + selected = Nothing +} + +-- Sum two coordinates. +sumCoords :: Coordinate -> Coordinate -> Coordinate +sumCoords (x, y) (a, b) = (x + a, y + b) + +-- Move the selector by a given coordinate. +moveBy :: Coordinate -> Selector -> Selector +moveBy c1 s@Selector{ position = c2 } = s{ position = sumCoords c1 c2 } + +-- Move the selector one position into the the given direction. +move :: Direction -> Selector -> Selector +move U = moveBy (head diff) +move D = moveBy (diff !! 1) +move L = moveBy (diff !! 2) +move R = moveBy (diff !! 3) + +select :: Selector -> Selector +select s@Selector{ position = pos } = s{ selected = Just pos } + +deselect :: Selector -> Selector +deselect s = s{ selected = Nothing } + +toggleSelection :: Selector -> Selector +toggleSelection s@Selector{ selected = Nothing } = select s +toggleSelection s = deselect s + +---------------------------------------------------------------------- + +-- Move the selector up one position. +moveUp :: Selector -> Selector +moveUp = move U +-- Move the selector down one position. +moveDown :: Selector -> Selector +moveDown = move D +-- Move the selector left one position. +moveLeft :: Selector -> Selector +moveLeft = move L +-- Move the selector right one position. +moveRight :: Selector -> Selector +moveRight = move R