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 ]

Word ladder in Haskell

Another followup to my earlier post about searching for word ladders, this time using Haskell!

This blog post is a Haskell program, written using the "literate comment" convention.

First a bit of front matter. This implementation of the word-ladder search will use the State and list monads.

> module Main where
> import Control.Monad.State
> import Data.Char
> import Data.List (find)
> import Data.Set (Set, member, difference)
> import qualified Data.Set as Set
> import System.Environment (getArgs)
> import System.Exit

The idea is simple: read the dictionary, search for the desired ladder, and show it to the user:

> main :: IO ()
> main = do
>   (start, goal, dict) <- getArgs >>= parse
>   fullDictionary <- readDictionary dict
>   print $ search start goal (trim fullDictionary start)

Remember that getArgs is an action that returns the list of command-line arguments. We bind this action to the following:

>   where parse [start,goal,dict] = return (start,goal,dict)
>         parse [start,goal]      = return (start,goal,"/usr/dict/words")
>         parse _ =
>           putStrLn "Usage: ladder start goal [ dictionary ]" >>
>           exitWith (ExitFailure 1)

Haskell's pattern matching shows that the program takes two or three arguments. The first two are the start and goal words. The optional third argument is the path to a dictionary (one word per line) to use.

We condition the dictionary by eliminating words whose lengths differ from the length of the start word and also converting everything to lowercase.

>         trim :: [String] -> String -> [String]
>         trim words start = filter (sameLength start) (lc words)
>
>         sameLength start = (== length start) . length
>
>         lc = map (map toLower)

The search can fail, so result is of type Maybe [String]. Handling both cases is straightforward:

>         print Nothing = putStrLn "No ladder found."
>         print (Just a) = mapM_ putStrLn a

The dictionary's format is simple, so reading it is a matter of extracting the lines from the file:

> readDictionary :: FilePath -> IO [String]
> readDictionary path = liftM lines $ readFile path

Now for the fun bits. Imagine a graph where nodes are words from the dictionary and where edges are between words that are "one hop' from each other, i.e., words that could be on consecutive "rungs" of a ladder.

Beginning with the start word, the program performs a breadth-first search of this graph. We call the set of words reached in the most recent iteration the "fringe." When the fringe contains the goal word, we're done.

The state monad simulates destructive update in imperative programming languages. (Haskell is purely functional.) Without it, we'd have to explicitly thread the state value through the call chain, but with it, we retrieve and update the state value with get and put as below:

> search start goal words =
>   evalState (loop [[start]]) (Set.fromList $ filter (/=start) words)
>   where
>     loop :: [[String]] -> State (Set String) (Maybe [String])
>     loop [] = return Nothing
>     loop paths = do
>       next <- step paths
>       let newFringe = fringe next
>       words <- get
>       put $ words `difference` newFringe
>       if goal `member` newFringe
>         then return $ Just (winner next)
>         else loop next

The list monad is handy for representing nondeterministic computations. In concept at least, the search carries around a list of lists that has all of the partial results computed so far.

For example, if the start word is dog, the state value on the second iteration might be [["dog", "dig"], ["dog", "fog"], ["dog", "bog"]]. This approach might seems to be a memory pig, but it remains surprisingly frugal.

To proceed to the next iteration of the search, for each partial result (one ladder beginning with the start word) we find the as-yet unseen neighbors of its last element (a member of the current fringe) and replace the current partial result with new ones for each of the neighbors. Again, consider the partial results at the second iteration in the previous paragraph.

>     step :: [[String]] -> State (Set String) [[String]]
>     step paths = do
>       words <- get
>       return $ paths >>= augment words
>
>     augment :: Set String -> [String] -> [[String]]
>     augment words path = [ path ++ [n] | n <- ns ]
>       where ns = Set.elems $ neighbors (last path) words
>     
>     neighbors :: String -> Set String -> Set String
>     neighbors word words = Set.filter (oneHop word) words
>       where oneHop [] [] = False
>             oneHop (x:xs) (y:ys) | x /= y = xs == ys
>                                  | otherwise = oneHop xs ys

As described above, the fringe is the set of words at the ends of the partial ladders computed so far:

>     fringe :: [[String]] -> Set String
>     fringe paths = Set.fromList (map last paths)

Once we've seen the goal in the fringe, we return the ladder that ends with the goal word:

>     winner :: [[String]] -> [String]
>     winner paths =
>       case (find ((== goal) . last) paths) of
>         Nothing -> undefined
>         Just a -> a

Word ladder in Python

In an earlier post, I described an implementation in Common Lisp of a breadth-first search to find word ladders.

This time I practiced the kata using Python. Python's list comprehensions help to make the solution concise, but apparently the lunch isn't free. For example, I could have written one_hop as

    def one_hop(a, b):
      return len([aa for aa, bb in zip(a, b) if aa != bb]) == 1

but that resulted in about a twenty percent slowdown.

