Checkers game-over in Haskell

The programming subreddit recently had a discussion about testing a checkers board for game-over. I wondered how specifying the rules for legal moves would look with Haskell's pattern matching, and this post is a study of that technique. In fact, you can run yourself. Copy-and-paste the post body to a file named Checkers.lhs to get a working program!

The game is American checkers or English draughts, played on an eight-by-eight checkerboard, of all surfaces.

> {-# LANGUAGE ViewPatterns #-}

> module Checkers where

> import Data.Char (toLower,toUpper)
> import Data.List (tails,transpose)
> import Test.HUnit

> data Board = Board [String] deriving (Show)

> size :: Int
> size = 8

For a rough idea of the punchline, I was hoping for code along the lines of

move ('w':' ':_)     = 1
move ('W':' ':_)     = 1
move (' ':'W':_)     = 1
move ('w':'b':' ':_) = 1
move ('w':'B':' ':_) = 1
move ('W':'b':' ':_) = 1
move ('W':'B':' ':_) = 1
move (' ':'b':'W':_) = 1
move (' ':'B':'W':_) = 1
move _ = 0

and eventually

> gameOver :: Board -> Bool
> gameOver b = blueMoves b == 0 || whiteMoves b == 0

The OP on reddit chose white and blue for the sides' colors, and above we have more-or-less declarative rules for legal white moves. A pawn or king (w and W respectively) can move to an empty space before it. Kings are special in that they can move backwards. The list ends with legal jumps, and everything else is invalid.

The code is repetitive, but I'll clean that up later.

An immediate problem is the patterns are linear, but all legal moves in checkers are along diagonals. I kicked around ideas such as using IArray or nasty double-applications of !!. Then I realized I could rotate the board by 45° with a shear, a transposition, and removal of placeholders.

-- diagonals with positive slopes
posdiags = map reverse . filter used . transpose . map shear . zip [0..]
  where shear (i,s) = (replicate i              '#') ++ s ++
                      (replicate (k - size - i) '#')
        k = 2 * size - 1
        used = not . all (`elem` "#.")

Getting the other diagonals is similar, but again brings too much repetition.

negdiags = map reverse . filter used . transpose . map shear . zip [0..]
  where shear (i,s) = (replicate (k - size - i) '#') ++ s ++
                      (replicate i              '#')
        k = 2 * size - 1
        used = not . all (`elem` "#.")

Having Board values to play with is trivial:

> board :: String -> Board
> board s = Board $ go s
>   where go [] = []
>         go xs = let (a,bs) = splitAt size xs
>                 in a : go bs

It chops one long string into rows, but with Haskell's usually-awkward multiline strings, it's not so bad. For example

startBoard =
  ".b.b.b.b\
  \b.b.b.b.\
  \.b.b.b.b\
  \ . . . .\
  \. . . . \
  \w.w.w.w.\
  \.w.w.w.w\
  \w.w.w.w."

An early cut at blueMoves and reducing the repetition in the rules for moves was

blueMoves :: Board -> Int
blueMoves (diagonals -> (p,n)) =
  sum $ map move $ concatMap tails $ p ++ n
  where move ( b :' ':_) | b `elem` "Bb" = 1
        move (' ':'B':_) = 1
        move ('b': w :' ':_) | w `elem` "Ww" = 1
        move (' ': w :'B':_) | w `elem` "Ww" = 1
        move _ = 0

Sticking with the theme of repetition, whiteMoves is nearly identical with little breadcrumbs of differences. That was all good because I wanted to have a testsuite before I started refactoring.

tests :: Test
tests = test
  [ assertEqual "white must have piece to move"
      0 (nw ".b.b.b.b\
            \b.b.b.b.\
            \.b.b.b.b\
            \ . . . .\
            \. . . . \
            \ . . . .\
            \. . . . \
            \ . . . .")
  ]
  where nw = whiteMoves . board

Not bad for a start, but each testcase will have a dual for the other side—way too much copy-and-paste.

*Checkers> runTestTT tests
Loading package HUnit-1.2.2.1 ... linking ... done.
Cases: 1  Tried: 1  Errors: 0  Failures: 0
Counts {cases = 1, tried = 1, errors = 0, failures = 0}

Whee!

To wring out the duplication in the code for each side's moves, I considered using Template Haskell—a cousin of Lisp macros for Haskell. I decided to push lexical closures as far as I could, and the result is below.

> blueMoves, whiteMoves :: Board -> Int
> [blueMoves, whiteMoves] =
>   let blueOrder = id  -- diagonals emerge in blue's perspective
>       whiteOrder = map reverse
>       count (direction,side) (diagonals -> ds) =
>         sum $ map sideCanMove $ concatMap tails $ direction $ ds
>         where sideCanMove ( p :' ':_)     | same p = 1
>               sideCanMove (' ': k :_)     | king k = 1
>               sideCanMove ( p : o :' ':_) | same p && opponent o = 1
>               sideCanMove (' ': o : k :_) | king k && opponent o = 1
>               sideCanMove _ = 0
>               same p     = piece p && toLower p == toLower side
>               opponent p = piece p && toLower p /= toLower side
>               king p     =  same p &&         p == toUpper side
>               piece p    = p `elem` "BbWw"  -- filter empty spaces
>   in map count [ (blueOrder, 'b'), (whiteOrder, 'w') ]

The code in count (notice the view pattern?) is a skeleton to be customized for the blue side and the white side, and it distills the repeated code. The definition of sideCanMove generalizes the rules for legal moves on either side. We have to reverse the diagonals to make them usable on the white side.

To get both sets of diagonals, the only difference is how to shear the board: bottom-away for positive slopes and top-away for negative.

> -- positive slopes slice from NW to SE
> -- negative slopes slice from SW to NE
> -- both extend in blue's direction (north-to-south)
> diagonals :: Board -> [String]
> diagonals (Board rows) = positiveSlopes rows ++ negativeSlopes rows
>   where positiveSlopes = go $ \(i,xs) -> (i, k - size - i, xs)
>         negativeSlopes = go $ \(i,xs) -> (k - size - i, i, xs)
>         k = 2 * size - 1
>         used = not . all ignored
>         go order = filter (not . null)
>                  . map (filter $ not . ignored)
>                  . transpose
>                  . map (shear . order)
>                  . zip [0..]
>         ignored = (`elem` "#.")
>         shear (l,r,s) = (replicate l '#') ++ s ++ (replicate r '#')

Finally come the tests that I added as I went. To factor out duplication, each board becomes two testcases. The first is as-is, and the same condition should hold for the other side. See the definition of invert in the where clause.

I had hoped for a more elegant result, but it was an interesting exercise and a fun problem!

> tests :: Test
> tests = test $ concat
>   [ checkMoves "must have piece to move"
>       0 ".b.b.b.b\
>         \b.b.b.b.\
>         \.b.b.b.b\
>         \ . . . .\
>         \. . . . \
>         \ . . . .\
>         \. . . . \
>         \ . . . ."
>   , checkMoves "one move"
>       1 ". . . . \
>         \ . . . .\
>         \. . . . \
>         \ . . . .\
>         \. . . . \
>         \ . . . .\
>         \. . . . \
>         \w. . . ."
>   , checkMoves "one king move"
>       1 ". . . . \
>         \ . . . .\
>         \. . . . \
>         \ . . . .\
>         \. . . . \
>         \ . . . .\
>         \. . . . \
>         \W. . . ."
>   , checkMoves "two moves"
>       2 ". . . . \
>         \ . . . .\
>         \. . . . \
>         \ . . . .\
>         \. . . . \
>         \ . . . .\
>         \. . . . \
>         \ .w. . ."
>   , checkMoves "king can move back from end"
>       2 ". . .W. \
>         \ . . . .\
>         \. . . . \
>         \ . . . .\
>         \. . . . \
>         \ . . . .\
>         \. . . . \
>         \ . . . ."
>   , checkMoves "can jump opponent pawn"
>       1 ". . . . \
>         \ . . . .\
>         \. . . . \
>         \ . . . .\
>         \. . . . \
>         \ . . . .\
>         \.b. . . \
>         \w. . . ."
>   , checkMoves "can't jump blocked opponent"
>       0 ". . . . \
>         \ . . . .\
>         \. . . . \
>         \ . . . .\
>         \. . . . \
>         \ .b. . .\
>         \.b. . . \
>         \w. . . ."
>   , checkMoves "can jump opponent king"
>       1 ". . . . \
>         \ . . . .\
>         \. . . . \
>         \ . . . .\
>         \. . . . \
>         \ . . . .\
>         \.B. . . \
>         \w. . . ."
>   , checkMoves "king can jump trailing opponent"
>       1 ". . . .W\
>         \ . . .b.\
>         \. . . . \
>         \ . . . .\
>         \. . . . \
>         \ . . . .\
>         \. . . . \
>         \ . . . ."
>   , checkMoves "king can't jump protected opponent"
>       0 ". . . .W\
>         \ . . .b.\
>         \. . .b. \
>         \ . . . .\
>         \. . . . \
>         \ . . . .\
>         \. . . . \
>         \ . . . ."
>   , checkMoves "king can't jump onto own piece"
>       1 ". . . .W\
>         \ . . .b.\
>         \. . .w. \
>         \ . . . .\
>         \. . . . \
>         \ . . . .\
>         \. . . . \
>         \ . . . ."
>   , checkMoves "king has four moves"
>       4 ". . . . \
>         \ . . . .\
>         \. . . . \
>         \ . .W. .\
>         \. . . . \
>         \ . . . .\
>         \. . . . \
>         \ . . . ."
>   , checkMoves "cannot displace opponent on king row"
>       0 ". . .b.b\
>         \ . . .w.\
>         \. . . . \
>         \ . . . .\
>         \. . . . \
>         \ . . . .\
>         \. . . . \
>         \ . . . ."
>   ]
>   where nw = whiteMoves . board
>         nb = blueMoves  . board
>         checkMoves name expect b =
>           [ assertEqual ("white: " ++ name) expect (nw b)
>           , assertEqual ("blue: "  ++ name) expect (nb $ invert b)
>           ]
>         invert = reverse . replace [('W','B'), ('w','b'), ('B','W'), ('b','w')]
>         replace tbl = map (\c -> maybe c id $ lookup c tbl)

Haskell Platform on a fresh Ubuntu install

With newly-installed Ubuntu 9.10, I attempted to install version 2009.2.0.2 of the Haskell Platform, but the build of mtl failed:

Could not find module `Control.Monad'

But ghci knew about Control.Monad!

Prelude> :m + Control.Monad
Prelude Control.Monad>

Google searches yielded no relevant hits. I did find Installing haskell-platform in Ubuntu 9.10 “Karmic Koala” by David Siegel, where he mentions installing prerequisites:

sudo apt-get install ghc6 ghc6-prof ghc6-doc haddock libglut-dev happy alex \
  libedit-dev zlib1g-dev checkinstall

Even with these packages in place, the build continued to fail with the same error.

In an earlier iteration, I had installed libghc6-mtl-dev from APT, but after removing it, the mtl build succeeded along with the rest of the Haskell Platform!

The problem is the Haskell Platform build wants to install packages with and without profiling, but this means you also need profiling versions of all the prerequisite Haskell packages. (Note the presence of ghc6-prof in the above apt-get command.)

Cabal could have saved me lots of headscratching by telling me in its error message that it couldn't find a profiling version of Control.Monad!

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 ]

Finding duplicates with Perl and Haskell

A coworker wanted to check a family of log files to be sure that a given task never appeared on multiple nodes at the same time. Log entries are on single, whitespace-separated lines, and the last field records a task's start time, e.g.,

1251475056672590000_1732248586_4

Of the three underscore-separated fields, the first is a timestamp, the second we don't care about, and the third is a task identifier.

This task is straightforward with Perl. The diamond operator (or null filehandle, as described in the "I/O Operators" section of the perlop manpage) takes care of the boilerplate for iterating over the paths on the command line, opening them, and reading each line. The scalar $ARGV contains the name of the current file.

By default, split separates fields by whitespace, so (split)[-1] gives us the last field, from which we then grab the time and task with a regular expression and record its presence by pushing the entry's path and line number onto an array associated with that time/task pair. After we've processed the logs, these arrays should all be singletons.

The continue clause is a little weird but necessary because the special variable $., the current line number, does not reset on <>'s implicit opens. ARGV is a handle on the file being read.

With this data structure, detecting duplicates is a search for time/task pairs with multiple hits. We count duplicates and let the user know what we found.

#! /usr/bin/perl

use warnings;
use strict;

# e.g., $hits = @{ $seen{$time}{$task} };
my %seen;

sub num { $a <=> $b }

while (<>) {
  if ((split)[-1] =~ /^(\d+)_\d+_(\d+)$/) {
    my($time,$task) = ($1,$2);
    push @{ $seen{$time}{$task} } => "$ARGV:$.";
  }
  else {
    die "$0: $ARGV:$.: bad timestamp/task field\n";
  }
}
continue {
  close ARGV if eof;
}

my $duplicates = 0;
foreach my $time (sort num keys %seen) {
  foreach my $task (sort num keys %{ $seen{$time} }) {
    my @hits = @{ $seen{$time}{$task} };
    next if @hits == 1;

    $duplicates += @hits - 1;
    warn "$0: duplicates for time=$time, task=$task:\n",
         map "    - $_\n", @hits;
  }
}

my $s = $duplicates == 1 ? "" : "s";
print "$0: $duplicates duplicate$s detected.\n";

exit $duplicates == 0 ? 0 : 1;

For comparison, I implemented the same log checker in Haskell. The function allInputs emulates Perl's diamond operator, and instead of a multi-level hash, the association is more direct: time/task pair to a list of hits.

module Main where

import Control.Monad (liftM)
import Data.List (sort)
import Data.Map (empty,filter,fromListWith,toList,unionWith)
import Prelude hiding (filter)
import System.Environment (getArgs,getProgName)
import System.Exit (ExitCode(..),exitWith)
import Text.Printf (printf)

type Time = String
type Task = String
data Duplicates =
  Duplicates { timestamp :: Time
             , taskId    :: Task
             , locations :: [(FilePath, Int)]
             }

main :: IO ()
main = do
  logs <- allInputs
  let multi = dups logs
      n = sum $ map (subtract 1 . length . locations) multi
  mapM_ (msg . lines . dupmsg) multi
  msg $ ndups n
  exitWith $ if n == 0
               then ExitSuccess
               else ExitFailure 1
  where
    msg info = do me <- getProgName
                  putStrLn $ me ++ ": " ++ head info
                  mapM_ putStrLn (tail info)

    ndups 1 = ["1 duplicate detected"]
    ndups n = [show n ++ " duplicates detected"]

    dupmsg (Duplicates tm task ls) = unlines $
      printf "duplicates for time=%s, task=%s:" tm task :
      map (\(path,n) -> printf "    - %s:%d" path n) ls

allInputs :: IO [(FilePath, String)]
allInputs = getArgs >>= go
  where go [] = ((:[]) . (,) "-") `liftM` getContents
        go fs = mapM readFile fs >>= return . zip fs

dups :: [(FilePath, String)] -> [Duplicates]
dups = map (\((tm,task),ds) -> Duplicates tm task ds) .
       sort .
       toList .
       filter ((> 1) . length) .
       foldl (unionWith (++)) empty .
       map (\(path, contents) ->
              fromListWith (++) $
              map (wrap path . getTimeTask) $
              zip [1..] $ lines contents)
  where
    wrap path (tm,task,n) = ((tm,task), [(path,n)])

getTimeTask :: (Int,String) -> (Time,Task,Int)
getTimeTask (n,line) = (tm,tsk,n)
  where
    [tm,_,tsk] = splitBy '_' (last $ words line)

    splitBy :: Eq a => a -> [a] -> [[a]]
    splitBy _ [] = []
    splitBy x xs = h : splitBy x t
      where (h,rest) = break (== x) xs
            t = drop 1 rest