I tried to write Candy Land game in Haskell as a step to work on something bigger than those toy programs/functions I used to write. I wrote myself a python version first, with a functional mindset before I started working on the actual Haskell version, and it was a breeze and easy and I got it to work in a little bit more than one hour. After that I started writing my Haskell version and it was not pleasant at all. The code I am posting here took me multiple coding sessions and I don't even have all the features I had in my python version.
This is the current state of the game:
- it doesn't support interactive play.
- it doesn't shuffle the cards yet. I googled shuffling in Haskell before I set out to write my own version but I didn't find any library that's simple and concise, except for System.Random.Shuffle but I haven't figured out how to install it. (I am using Haskell platform)
- Since the game is deterministic once the deck is shuffled, the game itself right now is only a simulation of the play rather an interactive play.
I want to use this as an example to seek advises in building applications in Haskell.
- What is the best way to model the game? I used
StateT
overReaderT
with all mutable states inStateT
, which is pretty much an equivalent of an imperative programming langagueclass
. Some part of gets bloated and clumsy, for exampleturn
function. - I tried to model all data using types, but I am not sure if I modeled things efficiently.
Please feel free to share your opinion/suggestion/critism on any part of the program. I appreciate your feedback.
import qualified Control.Monad.Trans.Reader as R
import qualified Control.Monad.Trans.State as S
import Control.Monad.Trans.Class (lift)
import qualified Data.Map as M
import qualified Data.Array as A
import qualified System.Random as Rand
data Color
= Red
| Purple
| Blue
| Yellow
| Orange
| Green
deriving (Show, Eq, Ord)
colors = [Red, Purple, Blue, Yellow, Orange, Green]
data SpecialFood
= Cupcake
| Icecream
| Gummystar
| Gingerbreadman
| Lollipop
| Popsicle
| Chocolate
deriving (Show, Eq, Ord)
foods =
[ Cupcake, Icecream, Gummystar
, Gingerbreadman, Lollipop, Popsicle, Chocolate
]
data Path
= PPeppermint
| PGummybear
deriving Show
data Tile
= TStart
| TRegular Color
| TPassStart Color Path
| TPassEnd Color Path
| TLicorice Color
| TSpecial SpecialFood
| TRainbow
deriving Show
tileHasColor :: Color -> Tile -> Bool
tileHasColor _ TStart = False
tileHasColor c1 (TRegular c2) = c1 == c2
tileHasColor c1 (TPassStart c2 _) = c1 == c2
tileHasColor c1 (TPassEnd c2 _) = c1 == c2
tileHasColor c1 (TLicorice c2) = c1 == c2
tileHasColor _ (TSpecial _) = False
tileHasColor _ TRainbow = True
tileIsFood :: SpecialFood -> Tile -> Bool
tileIsFood food (TSpecial fd) = food == fd
tileIsFood food _ = False
data Player
= PRed
| PBlue
| PGreen
| PYellow
deriving (Show, Eq, Ord)
data Card
= CSingle Color
| CDouble Color
| CSpecial SpecialFood
deriving Show
data Board
= Board
{ allTiles :: A.Array Int Tile
, colorTiles :: M.Map Color [Int]
, specialTiles :: M.Map SpecialFood Int
} deriving Show
lastTile :: Board -> Int
lastTile board = snd $ A.bounds $ allTiles board
mkTileArray :: [Tile] -> A.Array Int Tile
mkTileArray ts = A.array (0, len-1) $ zip [0..] ts
where len = length ts
mkColorTileMap :: [Tile] -> M.Map Color [Int]
mkColorTileMap ts = M.fromList $ zip colors $ map mkColorPosList colors
where
mkColorPosList c = [ i | (i, t) <- zip [0..] ts, tileHasColor c t]
mkSpecialTileMap :: [Tile] -> M.Map SpecialFood Int
mkSpecialTileMap ts = M.fromList foodPosList
where
foodPosList =
[ (fd, head pos)
| fd <- foods
, let pos = [ i | (i, t) <- zip [0..] ts, tileIsFood fd t]
, length pos == 1
]
mkBoard :: [Tile] -> Board
mkBoard ts = Board arr colorMap foodMap
where
arr = mkTileArray ts
colorMap = mkColorTileMap ts
foodMap = mkSpecialTileMap ts
type GameMove = Int -> Int
moveBeyond pos = filter (>pos)
move :: Monad m => Card -> R.ReaderT Board m GameMove
move (CSingle c) = do
board <- R.ask
return $ \pos ->
if pos == lastTile board
then pos
else
case fmap (moveBeyond pos) $ M.lookup c (colorTiles board) of
Nothing -> lastTile board -- or pos, depending on the moving rule
Just [] -> lastTile board
Just (x:_) -> x
move (CDouble c) = do
movef <- move (CSingle c)
return $ \pos -> let nextPos = movef pos in movef nextPos
move (CSpecial food) = do
board <- R.ask
return $ \pos ->
if pos == lastTile board
then pos
else
case M.lookup food (specialTiles board) of
Nothing -> pos
Just x -> x
-- I did not take advantage of the certain patterns
-- in the Candy Land game board to create the tiles list.
tiles :: [Tile]
tiles =
[ TStart
, TRegular Red
, TRegular Purple
, TRegular Yellow
, TPassStart Blue PPeppermint
-- large number of code was omitted here to save space.
, TRegular Green
, TRainbow
]
gameBoard = mkBoard tiles
type Deck = [Card]
standardDeck = singleCards ++ doubleCards1 ++ doubleCards2 ++ specialCards
where
singleCards = take 36 $ cycle $ map CSingle colors
doubleCards1 = take 16 $ cycle $ map CDouble [Red, Purple, Yellow, Blue]
doubleCards2 = take 12 $ cycle $ map CDouble [Orange, Green]
specialCards = map CSpecial foods
shuffle :: Deck -> Deck
shuffle = id -- a placeholder function
data PlayerProgress
= PlayerProgress
{ pPosition :: Int
, pWaits :: Int
} deriving Show
initPlayer :: PlayerProgress
initPlayer = PlayerProgress { pPosition=0, pWaits=0 }
data Game
= Game
{ gProgress :: M.Map Player PlayerProgress
, gState :: GameState
, gDeck :: Deck
, gTurns :: [Player]
} deriving Show
data GameState
= GContinue
| GWonBy Player
| GTerminated String
deriving Show
terminate :: String -> S.StateT Game (R.ReaderT Board IO) ()
terminate err = S.get >>= \g -> S.put $ g { gState=GTerminated err }
winner :: Player -> S.StateT Game (R.ReaderT Board IO) ()
winner p = S.get >>= \g -> S.put $ g { gState=GWonBy p }
drawCard :: S.StateT Game (R.ReaderT Board IO) (Maybe Card)
drawCard = do
g <- S.get
case gDeck g of
[] -> return Nothing
(c:cs) -> do
S.put $ g { gDeck=cs }
return (Just c)
logGame :: String -> S.StateT Game (R.ReaderT Board IO) ()
logGame s = lift $ lift $ putStrLn s
turn :: S.StateT Game (R.ReaderT Board IO) ()
turn = do
g <- S.get
case gState g of
GContinue -> case gDeck g of
[] -> terminate "out of cards!"
(c:cards) -> case gTurns g of
[] -> terminate "out of players! huh?"
(p:players) -> case M.lookup p (gProgress g) of
Nothing -> terminate "Who is this? How did the game even started?"
(Just (PlayerProgress pos wait)) -> if wait > 0
then
do
logGame $ (show p) ++ " has to wait!"
S.put $ g
{ gProgress=M.insert p (PlayerProgress pos (wait-1)) (gProgress g)
, gDeck=cards
, gTurns=players
}
else
do
mf <- lift $ move c
board <- lift $ R.ask
let pos' = mf pos
logGame $ (show p) ++ " moves from " ++ show pos ++ " to " ++ show pos'
S.put $ g
{ gProgress=M.insert p (PlayerProgress pos' 0) (gProgress g)
, gDeck=cards
, gTurns=players
}
if pos' == lastTile board
then winner p
else return ()
-- if the game state is not continue, do nothing
_ -> return ()
startGame :: [Player] -> Deck -> Game
startGame players deck =
Game { gProgress=M.fromList $ zip players $ map (const initPlayer) players
, gState=GContinue
, gDeck=deck
, gTurns=cycle players
}
play :: Game -> (R.ReaderT Board IO) ()
play g = do
(_, g') <- S.runStateT turn g
case gState g' of
GTerminated s -> lift $ putStrLn s
GWonBy winner -> lift $ putStrLn $ "We got a winner!" ++ show winner
GContinue -> play g'
playCandyLand :: Board -> Deck -> [Player] -> IO ()
playCandyLand _ _ [] = putStrLn "cannot play without any players"
playCandyLand board deck players = do
putStrLn "Starting Candy Land..."
let
initGame = startGame players deck
R.runReaderT (play initGame) board
After the program is loaded in GHCi, you can run the following to show the simulated result:
playCandyLand (mkBoard tiles) standardDeck [PRed, PBlue]