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 :: 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 :: 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 :: 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 :: 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 :: 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 :: 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 :: 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."
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 }
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
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 :: (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