Merge pull request 'polishing' (#20) from polishing into master

Reviewed-on: https://git.depeuter.tk/tdpeuter/patience/pulls/20

lib/CardDeck.hs

@@ -1,17 +1,31 @@
 module CardDeck
 ( Card
-, CardStatus(..)
+, CardType (..)
+, CardValue (..)
+, CardStatus (..)
 , Stack
 
 , generateDeck
 , generateShuffledDeck
+
 , showCard
 , hideCard
 , flipCard
+, matchType
+, matchValue
+, matchColor
 ) where
 
 import Shuffle
 
+----------------------------------------------------------------------
+-- Representation of the Standard 52-card deck.                     --
+-- Extra support for handling piles of cards, hiding and showing    --
+-- cards and checking if two match given a property.                --
+----------------------------------------------------------------------
+
+----------------------------- Constants ------------------------------
+
 -- Colors of cards
 data CardType = Clubs
               | Diamonds
@@ -39,7 +53,7 @@ data CardValue = Ace
 
 data CardStatus = Hidden
                 | Visible
-                deriving (Show)
+                deriving (Show, Eq)
 
 -- A card has a type and a value and is either shown or hidden.
 type Card = (CardType, CardValue, CardStatus)
@@ -47,21 +61,40 @@ type Card = (CardType, CardValue, CardStatus)
 -- A stack of cards
 type Stack = [Card]
 
--- Generate a standard 52-card deck, given by CardValue and CardType
+----------------------------------------------------------------------
+
+-- Generate a standard 52-card deck, with values by CardValue and types
+-- by CardType. Cards are hidden by default.
 generateDeck :: Stack
 generateDeck = [(cType, cValue, Hidden) | cType <- types, cValue <- values]
     where types  = init $ enumFrom Clubs
           values = init $ enumFrom Ace 
 
+-- Generate a standard 52-card deck and shuffle all cards randomly.
 generateShuffledDeck :: Stack
 generateShuffledDeck = shuffle generateDeck
 
+-- Show a card.
 showCard :: Card -> Card
 showCard (t, v, _) = (t,v,Visible)
 
+-- Hide a card.
 hideCard :: Card -> Card
 hideCard (t, v, _) = (t,v,Hidden)
 
+-- Flip the card. If it was visible, it is now hidden and vice versa.
 flipCard :: Card -> Card
 flipCard c@(_, _, Visible) = hideCard c
 flipCard c@(_, _, Hidden)  = showCard c
+
+-- Check if two cards match type.
+matchType :: Card -> Card -> Bool
+matchType (t1, _, _) (t2, _, _) = t1 == t2
+
+-- Check if two cards match color.
+matchValue :: Card -> Card -> Bool
+matchValue (_, v1, _) (_, v2, _) = v1 == v2
+
+-- Check if two cards have the same color.
+matchColor :: Card -> Card -> Bool
+matchColor (t1, _, _) (t2, _, _) = t1 == t2 || (fromEnum t1 + fromEnum t2) `elem` [3, 6]

lib/CardRenderer.hs

@@ -0,0 +1,88 @@
+module CardRenderer
+( cardHeight
+, cardWidth
+
+, renderCard
+, renderStack
+, renderStacks
+) where
+
+import CardDeck
+import PNGRenderer
+
+----------------------------- Constants ------------------------------
+
+-- The asset directory
+assetDir :: [Char]
+assetDir = "./lib/assets/"
+
+cardWidth :: Float
+cardWidth = 100
+
+cardHeight :: Float
+cardHeight = 134
+
+-- Map of all (rendered) cards
+cardRenders :: [Picture]
+cardRenders = back:placeHolder:deck
+    where deck        = map (renderCard' . showCard) generateDeck
+          back        = renderPNG $ assetDir ++ "back.png"
+          placeHolder = renderPNG $ assetDir ++ "placeholder.png" 
+
+amountOfValues :: Int
+amountOfValues = length $ init $ enumFrom Ace
+
+----------------------------------------------------------------------
+
+-- Render a card using renderPNG.
+renderCard' :: Card -> Picture
+renderCard' (_,_,Hidden)     = renderPNG $ assetDir ++ "back.png"
+renderCard' (ctype,cvalue,_) = renderPNG $ file_dir ++ file_name
+    where typestring  = cardTypeToString ctype
+          valuestring = cardTypeToChar cvalue
+          file_dir    = assetDir ++ typestring ++ "s/"
+          file_name   = typestring ++ "-" ++ valuestring ++ ".png"
+
+-- Render a card using the cached cards.
+renderCard :: Card -> Picture
+renderCard (_, _, Hidden)     = head cardRenders
+renderCard (cType, cValue, _) = cardRenders !! index
+    where index          = 2 + t * amountOfValues + v
+          t              = fromEnum cType
+          v              = fromEnum cValue
+
+-- Spread cards out, by moving each card a distance x over the x-axis
+-- and y over the y-axis.
+spread :: Float -> Float -> [Picture] -> [Picture]
+spread x y = zipWith shift [0 .. ]
+    where shift index = translate (x * index) (y * index)
+
+-- Render all cards of a stack with a card inset of given value.
+renderStack :: Float -> Stack -> Picture
+renderStack _        []    = cardRenders !! 1
+renderStack cardDist stack = compose spreadOutStack
+    where renderedStack  = map renderCard $ reverse stack
+          spreadOutStack = spread 0 cardDist renderedStack
+
+-- Render all cards of multiple stacks, with a given distance between
+-- all stacks and a different distance between cards.
+renderStacks :: Float -> Float -> [Stack] -> Picture
+renderStacks stackDist cardDist = compose . spreadOutStacks
+    where renderedStacks  = map (renderStack cardDist)
+          spreadOutStacks = spread (stackDist + cardWidth) 0 . renderedStacks
+
+-- Convert a CardType to a string.
+cardTypeToString :: CardType -> [Char]
+cardTypeToString Clubs    = "club"
+cardTypeToString Diamonds = "diamond"
+cardTypeToString Hearts   = "heart"
+cardTypeToString Spades   = "spade"
+cardTypeToString _        = ""
+
+-- Convert a CardType to a character.
+cardTypeToChar :: CardValue -> [Char]
+cardTypeToChar Ace   = "A"
+cardTypeToChar Jack  = "J"
+cardTypeToChar Queen = "Q"
+cardTypeToChar King  = "K"
+cardTypeToChar a     = show $ 1 + fromEnum a

lib/InputHandler.hs

@@ -0,0 +1,65 @@
+module InputHandler 
+( Event
+
+, handleInput
+, composeInputHandler
+
+, handleSpace
+, handleEnter
+, handleUp
+, handleDown
+, handleLeft
+, handleRight
+) where
+
+import Graphics.Gloss
+import qualified Graphics.Gloss.Interface.IO.Game as Game
+
+----------------------------------------------------------------------
+-- Handle one or more InputEvents to do something. Compose them to  --
+-- create an InputHandler that handles multiple inputs.             --
+----------------------------------------------------------------------
+
+----------------------------- Constants ------------------------------
+
+-- Something that happens, most often a keypress
+type Event = Game.Event
+
+----------------------------------------------------------------------
+
+-- Handle input by taking a keyCheck function that checks wheter or not
+-- a key is being presse
+handleInput :: Game.SpecialKey -> (a -> a) -> Event -> a -> a
+handleInput key convert ev currentState
+    | isKey key ev = convert currentState
+    | otherwise    = currentState
+
+-- Compose multiple InputHandlers into one combined InputHandler.
+composeInputHandler :: [Event -> a -> a] -> Event -> a -> a
+composeInputHandler (ih:ihs) ev a = composeInputHandler ihs ev (ih ev a)
+composeInputHandler []       ev a = a
+
+-- Check if the requested key is pressed.
+isKey :: Game.SpecialKey -> Event -> Bool
+isKey k1 (Game.EventKey (Game.SpecialKey k2) Game.Down _ _) = k1 == k2
+isKey _  _                                                  = False
+
+------------------ A couple of default inputhandlers -----------------
+
+handleSpace :: (a -> a) -> Event -> a -> a
+handleSpace = handleInput Game.KeySpace
+
+handleEnter :: (a -> a) -> Event -> a -> a
+handleEnter = handleInput Game.KeyEnter
+
+handleUp :: (a -> a) -> Event -> a -> a
+handleUp = handleInput Game.KeyUp
+
+handleDown :: (a -> a) -> Event -> a -> a
+handleDown = handleInput Game.KeyDown
+
+handleLeft :: (a -> a) -> Event -> a -> a
+handleLeft = handleInput Game.KeyLeft
+
+handleRight :: (a -> a) -> Event -> a -> a
+handleRight = handleInput Game.KeyRight

lib/PNGRenderer.hs

@@ -0,0 +1,40 @@
+module PNGRenderer
+( Picture
+
+, renderPNG
+, compose
+, translate
+, blank
+) where
+
+import Data.Maybe
+import System.IO.Unsafe
+import qualified Graphics.Gloss as Gloss
+import Graphics.Gloss.Juicy
+
+----------------------------------------------------------------------
+-- Render a file using Gloss.Picture. Compose multiple images into  --
+-- one.                                                             --
+----------------------------------------------------------------------
+
+----------------------------- Constants ------------------------------
+
+type Picture = Gloss.Picture
+
+----------------------------------------------------------------------
+
+-- Turn a path to a .png file into a Picture.
+renderPNG :: FilePath -> Picture
+renderPNG = fromJust . unsafePerformIO . loadJuicyPNG
+
+-- An empty picture
+blank :: Picture
+blank = Gloss.Blank
+
+-- Translate a picture by moving it along two axis.
+translate :: Float -> Float -> Picture -> Picture
+translate = Gloss.translate
+
+-- Compose multiple pictures into a single picture.
+compose :: [Picture] -> Picture
+compose = Gloss.Pictures

lib/Patience.hs

@@ -0,0 +1,39 @@
+module Patience
+( playPatience
+) where
+
+import PatienceBoard
+import PatienceRenderer
+
+import Graphics.Gloss (dim, 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 bgcolor fps initGame render handleInputs step
+    where window   = getWindow
+          step _ g = g
+          bgcolor  = dim green
+
+---------------------------- Documentation ---------------------------
+-- The structure of this project is based on the Model-View-        --
+-- Controller as known in Java. This clearly seperates different    --
+-- functionality from each other. I also tried to put as much       --
+-- functionality of the same thing into a single module. I always   --
+-- asked myself: "Could I use this piece of code in a different     --
+-- project?" If the answer was yes, there is now a module for it.   --
+--                             -*-                                  --
+-- This block merely serves as a message to the person reviewing    --
+-- this code.                                                       --
+----------------------------------------------------------------------

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, Eq)
 
 -- Representation of a Patience board
 data Board = Board {
@@ -14,29 +38,278 @@ data Board = Board {
     endingStacks :: [Stack],
     -- Stack of cards that are not yet on the board
     pile         :: Stack
-} deriving (Show)
+} deriving (Show, Eq)
 
--- 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 && null xStack
+
+-- 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
+
+--------------------------- 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,vis2):_) = differentColor && predValue && visibility
+    where (t1,v1,vis) = cs !! index
+          differentColor = not $ (t1,v1,vis) `matchColor` (t2,v2,vis2)
+          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 }
+-- Move from a gameStack to an endingStack.
+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 }
+
+-- Move a card from an endingStack to a gameStack.
+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
+getStackFromZone _    Out  _     = []
+
+-- 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
+
+-- Tranform the index based on the zone.
+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 [
+    -- Selector movement
+    handleUp    (moveSelector U), 
+    handleDown  (moveSelector D),
+    handleLeft  (moveSelector L),
+    handleRight (moveSelector R), 
+    -- Selection handling
+    handleSpace toggleSelector,
+    -- Pile rotation
+    handleEnter rotatePile
+    ]

