Take the 2-minute tour ×
Code Review Stack Exchange is a question and answer site for peer programmer code reviews. It's 100% free, no registration required.

This is my first attempt at creating a game in Haskell, and I would greatly appreciate some feedback.

Here is Main.hs:

module Main where

import Deck

import Data.List
import System.Random
import Control.Monad.State

-- |'main' is the entry point for the program. This function will bind a
-- random number generator and pass it into a new 'Game' state. Finally, it will
-- evaluate the 'gameLoop'.
main :: IO ()
main = do
  stdGen <- getStdGen
  evalStateT gameLoop $ mkGame stdGen hitUnlessTwentyOne

-- |The 'Game' data type contains all of the state information about a
-- blackjack game.
data Game = Game
  { deck :: Deck
  , playerHand :: [Card]
  , playerAction :: Action
  , dealerHand :: [Card]
  , dealerAction :: Action
  , dealerStrategy :: Strategy }

-- |The 'GameS' type represents the current state of the 'Game'.
type GameS a = StateT Game a

-- |The 'Action' data type represents the possible actions a player can take.
data Action = Hit | Stay deriving (Eq, Read)

-- |The 'Strategy' type is the signature of all AI functions used by the dealer.
type Strategy = [Card] -> GameS IO (Action)

-- |'gameLoop' will repeatedly evaluate an iteration of the game. It updates the
-- game state based on the actions of the player and the dealer, and then
-- determines if the game is over.
gameLoop :: GameS IO ()
gameLoop = do
  curr <- get
  when ((playerAction curr) == Hit) handlePlayer
  when ((dealerAction curr) == Hit) handleDealer
  gameOver <- isGameOver
  when gameOver handleGameOver
  when (not gameOver) gameLoop

