diff --git a/lib/CardDeck.hs b/lib/CardDeck.hs index b98d32e..982688f 100644 --- a/lib/CardDeck.hs +++ b/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] diff --git a/lib/CardRenderer.hs b/lib/CardRenderer.hs new file mode 100644 index 0000000..7a3a185 --- /dev/null +++ b/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 diff --git a/lib/InputHandler.hs b/lib/InputHandler.hs new file mode 100644 index 0000000..6555836 --- /dev/null +++ b/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 diff --git a/lib/PNGRenderer.hs b/lib/PNGRenderer.hs new file mode 100644 index 0000000..04955bc --- /dev/null +++ b/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 diff --git a/lib/Patience.hs b/lib/Patience.hs new file mode 100644 index 0000000..dcdab32 --- /dev/null +++ b/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. -- +---------------------------------------------------------------------- diff --git a/lib/PatienceBoard.hs b/lib/PatienceBoard.hs index 3253241..2465d50 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, 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 + ] diff --git a/lib/PatienceRenderer.hs b/lib/PatienceRenderer.hs new file mode 100644 index 0000000..4ca4935 --- /dev/null +++ b/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) diff --git a/lib/Selector.hs b/lib/Selector.hs new file mode 100644 index 0000000..e2693c5 --- /dev/null +++ b/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 diff --git a/lib/SelectorRenderer.hs b/lib/SelectorRenderer.hs new file mode 100644 index 0000000..4bc38fb --- /dev/null +++ b/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 diff --git a/lib/Shuffle.hs b/lib/Shuffle.hs index 6f349c6..14f8919 100644 --- a/lib/Shuffle.hs +++ b/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 diff --git a/lib/assets/hearts/heart-4.png b/lib/assets/hearts/heart-4.png index d605446..a14dc61 100644 Binary files a/lib/assets/hearts/heart-4.png and b/lib/assets/hearts/heart-4.png differ diff --git a/lib/assets/hearts/heart-A.png b/lib/assets/hearts/heart-A.png index 0aa8ede..6b0ed46 100644 Binary files a/lib/assets/hearts/heart-A.png and b/lib/assets/hearts/heart-A.png differ diff --git a/lib/assets/selected.png b/lib/assets/selected.png index 011c55d..69c7876 100644 Binary files a/lib/assets/selected.png and b/lib/assets/selected.png differ diff --git a/lib/assets/selector.png b/lib/assets/selector.png index 7ea8930..8da890d 100644 Binary files a/lib/assets/selector.png and b/lib/assets/selector.png differ diff --git a/patience.cabal b/patience.cabal index 214f1fa..eac70b7 100644 --- a/patience.cabal +++ b/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 diff --git a/src/Main.hs b/src/Main.hs index 55d35ac..927c356 100644 --- a/src/Main.hs +++ b/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 diff --git a/test/PatienceTest.hs b/test/PatienceTest.hs new file mode 100644 index 0000000..795b750 --- /dev/null +++ b/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) + diff --git a/test/VoorbeeldTest.hs b/test/VoorbeeldTest.hs deleted file mode 100644 index 2b94edb..0000000 --- a/test/VoorbeeldTest.hs +++ /dev/null @@ -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"