The code falls out pretty easily:

#! /usr/bin/env python

"""Usage: %(prog)s start-word goal-word [ dictionary-path ]
"""

import sys

prog = sys.argv[0]

def read_words(path):
  words = []

  try:
    f = open(path, "r")
  except IOError, (errno, error):
    sys.stderr.write("%s: open %s: %s\n" % (prog, path, error))
    sys.exit(1)

  for word in f:
    words.append(word[:-1].lower())

  return words

def unpack_args(args):
  dict = "/usr/dict/words"

  if len(args) < 2 or len(args) > 3:
    sys.stderr.write(__doc__ % globals())
    sys.exit(1)

  start, goal = args[0:2]
  if len(args) == 3:
    dict = args[2]

  return (start, goal, dict)

def one_hop(a, b):
#  return len([aa for aa,bb in zip(a, b) if aa != bb]) == 1
  hops = 0
  for aa, bb in zip(a, b):
    if aa != bb:
      hops += 1

  return hops == 1

def rungs(start, goal, begat):
  path = [goal]
  while path[-1] != start:
    path.append(begat[path[-1]])
  path.reverse()

  return path

def ladder(start, goal, dict):
  if len(start) != len(goal):
    return None

  words = read_words(dict)
  candidates = set([w for w in words if len(w) == len(start)])

  start = start.lower()
  goal  = goal.lower()

  begat = {}

  last = [start]
  while len(last) > 0:
    fringe = []

    for w in last:
      neighbors = [n for n in candidates if one_hop(n, w)]

      for n in neighbors:
        begat[n] = w
        candidates.remove(n)

      if goal in neighbors:
        return rungs(start, goal, begat)
      else:
        fringe.extend(neighbors)

    last = fringe
  else:
    return None

def main(args):
  start, goal, dict = unpack_args(args)

  path = ladder(start, goal, dict)
  if path is None:
    print "%s: no path from '%s' to '%s'" % (prog, start, goal)
  else:
    for w, i in zip(path, range(1, len(path) + 1)):
      print "%3d. %s" % (i, w)

  return 0

if __name__ == "__main__":
    sys.exit(main(sys.argv[1:]))

Word ladder

You form a word ladder by changing exactly one letter in the current "rung" to form the next. For example, the following is a ladder from 'paste' to 'carry':

1. paste
2. pasty
3. party
4. parry
5. carry

Given starting and goal words, the Lisp code below performs a breadth-first search in the supplied dictionary. Using BFS has the interesting property of guaranteeing that the path found is the shortest between the two words.

I'm not really pleased with the result: there's not enough abstraction. I guess with Lisp, it's hard to be satisfied unless you write a couple of fly-daddy macros that reduce the meat of the code to about three lines.

(defparameter *default-dictionary*
  #P"/usr/dict/words")

(defvar *dictionary* (make-hash-table :test #'equal))

(defun ladder (start goal)
  (if (/= (length start) (length goal))
      (error "'~S' and '~S' have different lengths" start goal)
      (let* ((dict (read-dictionary))
             (candidates (ladder-candidates dict start))
             (seen (make-hash-table :test #'equal))
             (begat (make-hash-table :test #'equal))
             (todo (list start)))
        (loop while todo do
              (let ((next '()))
                (loop for word in todo do
                      (let ((neighbors (neighbors word candidates seen)))
                        (loop for w in neighbors do
                              (setf (gethash w seen) 1
                                    (gethash w begat) word))
                        (if (find goal neighbors :test #'equal)
                            (return-from ladder (rungs start goal begat))
                            (setf next (nconc next neighbors)))))
                (setf todo next)))
        (error "No path from '~A' to '~A'" start goal))))

(defun read-dictionary (&optional (path *default-dictionary*))
  (let ((cached (gethash path *dictionary*)))
    (if cached
        cached
        (let ((dict '()))
          (with-open-file (s path)
            (loop for word = (read-line s nil)
                  while word do
                  (push word dict)))
          (setf (gethash path *dictionary*) dict)))))

(defun ladder-candidates (dict start)
  (let ((candidates '())
        (len (length start)))
    (loop for w in dict
          when (and (= len (length w)) (string-not-equal w start)) do
          (push (string-downcase w) candidates))
    candidates))

(defun one-hop-p (from to)
  (let ((hops 0))
    (loop for ff across from
          for tt across to
          when (char-not-equal ff tt) do
          (incf hops))
    (= hops 1)))

(defun rungs (start goal begat)
  (let ((path (list goal)))
    (loop for word = (first path)
          for parent = (gethash word begat)
          while (string-not-equal word start) do
          (push parent path))
    path))

(defun neighbors (word pool &optional (seen (make-hash-table)))
  (loop for w in pool
        when (and (one-hop-p word w)
                  (not (gethash w seen)))
        collect w))

(defun one-hop-neighbors (word)
  (neighbors word (ladder-candidates (read-dictionary) word)))