diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,29 @@ +Copyright (c) 2010, Eric Mertens +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +Redistributions of source code must retain the above copyright notice, +this list of conditions and the following disclaimer. + +Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in the +documentation and/or other materials provided with the distribution. + +Neither the name of the author nor the names of its contributors +may be used to endorse or promote products derived from this software +without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED +TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Main.hs b/Main.hs new file mode 100644 --- /dev/null +++ b/Main.hs @@ -0,0 +1,7 @@ +module Main where + +import Data.Monoid (mempty) +import SetGame (gameMain) + +main :: IO () +main = gameMain mempty diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import Distribution.Simple + +main :: IO () +main = defaultMainWithHooks simpleUserHooks diff --git a/setgame.cabal b/setgame.cabal new file mode 100644 --- /dev/null +++ b/setgame.cabal @@ -0,0 +1,32 @@ +name: setgame +version: 1.1 +category: Game +license: BSD3 +license-file: LICENSE +maintainer: emertens@gmail.com +synopsis: A console interface to the game of Set +description: A console interface to the game of Set +build-type: Simple +cabal-version: >=1.8 +tested-with: GHC == 7.10.2, GHC == 7.8.4 + +source-repository head + type: git + location: https://github.com/glguy/set-game + +library + build-depends: base >=4.7 && <4.9, + random >=1.1 && <1.2, + vty >=5.4 && <5.5 + hs-source-dirs: src + ghc-options: -Wall + exposed-modules: SetGame, + Set.Ascii, + Set.Card, + Set.Game, + Set.Utils + +executable set-game + main-is: Main.hs + build-depends: setgame, base + ghc-options: -Wall -threaded diff --git a/src/Set/Ascii.hs b/src/Set/Ascii.hs new file mode 100644 --- /dev/null +++ b/src/Set/Ascii.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE NamedFieldPuns #-} +module Set.Ascii (cardLines) where + +import Set.Card + +------------------------------------------------------------------------------- +-- Card drawing functions ----------------------------------------------------- +------------------------------------------------------------------------------- + +-- | 'selectArt' returns the ASCII art representation of the lines for +-- a given 'Shading' and 'Symbol'. +selectArt :: Shading -> Symbol -> [String] +selectArt Open Diamond = [" " + ," ╱╲ " + ,"╱ ╲" + ,"‾‾‾‾"] +selectArt Striped Diamond = [" " + ," ╱╲ " + ,"╱╱╲╲" + ,"‾‾‾‾"] +selectArt Solid Diamond = [" " + ," ╱╲ " + ,"╱╳╳╲" + ,"‾‾‾‾"] +selectArt Open Squiggle = ["___ " + ,"╲ ╲" + ,"╱ ╱" + ,"‾‾‾ "] +selectArt Striped Squiggle = ["___ " + ,"╲╲╲╲" + ,"╱╱╱╱" + ,"‾‾‾ "] +selectArt Solid Squiggle = ["___ " + ,"╲╳╳╲" + ,"╱╳╳╱" + ,"‾‾‾ "] +selectArt Open Oval = [" __ " + ,"╱ ╲" + ,"╲ ╱" + ," ‾‾ "] +selectArt Striped Oval = [" __ " + ,"╱╱╲╲" + ,"╲╲╱╱" + ," ‾‾ "] +selectArt Solid Oval = [" __ " + ,"╱╳╳╲" + ,"╲╳╳╱" + ," ‾‾ "] + +-- | Compute the ASCII lines and color of a given card +cardLines :: Card -> (Color, [String]) +cardLines Card {color, count, shading, symbol} + = (color, map (duplicate count) (selectArt shading symbol)) + +-- | 'duplicate' pads a 'String' to fit neatly, centered in a 14-character +-- region. +duplicate :: Count -> String -> String +duplicate One x = " " ++ x ++ " " +duplicate Two x = " " ++ x ++ " " ++ x ++ " " +duplicate Three x = " " ++ x ++ " " ++ x ++ " " ++ x ++ " " diff --git a/src/Set/Card.hs b/src/Set/Card.hs new file mode 100644 --- /dev/null +++ b/src/Set/Card.hs @@ -0,0 +1,66 @@ +module Set.Card + (-- * Types + Card(..), + Color(..), + Count(..), + Shading(..), + Symbol(..), + + -- * 'Card' interface functions + allCards, + validSet, + solve + ) where + +import Data.List (tails) + +import Set.Utils + +data Color = Red | Purple | Green + deriving (Show, Eq, Ord) + +data Count = One | Two | Three + deriving (Show, Eq, Ord) + +data Shading = Open | Striped | Solid + deriving (Show, Eq, Ord) + +data Symbol = Diamond | Squiggle | Oval + deriving (Show, Eq, Ord) + +data Card = Card { color :: Color + , count :: Count + , shading :: Shading + , symbol :: Symbol + } + deriving (Show, Eq) + +checkAttribute :: Eq a => [a] -> Bool +checkAttribute xs = all (uncurry (==)) combos + || all (uncurry (/=)) combos + where + combos = chooseTwo xs + +validSet :: Card -> Card -> Card -> Bool +validSet card1 card2 card3 + = checkAttribute (map color cards) + && checkAttribute (map count cards) + && checkAttribute (map shading cards) + && checkAttribute (map symbol cards) + where + cards = [card1, card2, card3] + +allCards :: [Card] +allCards = [Card a b c d | a <- [Red, Purple, Green] + , b <- [One, Two, Three] + , c <- [Open, Striped, Solid] + , d <- [Diamond, Squiggle, Oval]] + + +-- | 'solveBoard' returns the list of all valid sets contained in the given +-- list. +solve :: [Card] -> [(Card,Card,Card)] +solve xs = [(a,b,c) | (a:as) <- tails xs + , (b:bs) <- tails as + , c <- bs + , validSet a b c] diff --git a/src/Set/Game.hs b/src/Set/Game.hs new file mode 100644 --- /dev/null +++ b/src/Set/Game.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE NamedFieldPuns #-} +module Set.Game ( + -- * Types + Game + + -- * 'Game' creation functions + , newGame + + -- * 'Game' update functions + , considerSet + , extraCards + , sortTableau + + -- * Game query functions + , tableau + , deckNull + , deckSize + , emptyGame + , hint + ) where + +import Control.Monad (guard) +import System.Random (RandomGen) + +import Set.Card +import Set.Utils +import Data.List (sortBy) + +-- | 'tableauSize' is the minimum number of cards that should be on the tableau. +tableauSize :: Int +tableauSize = 12 + +-- | 'Game' represents the current state of a Set game including the remaining +-- shuffled deck and the current tableau. +data Game = Game [Card] [Card] + +tableau :: Game -> [Card] +tableau (Game t _) = t + +-- | 'newGame' creates a new 'Game' with a full tableau and shuffled deck. +newGame :: IO Game +newGame = (deal . Game []) `fmap` shuffleIO allCards + +-- | 'deal' adds additional cards as needed to reach 'tableauSize' cards. +deal :: Game -> Game +deal game = addCards (tableauSize - length (tableau game)) game + +-- | 'considerSet' verifies that a given set exists in the tableau +-- and then removes the set from the tableau. +considerSet :: Card -> Card -> Card -> Game -> Maybe Game +considerSet card0 card1 card2 (Game t d) = do + guard (validSet card0 card1 card2) + t' <- delete1 card0 =<< delete1 card1 =<< delete1 card2 t + return (deal (Game t' d)) + +-- | 'addCards' adds the top @n cards from the deck to the end of the tableau. +addCards :: Int -> Game -> Game +addCards n (Game t d) = Game (t ++ dealt) d' + where + (dealt, d') = splitAt n d + +-- | 'deckSize' returns the number of cards remaining in the deck. +deckSize :: Game -> Int +deckSize (Game _ d) = length d + +-- | 'deckNull' returns 'True' iff the deck is empty. +deckNull :: Game -> Bool +deckNull (Game _ d) = null d + +-- | 'extraCards' returns either a new game with 3 additional cards dealt +-- or the number of sets remaining in the tableau. +extraCards :: Game -> Either Int Game +extraCards game + | sets == 0 && not (deckNull game) = Right (addCards 3 game) + | otherwise = Left sets + where + sets = length (solve (tableau game)) + +-- | 'hint' returns a randomly selected card contained in a set found on +-- the tableau. +hint :: RandomGen g => g -> Game -> (Maybe Card, g) +hint g game = + let (tableau', g') = shuffle (tableau game) g + in case solve tableau' of + ((a,_,_):_) -> (Just a, g') + _ -> (Nothing, g') + +-- | 'sortTableau' sorts the tableau with a given order. +sortTableau :: (Card -> Card -> Ordering) -> Game -> Game +sortTableau f (Game t d) = Game (sortBy f t) d + +-- | 'emptyGame' tests for a game with no cards remaining +-- in either the tableau or the deck. +emptyGame :: Game -> Bool +emptyGame game = null (tableau game) && deckNull game + diff --git a/src/Set/Utils.hs b/src/Set/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Set/Utils.hs @@ -0,0 +1,97 @@ +module Set.Utils where + +import Data.List (tails) +import System.Random (newStdGen, RandomGen, randomR) + +------------------------------------------------------------------------------- +-- List utilities-------------------------------------------------------------- +------------------------------------------------------------------------------- + +-- | 'groups' breaks a list into sublists of the given size. The final resulting +-- group may contain fewer elements than the given size. +-- Property: For all positive n. concat (groups n xs) == xs +groups :: Int -> [a] -> [[a]] +groups _ [] = [] +groups n xs = as : groups n bs + where + (as,bs) = splitAt n xs + +-- | 'delete1' returns a list with the first occurrence of @x removed. If there +-- is no occurrence 'Nothing' is returned. +delete1 :: Eq a => a -> [a] -> Maybe [a] +delete1 x (y:ys) + | x == y = Just ys + | otherwise = fmap (y:) (delete1 x ys) +delete1 _ [] = Nothing + +-- | 'index' returns the element at the given 0-based index and returns +-- 'Nothing' on failure. +index :: Int -> [a] -> Maybe a +index 0 (x:_) = Just x +index n (_:xs) | n > 0 = index (n-1) xs +index _ _ = Nothing + +-- | Extract an element from a list by index returning that element +-- and the remaining list. +select :: Int -> [a] -> (a,[a]) +select _ [] = error "select: index too large" +select 0 (x:xs) = (x,xs) +select n (x:xs) = (y,x:ys) + where + (y,ys) = select (n-1) xs + +-- | Drop last element of list if there is an element to drop. +init' :: [a] -> [a] +init' [] = [] +init' xs = init xs + +------------------------------------------------------------------------------- +-- Other utilities ------------------------------------------------------------ +------------------------------------------------------------------------------- + +-- | 'chooseTwo' returns all combinations of two elements. +chooseTwo :: [a] -> [(a,a)] +chooseTwo xs = [ (a,b) | (a:as) <- tails xs + , b <- as + ] + +-- | 'seconds' converts seconds to microseconds for use in 'threadDelay'. +seconds :: Int -> Int +seconds x = 1000000 * x + +------------------------------------------------------------------------------- +-- List shuffling utilities --------------------------------------------------- +------------------------------------------------------------------------------- + +-- | 'shuffleIO' calls shuffle using a generator from 'newStdGen'. +shuffleIO :: [a] -> IO [a] +shuffleIO xs = fmap (fst . shuffle xs) newStdGen + +-- | 'shuffle' shuffles the elements of a list using the given random generator. +shuffle :: RandomGen g => [a] -> g -> ([a], g) +shuffle xs = shuffle' (length xs) xs + +shuffle' :: RandomGen g => Int -> [a] -> g -> ([a], g) +shuffle' _ [] g = ([], g) +shuffle' n xs g = (x:xs'', g'') + where + n' = n - 1 + (i, g') = randomR (0,n') g + (x, xs') = select i xs + (xs'', g'') = shuffle' n' xs' g' + +------------------------------------------------------------------------------- +-- Text manipulation utilities ------------------------------------------------ +------------------------------------------------------------------------------- + +-- | 'centerText' centers the given string in a field of @width characters. +centerText :: Int -> String -> String +centerText width xs = replicate ((width - length xs) `div` 2 ) ' ' ++ xs + ++ replicate ((width - length xs + 1) `div` 2 ) ' ' +-- | 'centerText' right-aligns the given string in a field of @width characters. +leftPadText :: Int -> String -> String +leftPadText width xs = replicate (width - length xs) ' ' ++ xs + +-- | 'centerText' left-aligns the given string in a field of @width characters. +rightPadText :: Int -> String -> String +rightPadText width xs = xs ++ replicate (width - length xs) ' ' diff --git a/src/SetGame.hs b/src/SetGame.hs new file mode 100644 --- /dev/null +++ b/src/SetGame.hs @@ -0,0 +1,352 @@ +module SetGame (gameMain) where + +import Control.Concurrent (threadDelay) +import Data.List (delete) +import Data.Foldable (traverse_) +import Graphics.Vty as Vty +import System.Random (newStdGen, StdGen) + +import Set.Ascii (cardLines) +import Set.Card (Card, Color(Red,Purple,Green)) +import Set.Game +import Set.Utils hiding (select) + +gameMain :: Vty.Config -> IO () +gameMain config = do + vty <- mkVty config + game <- newGame + g <- newStdGen + run vty game + $ setGame game + $ newInterface g + shutdown vty + +-- | 'run' is the main event-loop for the game. It alternates +-- reading user input and drawing the interface. +run :: Vty -> Game -> Interface -> IO () +run vty game s + | emptyGame game = return () + | otherwise = do + s' <- printGame vty s + + cmd <- handleInput vty + let simple f = run vty game (f s') + case cmd of + Deal -> traverse_ (\(g,i) -> run vty g i) (checkNoSets game s') + Delete -> simple $ clearSelection . clearMessage + Hint -> simple $ giveHint game + Move dir -> simple $ moveFocus dir + Quit -> return () + Redraw -> refresh vty >> run vty game s + Select -> traverse_ (\(g,i) -> run vty g i) (select game s') + +-- | 'select' performs an event on the interface based on the currently +-- focused control. +select :: Game -> Interface -> Maybe (Game, Interface) +select game s = case iControl s of + CardButton i -> case index i (iTableau s) of + Just t | isSelected t s -> Just (game, updateSelection (delete t) + . clearMessage + $ s) + | otherwise -> addCard t game s + Nothing -> Just (game, setControl (CardButton 0) + $ s) + +-- | 'addCard' attempts to add a new card to the selection and handles +-- checking for a valid set when the selection becomes full. +addCard :: Card -> Game -> Interface -> Maybe (Game, Interface) +addCard card0 game s = case iSelection s of + (_:_:_:_) -> Just (game, setMessage "Selection full" s) + [card1, card2] -> checkSet card0 card1 card2 game . appendSelection card0 + . clearMessage + $ s + _ -> Just (game, appendSelection card0 + . clearMessage + $ s) + +-- | 'setGame' updates the 'Interface' based on the current 'Game' state. +setGame :: Game -> Interface -> Interface +setGame game = setTableau (tableau game) + . setRemaining (deckSize game) + +moveFocus :: Direction -> Interface -> Interface +moveFocus dir s = setControl control s + where + control = case iControl s of + CardButton i -> moveFocusCardButton dir i (length (iTableau s)) + +moveFocusCardButton :: Direction -> Int -> Int -> CurrentControl +moveFocusCardButton dir i n = CardButton i1 + where + (row,col) = i `divMod` cols + + (row1, col1) = case dir of + GoUp -> (row - 1, col) + GoDown -> (row + 1, col) + GoLeft -> (row, col - 1) + GoRight -> (row, col + 1) + + i1 = case dir of + _ | toI (row1, col1) < n + -> toI (row1, col1) + GoUp -> toI (-2, col1) + GoDown -> toI (0, col1) + GoLeft -> toI (row1, n-1) + GoRight -> toI (row1, 0) + + toI (r,c) = r `mod` rows * cols + c `mod` cols + + rows = (n + cols - 1) `div` cols + cols = tableauWidth + +printGame :: Vty -> Interface -> IO Interface +printGame vty s = do + update vty $ makePicture + $ interfaceImage s + case iTimer s of + Nothing -> return s + Just (delay, s') -> do + threadDelay delay + printGame vty s' + +-- | 'giveHint' checks for a hint in the current game and alters the +-- selection if a hint is found. +giveHint :: Game -> Interface -> Interface +giveHint game s = incHintCounter . setGen g . f $ s + where + f = case mbHint of + Just a -> setMessage hintmsg . setSelection [a] + Nothing -> setMessage dealmsg + + (mbHint, g) = hint (iStdGen s) game + + hintmsg = "There is a set using this card." + dealmsg = "No sets in this tableau, deal more cards." + +-- | 'checkSet' will extract the chosen set from the tableau and check it +-- for validity. If a valid set is removed from the tableau the tableau +-- will be refilled up to 12 cards. +checkSet :: Card -> Card -> Card -> Game -> Interface + -> Maybe (Game, Interface) +checkSet a b c game s = Just $ case considerSet a b c game of + Nothing -> (game, setMessage "Not a set!" + . delayedUpdate (seconds 1 `div` 4) + ( setMessage "Not a set.") + $ s) + + Just game' -> (game', delayedUpdate (seconds 1) + ( setGame game' + . clearSelection + . setMessage "Good job.") + . setMessage "Good job!" + $ s) + +-- | 'checkNoSets' verifies that there are no sets in the current tableau +-- and deals additional cards to the tableau in that case. +checkNoSets :: Game -> Interface -> Maybe (Game, Interface) +checkNoSets game s = case extraCards game of + Right game' -> Just (game', setGame game' + . incDealCounter + . setMessage "Dealing more cards." + $ s) + Left 0 -> Just (game , setMessage "Game over, all sets found." s) + Left sets -> Just (game , incBadDealCounter + . setMessage msg + $ s) + where + msg = "Oops, " ++ show sets ++ " sets in tableau. Keep looking." + +------------------------------------------------------------------------------- +-- Interface manipulation functions ------------------------------------------- +------------------------------------------------------------------------------- + +data Interface = IS + { iControl :: CurrentControl + , iSelection :: [Card] + , iMessage :: String + , iDealCounter :: Integer + , iBadDealCounter :: Integer + , iHintCounter :: Integer + , iStdGen :: StdGen + , iTimer :: Maybe (Int, Interface) + , iTableau :: [Card] + , iRemaining :: Int + } + +newInterface :: StdGen -> Interface +newInterface g = IS + { iControl = CardButton 0 + , iSelection = [] + , iMessage = "" + , iDealCounter = 0 + , iBadDealCounter = 0 + , iHintCounter = 0 + , iStdGen = g + , iTimer = Nothing + , iTableau = [] + , iRemaining = 0 + } + +data CurrentControl = CardButton Int + deriving (Eq) + +setRemaining :: Int -> Interface -> Interface +setRemaining n s = s { iRemaining = n } + +setTableau :: [Card] -> Interface -> Interface +setTableau xs s = s { iTableau = xs } + +setTimer :: Int -> Interface -> Interface -> Interface +setTimer delay s' s = s { iTimer = Just (delay, s') } + +delayedUpdate :: Int -> (Interface -> Interface) + -> Interface -> Interface +delayedUpdate delay f s = setTimer delay (f s) s + +incHintCounter :: Interface -> Interface +incHintCounter i = i { iHintCounter = iHintCounter i + 1 } + +incDealCounter :: Interface -> Interface +incDealCounter i = i { iDealCounter = iDealCounter i + 1 } + +incBadDealCounter :: Interface -> Interface +incBadDealCounter i = i { iBadDealCounter = iBadDealCounter i + 1 } + +setControl :: CurrentControl -> Interface -> Interface +setControl x i = i { iControl = x } + +clearMessage :: Interface -> Interface +clearMessage = setMessage "" + +setMessage :: String -> Interface -> Interface +setMessage msg i = i { iMessage = msg } + +setSelection :: [Card] -> Interface -> Interface +setSelection xs i = i { iSelection = xs } + +updateSelection :: ([Card] -> [Card]) -> Interface -> Interface +updateSelection f i = setSelection (f (iSelection i)) i + +appendSelection :: Card -> Interface -> Interface +appendSelection card = updateSelection (++ [card]) + +clearSelection :: Interface -> Interface +clearSelection = updateSelection (const []) + +isSelected :: Card -> Interface -> Bool +isSelected x i = x `elem` iSelection i + +setGen :: StdGen -> Interface -> Interface +setGen g i = i { iStdGen = g } + +------------------------------------------------------------------------------- +-- Input to event mapping ----------------------------------------------------- +------------------------------------------------------------------------------- + +data Command = Move Direction | Select | Quit | Deal | Delete | Hint | Redraw +data Direction = GoUp | GoDown | GoLeft | GoRight + +handleInput :: Vty -> IO Command +handleInput vty = do + ev <- nextEvent vty + case ev of + EvKey KBS [] -> return Delete + EvKey KUp [] -> return (Move GoUp) + EvKey KDown [] -> return (Move GoDown) + EvKey KLeft [] -> return (Move GoLeft) + EvKey KRight [] -> return (Move GoRight) + EvKey KEnter [] -> return Select + EvKey (KChar 'd') [] -> return Deal + EvKey (KChar 'h') [] -> return Hint + EvKey (KChar 'q') [] -> return Quit + EvKey (KChar 'l') [MCtrl] -> return Redraw + _ -> handleInput vty + +------------------------------------------------------------------------------- +-- Interface rendering functions ---------------------------------------------- +------------------------------------------------------------------------------- + +titleString :: String +titleString = "The game of Set" + +helpString :: String +helpString = "(D)eal, (H)int, (Q)uit, Arrows move, Return selects,\ + \ Backspace clears" + +interfaceImage :: Interface -> Image +interfaceImage s = + boldString (centerText 72 titleString) + <-> + plainString helpString + <-> + tableauImage s + <-> + plainString "Cards remaining in deck: " + <|> boldString (leftPadText 2 (show (iRemaining s))) + <|> plainString " [" + <|> boldString (rightPadText 38 (iMessage s)) + <|> plainString "]" + <-> + plainString "Deal count: " + <|> boldString (show (iDealCounter s)) + <|> plainString "/" + <|> boldString (show (iDealCounter s + iBadDealCounter s)) + <|> plainString " Hints used: " + <|> boldString (show (iHintCounter s)) + +tableauImage :: Interface -> Image +tableauImage s + | null (iTableau s) = boldString "No more cards!" + <-> plainString " " + + | otherwise = vertCat + $ map cardRowImage + $ groups tableauWidth + $ zipWith testFocus [0..] + $ iTableau s + where + testFocus i c = (iControl s == CardButton i, isSelected c s, c) + +cardRowImage :: [(Bool, Bool, Card)] -> Image +cardRowImage = horizCat . map cardImage + +-- | 'cardImage' renders a 'Card' based on its current selection and focus +-- state. +cardImage :: (Bool, Bool, Card) -> Image +cardImage (focused,selected,c) = leftSide <|> body <|> rightSide <-> bottom + where + body = vertCat (map (Vty.string cardAttr) xs) + leftSide = charFill fillAttr leftFiller 1 (4 :: Int) + rightSide = charFill fillAttr rightFiller 1 (4 :: Int) + bottom = charFill defAttr ' ' 18 (1 :: Int) + + (cardColor, xs) = cardLines c + + vtyColor = case cardColor of + Red -> red + Purple -> cyan + Green -> green + + (fillAttr, leftFiller, rightFiller) + | focused = (defAttr`withForeColor`white`withBackColor`yellow, + '▶', '◀') + | otherwise = (defAttr, ' ', ' ') + + cardAttr + | selected = baseCardAttr `withStyle` reverseVideo + | otherwise = baseCardAttr + + baseCardAttr = defAttr `withForeColor` vtyColor `withBackColor` black + +makePicture :: Image -> Picture +makePicture img = (picForImage img) + { picBackground = Background ' ' defAttr } + +plainString :: String -> Image +plainString = string defAttr + +boldString :: String -> Image +boldString = string (defAttr `withStyle` bold) + +tableauWidth :: Int +tableauWidth = 4