Haskell craps

A Haskell neophyte at $WORK talked about writing a craps simulator as a learning exercise. The rules, limiting consideration to pass-line bets, are complex enough to make it an interesting kata. Designing a processor for the game's complex prop bets, on the other hand, might make a good interview discussion.

Front matter:

> module Craps ( games
>              , rolls
>              , runTests
>              , Game
>              , Roll
>              ) where

> import Data.List ((\\))
> import System.Random (randomRs,Random,RandomGen)
> import Test.QuickCheck (choose,forAll,oneof,sized,Arbitrary(..),Gen,Property)
> import Test.QuickCheck.Batch (defOpt,run,TestOptions(..))
> import qualified Test.QuickCheck.Batch as QC

Craps is played with two dice:

> data Roll = Roll Int Int
>   deriving (Show)

At the pass line, the bettor can win two ways and lose two ways. With no point, rolls of 7 or 11 win (“natural”), and rolls of 2, 3, or 12 lose (“craps”). Any other roll becomes the point, and the shooter continues until she rolls the point again (“pass” or “win”) or 7 (“seven out”).

> data Game = Natural Roll
>           | Pass [Roll]
>           | CrapOut Roll
>           | SevenOut [Roll]
>   deriving Show

To generate a lazy list of rolls, pass a random-number generator (created, for example, with newStdGen, and use as many as you need. The second case in the definition of go silences a partial-function warning (“Pattern match(es) are non-exhaustive” with ghc), viz. empty and singleton lists. We'll always have at least two elements because randomRs produces an infinite list of bounded random numbers.

> rolls :: RandomGen g => g -> [Roll]
> rolls g = go $ randomRs (1,6) g
>   where
>     go (a:b:xs) = Roll a b : go xs
>     go _ = undefined

Now that we have as many rolls as we want, let's separate them into games. For the trivial case, if you aren't rolling, you aren't playing:

> games :: [Roll] -> [Game]
> games [] = []

Before the shooter establishes a point, we watch for magic numbers:

> games (r:rs) | any (rolled r) [7,11]   = Natural r : games rs
> games (r:rs) | any (rolled r) [2,3,12] = CrapOut r : games rs

Otherwise, whatever the shooter rolled becomes the point. The game ends when the shooter rolls 7 or makes the point.

> games (pt:rs) = go rest : games rs'
>   where

This inner go is also partial. If the list of rolls is finite, every point must be resolved, either pass or seven out. Note that the roll that ends the round will be the first element of the snd of the pair we get from break, so we use pattern matching to grab it and tack it on the end of the round.

>     go xs@(final:_) = outcome $ reverse xs
>       where outcome | final `rolled` 7 = SevenOut
>                     | otherwise        = Pass
>     go _ = undefined
>     (ensuing,x:rs') = break (\r -> r `rolled` 7 || r `eq` pt) rs
>     rest = x : reverse (pt : ensuing)

rolled is a simple helper for testing whether the shooter rolled a particular number, e.g., r `rolled` 7 as seen above.

> rolled :: Roll -> Int -> Bool
> rolled r = (== total r)

Two rolls are equal if they have the same total (yes, Lispers, I should have spelled it equal):

> eq :: Roll -> Roll -> Bool
> a `eq` b = total a == total b

> total :: Roll -> Int
> total (Roll a b) = a + b

Everything below is for testing with classic QuickCheck. Earlier iterations used this Arbitrary instance, but now it's window dressing.

> instance Arbitrary Roll where
>   arbitrary = do a <- choose (1,6)
>                  b <- choose (1,6)
>                  return $ Roll a b
>   coarbitrary = undefined

vectorOf turns a generator's crank a few times. We'll use this to generate multiple non-point rolls, for example. Note the use of sequence to allow pseudo-random number generator state to update between rolls.

> vectorOf :: Int -> Gen a -> Gen [a]
> vectorOf n gs = sequence [ gs | _ <- [1..n] ]

After the come-out roll establishes a point, the difference between a win and a loss is whether the game's last roll is 7 or the point. If pass is true, we generate a winner, otherwise a loser.

> afterComeOut :: Bool -> Int -> Gen [Roll]
> afterComeOut pass n = do
>   n' <- choose (1,n)
>   pt <- oneof points
>   rs <- vectorOf n' (oneof $ noPoint pt)
>   let rollpt = mkRoll pt
>       final = if pass then rollpt else seven
>   return $ rollpt : rs ++ [final]
>   where
>     noPoint p = mayroll $ except [7,p]
>     points = map return $ except [2,3,7,11,12]
>     seven = Roll 3 4
>     except = ([2..12] \\)

Our testing strategy will be to generate games of all four types and then make sure they're correctly recognized. For example, the test for passes will use expect isPass ...

> expect :: (Game -> Bool) -> [Roll] -> Bool
> expect what = all what . games

mayroll creates a list of generators ultimately for use with oneof, e.g., mayroll [2,3,12] in the crap-out property.

> mayroll :: [Int] -> [Gen Roll]
> mayroll = map (return . mkRoll)

QuickCheck opens the throttle on the size of testcases with sized, and many connects to this hook.

> many :: [Gen Roll] -> Int -> Gen [Roll]
> many what n = do
>   n' <- choose (1,n)
>   vectorOf n' (oneof what)

mkRoll starts from a roll total and backs into the individual components. An obvious improvement would be adding choices other than 1 and 6.

> mkRoll :: Int -> Roll
> mkRoll t = Roll less (t - less)
>   where less | t <= 6    = 1
>              | otherwise = 6

Now we get to the properties that use QuickCheck's forAll to generate random test data of the appropriate class and check for the expected results.

> prop_crapOut :: Property
> prop_crapOut =
>   forAll allCraps $ expect isCrapOut
>   where isCrapOut (CrapOut _) = True
>         isCrapOut _ = False
>         allCraps = sized $ many craps
>         craps = mayroll [2,3,12]

> prop_natural :: Property
> prop_natural =
>   forAll allNats $ expect isNat
>   where isNat (Natural _) = True
>         isNat _ = False
>         allNats = sized $ many nats
>         nats = mayroll [7,11]

> prop_sevenOut :: Property
> prop_sevenOut =
>   forAll allSevenOuts $ expect is7Out
>   where is7Out (SevenOut _) = True
>         is7Out _ = False
>         allSevenOuts = sized $ afterComeOut False

> prop_pass :: Property
> prop_pass =
>   forAll allPasses $ expect isPass
>   where isPass (Pass _) = True
>         isPass _ = False
>         allPasses = sized $ afterComeOut True

Finally, a simple test driver so we don't have to check them one-by-one:

> runTests :: IO ()
> runTests = do
>   let opts = defOpt { no_of_tests = 200 }
>   QC.runTests "crap out"  opts [ run prop_crapOut ]
>   QC.runTests "natural"   opts [ run prop_natural ]
>   QC.runTests "seven out" opts [ run prop_sevenOut ]
>   QC.runTests "pass"      opts [ run prop_pass ]