lib/PatienceRenderer.hs

@@ -0,0 +1,115 @@
+module PatienceRenderer
+( render
+, getWindow
+) where
+
+import CardDeck
+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
+
+-- 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
+
+-- X axis render difference for Pile
+pileXDiff :: Float
+pileXDiff = 0
+
+-- Y axis render difference for Pile
+pileYDiff :: Float
+pileYDiff = esYDiff
+
+----------------------------------------------------------------------
+
+-- 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
+
+-- Render the Pile zone.
+renderPile :: Board -> Picture
+renderPile = renderStack 0 . pile
+
+-- 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
+
+-- Render the patience game.
+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
+
+-- The default window to play patience.
+getWindow :: Display
+getWindow = InWindow "Patience" (1200,800) (50,50)

lib/Selector.hs

@@ -0,0 +1,101 @@
+module Selector
+( Selector (..)
+, Coordinate
+, Direction (..)
+
+, initSelector
+, move
+, moveBy
+, select
+, deselect
+, toggleSelection
+, getSelected
+
+, 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, Eq)
+
+----------------------------------------------------------------------
+
+-- 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 the current position.
+select :: Selector -> Selector
+select s@Selector{ position = pos } = s{ selected = Just pos }
+
+-- Deselect the current selection.
+deselect :: Selector -> Selector
+deselect s = s{ selected = Nothing }
+
+-- Toggle the selection of the selector. Deselect if any position is
+-- selected, otherwise select the current position.
+toggleSelection :: Selector -> Selector
+toggleSelection s@Selector{ selected = Nothing } = select s
+toggleSelection s                                = deselect s
+
+-- Get the selected coordinate, otherwise get (0,0) by default.
+getSelected :: Selector -> Coordinate
+getSelected s@Selector{ selected = Just c  } = c
+getSelected s@Selector{ selected = Nothing } = (0,0)
+
+----------------------------------------------------------------------
+
+-- 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