handlePlayer :: GameS IO ()
handlePlayer = do
  curr <- get
  input <- liftIO $ do
    let playerH = playerHand curr
    putStrLn $ "Your hand: " ++ (show playerH)
    putStrLn $ "Dealer's hand: " ++ (showDealer $ dealerHand curr)
    putStrLn "What do you want to do? (Hit/Stay)"
    input <- getLine
    return input

  let action = read input :: Action
  when (action == Hit) $ do
    let (card, deck') = runState draw $ deck curr
    put curr { deck = deck'
             , playerHand = card : playerHand curr }
    new <- get
    let playerH = playerHand new
    liftIO . putStrLn $ "Your hand: " ++ (showDealer playerH)

  when (action == Stay) $ do
    put curr { playerAction = Stay }

handleDealer :: GameS IO ()
handleDealer = do
  curr <- get
  action <- dealerStrategy curr $ dealerHand curr
  when (action == Hit) $ do
    let (card, deck') = runState draw $ deck curr
    put curr { deck = deck'
             , dealerHand = card : dealerHand curr }
    new <- get
    let dealerH = dealerHand new
    liftIO . putStrLn $ "The dealer hit."
    liftIO . putStrLn $ "Dealer's hand: " ++ (showDealer dealerH)

  when (action == Stay) $ do
    put curr { dealerAction = Stay }
    liftIO . putStrLn $ "The dealer stayed."

isGameOver :: GameS IO Bool
isGameOver = do
  curr <- get
  let playerA    = playerAction curr
      dealerA    = dealerAction curr
      playerH    = playerHand curr
      dealerH    = dealerHand curr
      bothStayed = (playerA == Stay && dealerA == Stay)
      playerBust = bust playerH
      dealerBust = bust dealerH
      gameOver = bothStayed || playerBust || dealerBust

  when playerBust $ liftIO . putStrLn $ "You busted out!"
  when dealerBust $ liftIO . putStrLn $ "The dealer busted out!"

  return gameOver

handleGameOver :: GameS IO ()
handleGameOver = do
  curr <- get
  let playerH = playerHand curr
      dealerH = dealerHand curr
      winner  = won playerH dealerH
  liftIO . putStrLn $ "Your hand: " ++ (show playerH) ++ ", " ++ (show (possiblePoints playerH))
  liftIO . putStrLn $ "Dealer's hand: " ++ (show dealerH) ++ ", " ++ (show (possiblePoints dealerH))
  when winner $ liftIO . putStrLn $ "You win!"
  when (not winner) $ liftIO . putStrLn $ "You lose..."

won :: [Card] -> [Card] -> Bool
won playerH dealerH = playerScore > dealerScore
  where playerScore = score playerH
        dealerScore = score dealerH

score :: [Card] -> Int
score h 
  | bust h    = 0
  | otherwise = best h

bust :: [Card] -> Bool
bust = and . map ((<) 21) . possiblePoints

twentyOne :: [Card] -> Bool
twentyOne = any ((==) 21) . possiblePoints

best :: [Card] -> Int
best = maximum . filter ((>=) 21) . possiblePoints

showDealer :: [Card] -> String
showDealer hand = "[" ++ (show $ head hand) ++ "," ++ (intersperse ',' hidden) ++ "]"
  where n = length $ tail hand
        hidden = replicate n '?'

mkGame :: StdGen -> Strategy -> Game
mkGame g strat = Game
  { deck = d' 
  , playerHand = playerH
  , playerAction = Hit
  , dealerHand = dealerH
  , dealerAction = Hit
  , dealerStrategy = strat }
  where d = execState shuffle $ mkDeck g
        ((playerH, dealerH), d') = runState deal $ d

deal :: DeckS ([Card], [Card])
deal = do
  mine   <- draw
  yours  <- draw
  mine'  <- draw
  yours' <- draw
  let me = [mine, mine']
      you = [yours, yours']
  return (me, you)

hitUnlessTwentyOne :: Strategy
hitUnlessTwentyOne hand
  | twentyOne hand = return Stay
  | otherwise      = return Hit

hitSometimes :: Double -> Strategy
hitSometimes threshold _ = do
  curr <- get
  let deck' = deck curr
      (num, gen') = random $ gen deck'
  put curr { deck = deck' { gen = gen' } }
  if num > threshold
    then return Hit
    else return Stay

Here is Deck.hs:

module Deck 
  ( Card
  , possiblePoints
  , Deck
  , DeckS
  , cards
  , gen
  , mkDeck
  , draw
  , shuffle
  , takeRandomCard
  , takeCardAt ) where

import System.Random
import Control.Monad.State

-- |The 'Card' data type represents the possible playing card ranks.
data Card = Ace
          | Two
          | Three
          | Four
          | Five
          | Six
          | Seven
          | Eight
          | Nine
          | Ten
          | Jack
          | Queen
          | King
          deriving (Enum, Show)

-- |'possiblePoints' calculates all possible scores for a given hand.
possiblePoints :: [Card] -> [Int]
possiblePoints = go [0]
  where go n []           = n
        go ns (Ace:rest)   = go (map ((+) 1) ns ++ map ((+) 11) ns) rest
        go ns (Two:rest)   = go (map ((+) 2) ns) rest
        go ns (Three:rest) = go (map ((+) 3) ns) rest
        go ns (Four:rest)  = go (map ((+) 4) ns) rest
        go ns (Five:rest)  = go (map ((+) 5) ns) rest
        go ns (Six:rest)   = go (map ((+) 6) ns) rest
        go ns (Seven:rest) = go (map ((+) 7) ns) rest
        go ns (Eight:rest) = go (map ((+) 8) ns) rest
        go ns (Nine:rest)  = go (map ((+) 9) ns) rest
        go ns (Ten:rest)   = go (map ((+) 10) ns) rest
        go ns (Jack:rest)  = go (map ((+) 10) ns) rest
        go ns (Queen:rest) = go (map ((+) 10) ns) rest
        go ns (King:rest)  = go (map ((+) 10) ns) rest

-- |The 'Deck' data type represents a deck of cards that can be shuffled.
data Deck = Deck
  { cards :: [Card]
  , gen :: StdGen }
  deriving (Show)

-- |'mkDeck' will construct a 52-card deck.
mkDeck :: StdGen -> Deck
mkDeck g = 
  Deck { cards = [ card | card <- [Ace ..], _ <- [1..4] :: [Int] ]
       , gen = g }

-- |The 'DeckS' is the current state of the 'Deck'.
type DeckS a = State Deck a

-- |'draw' will take one card off the top of the deck.
draw :: DeckS Card
draw = takeCardAt 0

-- |'shuffle' takes a 52-card deck and randomly shuffles its elements.
shuffle :: DeckS ()
shuffle = do
  curr <- get
  shuffled <- replicateM 52 takeRandomCard
  put curr { cards = shuffled }

-- |'takeRandomCard' will pick one random card from the deck and remove it.
-- It is a helper-function used by 'shuffle'.
takeRandomCard :: DeckS Card
takeRandomCard = do
  curr <- get
  let n = length $ cards curr
      (i, gen') = randomR (0, n) $ gen curr
  card <- takeCardAt i
  put curr { gen = gen' }
  return card

-- |'takeCardAt' will pick the card at the given index and remove it from the
-- deck.
takeCardAt :: Int -> DeckS Card
takeCardAt i = do
  curr <- get
  let (cards', cards'') = splitAt (i + 1) $ cards curr
      card              = last cards'
      newCards          = init cards' ++ cards''
  put curr { cards = newCards }
  return card
share|improve this question

2 Answers 2

up vote 6 down vote accepted

Warning : I never played this game, so I might be wrong.

Syntactic nitpicking

There is quite a bit of syntactic noise, that you can catch by using hlint. For example :

input <- getLine
return input

should be

getLine

There is however a couple instances that are not properly flagged :

when winner $ liftIO . putStrLn $ "You win!"
when (not winner) $ liftIO . putStrLn $ "You lose..."

I believe the intent here is not properly encoded, as you might modify one of the two lines, and have both branches (or none) executed. I think that the following makes it more obvious :

liftIO . putStrLn $ if winner
                       then "You win"
                       else "You lose"

And as the whole section is lifted, it could be replaced by something like :

handleGameOver :: GameS IO ()
handleGameOver = get >>= \curr -> liftIO $ do
  let playerH = playerHand curr
      dealerH = dealerHand curr
      winner  = won playerH dealerH
  putStrLn $ "Your hand: " ++ show playerH ++ ", " ++ show (possiblePoints playerH)
  putStrLn $ "Dealer's hand: " ++ show dealerH ++ ", " ++ show (possiblePoints dealerH)
  putStrLn $ if winner then "You win!" else "You lose..."

But those are all minor nitpicks. The main issue, for me, is that the whole design is unnecessarily coupling orthogonal concepts.

Decoupling stuff

There are several concerns that are mixed :

  • Player strategy and its effect are coupled in the handlePlayer and handleDealer functions.
  • The dealer and player are handled as if they were completely distinct, which leads to code duplication. In practice they are following the same rules (I suppose).
  • The dealer strategy is part of the game state, even though it is immutable
  • IO is mixed with the game logic

Here is a quick rewrite of Main.hs (it might be buggy, I just checked it typechecks) :

{-# LANGUAGE GADTs #-}
module Main where

import Deck

import Data.List
import System.Random
import Control.Monad.State
import Control.Monad.Operational
import qualified Data.Map.Strict as M

data PlayerType = Dealer | Player
                deriving (Ord, Eq)

data GameActions a where
    GetAction :: PlayerType -> GameActions Action
    ShowState :: GameActions ()
    Win :: GameActions ()
    Lose :: GameActions ()

type GameS = ProgramT GameActions (State Game)

main :: IO ()
main = do
  stdGen <- getStdGen
  interpretIO M.empty (mkGame stdGen) gameLoop

interpretIO :: M.Map PlayerType (Game -> IO Action) -> Game -> GameS a -> IO a
interpretIO strats s instr = case runState (viewT instr) s of
                          (a, ns) -> evalinstr ns a 
    where
        evalinstr   _ (Return x) = return x 
        evalinstr stt (a :>>= f) = 
            let runC a' = interpretIO strats stt (f a')
    in  case a of
            GetAction pt ->
                let strategy = M.findWithDefault (const (return Stay)) pt strats
                in  strategy stt >>= runC
            ShowState -> putStrLn "show state" >>= runC
            Win -> putStrLn "You win" >>= runC
            Lose -> putStrLn "You lose" >>= runC


data Game = Game
  { deck  :: Deck
  , hands :: M.Map PlayerType [Card]
  }

data Action = Hit | Stay deriving (Eq, Read)

runAction :: PlayerType -> GameS Action
runAction pt = do
    action <- singleton (GetAction pt)
    when (action == Hit) $ do
        curr <- get
        let (card, deck') = runState draw $ deck curr
        put curr { deck = deck'
                 , hands = M.insertWith (++) pt [card] (hands curr)
                 }
    return action

gameLoop :: GameS ()
gameLoop = do
  playerAction <- runAction Player
  dealerAction <- runAction Dealer
  pbust <- isBust Player
  dbust <- isBust Dealer
  let bothStayed = playerAction == Stay && dealerAction == Stay
      gameOver = bothStayed || pbust || dbust
  if gameOver
      then handleGameOver
      else gameLoop

handleGameOver :: GameS ()
handleGameOver = do
    singleton ShowState
    hs <- gets hands
    let playerH = M.findWithDefault [] Player hs
        dealerH = M.findWithDefault [] Dealer hs
    singleton $ if won playerH dealerH then Win else Lose

won :: [Card] -> [Card] -> Bool
won playerH dealerH = playerScore > dealerScore
  where playerScore = score playerH
        dealerScore = score dealerH

score :: [Card] -> Int
score h
  | bust h    = 0
  | otherwise = best h

isBust :: PlayerType -> GameS Bool
isBust pt = gets (check . hands)
    where
        check h = case M.lookup pt h of
                      Just cs -> bust cs
                      Nothing -> True

bust :: [Card] -> Bool
bust = all (21 <) . possiblePoints

twentyOne :: [Card] -> Bool
twentyOne = elem 21 . possiblePoints

best :: [Card] -> Int
best = maximum . filter (21 >=) . possiblePoints

showDealer :: [Card] -> String
showDealer hand = "[" ++ show (head hand) ++ "," ++ intersperse ',' hidden ++ "]"
  where n = length $ tail hand
        hidden = replicate n '?'

mkGame :: StdGen -> Game
mkGame g = Game
  { deck = d'
  , hands = M.fromList [(Player, playerH), (Dealer, dealerH)]
  }
  where d = execState shuffle $ mkDeck g
        ((playerH, dealerH), d') = runState deal d

deal :: DeckS ([Card], [Card])
deal = do
  mine   <- draw
  yours  <- draw
  mine'  <- draw
  yours' <- draw
  let me = [mine, mine']
      you = [yours, yours']
  return (me, you)

It is a lot more complex now :) Here are the main takeaways :

An interpreter

This is a major technique in Haskell : transform an effectful computation into a pure computation that is then interpreted. You can use the free or operational packages for that. You now have the game logic running in the GameS monad, that can run effectful instructions encoded as the GameActions type. Those instructions are then interpreter by the interpretIO function.

You gain several things from that move :

  • All IO is in a single place, instead of being intertwined with game logic
  • You can easily write an interpretPure :: Game -> GameS a -> Identity a function that can be used for unit tests
  • You can also write it in any other monad, for example to have this work as part of a Web application

However, it makes things a bit more complicated to lay out at first ...

All players are handled in the same way

There is now less code duplication (the handlePlayer and handleDealer functions were almost identical), and it would probably be easier to increase the player count.

Pluggable strategies

Now all strategies are pluggable, not just that of the dealer.

Well ...

I basically said "rewrite your whole program in the way I like", and there is definitively a question of taste here with the whole "free monad" or "operational" decoupling. You gain nice effect separation with "magical behavior" that might turn into cargo cult programming ...

There is also the problem that I turned fixed fields (playerHand and dealerHand) into a Map, which might return Nothing.

share|improve this answer

I am not a Haskell programmer but I can't help suggest an improvement for possiblePoints. That much repetition hurt my eyes. :)

-- first factor out the mapping from a card to its value(s)
possibleValues :: Card -> [Int]
possibleValues card
    | card == Ace = [1, 11]
    | card `elem` [Jack,Queen,King] = [10]
    | otherwise = fromEnum card


possiblePoints :: [Card] -> [Int]
possiblePoints hand = nub $ map sum $ mapM possibleValues hand
share|improve this answer
    
Ahhh, that is a very nice solution. Thank you! –  Colin Ray Apr 10 at 17:20

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

Not the answer you're looking for? Browse other questions tagged or ask your own question.