lib/SelectorRenderer.hs

@@ -0,0 +1,39 @@
+module SelectorRenderer
+( renderSelector
+, renderSelected
+) where
+
+import Selector
+import PNGRenderer
+
+----------------------------- Constants ------------------------------
+
+selectorFilePath :: FilePath
+selectorFilePath = "./lib/assets/selector.png"
+
+selectedFilePath :: FilePath
+selectedFilePath = "./lib/assets/selected.png"
+
+selectorRenders :: (Picture, Picture)
+selectorRenders = (
+    renderPNG selectorFilePath, 
+    renderPNG selectedFilePath
+    )
+
+----------------------------------------------------------------------
+
+-- Render the outline of the selector. The offset for every value 1 
+-- in the coordinate must be given.
+renderSelector :: Float -> Float -> Selector -> Picture
+renderSelector a b Selector{ position = (x,y) } = translate fx fy render
+    where fx     = fromIntegral x * a
+          fy     = fromIntegral y * b
+          render = fst selectorRenders
+
+-- Render the selected piece if any.
+renderSelected :: Float -> Float -> Selector -> Picture
+renderSelected a b Selector{ selected = Just (x, y) } = translate fx fy render
+    where fx     = fromIntegral x * a
+          fy     = fromIntegral y * b
+          render = snd selectorRenders
+renderSelected _ _ _                                  = blank

lib/Shuffle.hs

@@ -1,12 +1,23 @@
-module Shuffle (
-    shuffle
+module Shuffle
+( shuffle
 ) where
 
 import Data.List
 import System.Random
 
+----------------------------------------------------------------------
+-- Shuffle a list so that the elements of the list are randomly     --
+-- perumated.                                                       --
+----------------------------------------------------------------------
+
+----------------------------- Constants ------------------------------
+
+-- The seed used to generate random numbers.
+seed :: Int
 seed = 20
 
+----------------------------------------------------------------------
+
 -- Shuffle a list of values.
 shuffle :: [a] -> [a]
 shuffle l = map (l !!) $ generateIndices $ length l
@@ -19,6 +30,5 @@ generateIndices size = take size uniqueList
           uniqueList = nub randomList
 
 -- Generate a random generator
--- TODO Écht random maken?
 randomGen :: StdGen
 randomGen = mkStdGen seed

patience.cabal

@@ -6,18 +6,18 @@ build-type:     Simple
 
 library
   hs-source-dirs: lib
-  build-depends: base >= 4.7 && <5, random >= 1.1 && < 1.4
-  exposed-modules: CardDeck, PatienceBoard, Shuffle
+  build-depends: base >= 4.7 && <5, gloss >= 1.11 && < 1.14, gloss-juicy >= 0.2.3, random >= 1.1 && < 1.4
+  exposed-modules: CardDeck, CardRenderer, InputHandler, Patience, PatienceBoard, PatienceRenderer, PNGRenderer, Selector, SelectorRenderer, Shuffle
 
 executable patience
   main-is: Main.hs
   hs-source-dirs: src
   default-language: Haskell2010
-  build-depends: base >= 4.7 && <5, gloss >= 1.11 && < 1.14, gloss-juicy >= 0.2.3, patience
+  build-depends: base >= 4.7 && <5, gloss >= 1.11 && < 1.14, patience
 
 test-suite patience-test
   type: exitcode-stdio-1.0
-  main-is: VoorbeeldTest.hs
+  main-is: PatienceTest.hs
   hs-source-dirs: test
   default-language: Haskell2010
   build-depends: base >=4.7 && <5, hspec <= 2.10.6, patience

src/Main.hs

@@ -1,4 +1,12 @@
-import VoorbeeldModule (hoi)
+import Patience
 
-main :: IO ()
-main = putStrLn hoi
+----------------------------- Constants ------------------------------
+
+-- Framerate of the game
+fps :: Int
+fps = 60
+
+----------------------------------------------------------------------
+
+main :: IO()
+main = playPatience fps

test/PatienceTest.hs

@@ -0,0 +1,52 @@
+import Test.Hspec
+
+import CardDeck
+import PatienceBoard
+import Selector
+
+main :: IO ()
+main = hspec $ do
+    describe "Testing CardDeck" $ do
+        it "generateDeck generates a full sized deck" $ do
+            length generateDeck == 52
+
+        it "showCard shows card" $ do
+            showCard (Hearts, Ace, Hidden)  `shouldBe` (Hearts, Ace, Visible)
+            showCard (Clubs, King, Visible) `shouldBe` (Clubs, King, Visible)
+
+        it "hideCard hides card" $ do
+            hideCard (Hearts, King, Hidden) `shouldBe` (Hearts, King, Hidden)
+            hideCard (Spades, Ace, Visible) `shouldBe` (Spades, Ace, Hidden)
+
+        it "flipCard flips card" $ do
+            flipCard (Hearts, Ace, Hidden)  `shouldBe` (Hearts, Ace, Visible)
+            flipCard (Hearts, Ace, Visible) `shouldBe` (Hearts, Ace, Hidden)
+
+        it "matchType checks types" $ do
+            matchType (Hearts, Ace, Visible)  (Hearts, King, Hidden) `shouldBe` True
+            matchType (Hearts, Ace, Visible)  (Clubs, Ace, Visible)  `shouldBe` False
+            matchType (NoneType, Ace, Hidden) (Spades, King, Hidden) `shouldBe` False
+
+        it "matchColor checks colors" $ do
+            matchColor (Hearts, Ace, Visible)    (Hearts, King, Hidden)   `shouldBe` True
+            matchColor (Hearts, Ace, Visible)    (Diamonds, King, Hidden) `shouldBe` True
+            matchColor (Spades, King, Hidden)    (Clubs, Two, Visible)    `shouldBe` True
+            matchColor (Spades, King, Hidden)    (Hearts, Three, Visible) `shouldBe` False
+            matchColor (Diamonds, Four, Visible) (Clubs, Five, Hidden)    `shouldBe` False
+    
+    describe "Testing PatienceBoard" $ do
+        it "Starts with empty endingStacks" $ do
+            endingStacks (board initGame) `shouldBe` [[],[],[],[]]
+        it "Check size of pile at start of game" $ do
+            length (pile (board initGame)) `shouldBe` foldl (-) 52 [0 .. amountOfGameStacks]
+        it "First gameStack should be smallest" $ do
+            length (head (gameStacks (board initGame))) `shouldBe` 1
+        it "Last gameStack should be biggest" $ do
+            length (gameStacks (board initGame) !! (amountOfGameStacks - 1)) `shouldBe` amountOfGameStacks
+
+    describe "Testing Selector" $ do
+        it "initSelector is empty" $ do
+            selected initSelector `shouldBe` Nothing
+        it "select selects" $ do
+            selected (toggleSelection initSelector) `shouldBe` Just (0,0)
+

test/VoorbeeldTest.hs

@@ -1,11 +0,0 @@
-import Test.Hspec
-
-import VoorbeeldModule (hoi, hallo)
-
-main :: IO ()
-main = hspec $ do 
-    it "Returns correct string for hoi" $ do
-        hoi `shouldBe` "Hoi"
-
-    it "Returns correct string for hallo" $ do
-        hallo `shouldBe` "Hallo"