Solving Logic Grid Puzzles in Haskell
The Zebra Puzzle is a decades-old exercise in deductive logic. Unfortunately, I lack the patience to sit down and solve this kind of puzzle. So in this post, we're going to cheat by teaching Haskell to solve it for us.
We will take our cue from this solution written in SWI Prolog, and encode our puzzle as a set of constraints that our solving code must satisfy.
An 'entry' is a single entity in the solution. In the Zebra puzzle, these are going to be the individual houses. For maximum generality, we're just going to represent all the properties of the entries with strings.
An answer to the puzzle is a collection of several entities which together satisfy all of the rules set forth in the puzzle description.
I was going to explain the rule types at this point, but the explanation ended up being a lot harder to understand than just looking at the rules for this puzzle, so we'll do that instead.
The first four rules simply teach our solver about numbers. After these rules are satisfied, the entries in the solution will be numbered one through five.
> [ Follows [ "1", "", "", "", "", "" ]
> [ "2", "", "", "", "", "" ]
> , Follows [ "2", "", "", "", "", "" ]
> [ "3", "", "", "", "", "" ]
> , Follows [ "3", "", "", "", "", "" ]
> [ "4", "", "", "", "", "" ]
> , Follows [ "4", "", "", "", "", "" ]
> [ "5", "", "", "", "", "" ]
Then we specify all of the clues that make up the puzzle itself. These are given in order, so it should be easy to see the correspondence with the clues listed in the wikipedia article
> , Literal [ "", "Spain", "Dog", "", "", "" ]
> , Literal [ "", "", "", "Coffee", "Green", "" ]
> , Literal [ "", "Ukraine", "", "Tea", "", "" ]
> , Follows [ "", "", "", "", "Green", "" ]
> [ "", "", "", "", "Ivory", "" ]
> , Literal [ "", "", "Snails", "", "", "Old Gold" ]
> , Literal [ "", "", "", "", "Yellow", "Kools" ]
> , Literal [ "3", "", "", "Milk", "", "" ]
> , Literal [ "1", "Norway", "", "", "", "" ]
> , Adjacent [ "", "", "", "", "", "Chesterfields" ]
> [ "", "", "Fox", "", "", "" ]
> , Adjacent [ "", "", "", "", "", "Kools" ]
> [ "", "", "Horse", "", "", "" ]
> , Literal [ "", "", "", "Juice", "", "Lucky Strike" ]
> , Literal [ "", "Japan", "", "", "", "Parliaments" ]
> , Adjacent [ "", "Norway", "", "", "", "" ]
> [ "", "", "", "", "Blue", "" ]
Unfortunately, one drink and one animal are missing from the rules as stated, so here we just inform the solver "someone drinks water" and "someone owns a zebra"
> , Literal [ "", "", "Zebra", "", "", "" ]
> ]
So we have three kinds of rules, for which we'll need a data definition. By now it should be self-evident how each of these work
At this point, we have a nice, declarative specification of what a solution will look like, and we need to write the code to solve for it. The key to solving the puzzle efficiently is to realize that each rule is effectively describing some small portion of a possible answer, with empty strings representing unknown values. What we need next is a way to expand a rule into a list of all those answers that it represents
> expandRule n (Literal a ) = [ expand n [ a ] x | x <- [0 .. n - 1] ]
> expandRule n (Follows a b) = [ expand n [a,b] x | x <- [0 .. n - 2] ]
> expandRule n (Adjacent a b) = concat [e $ Follows a b, e $ Follows b a]
> where e = expandRule n
>
> expand :: Int -> [Entry] -> Int -> [Entry]
> expand n rs@(r:_) x = replicate x blank ++ rs ++ replicate (n - x - 1) blank
> where blank = replicate (length r) ""
As we go about solving the puzzle, we will at all times have a collection of answers the solver currently knows to be possible, and a set of answer fragments resulting from expanding the rule we're currently trying to satisfy. What we need is a way to test every possible combination of the old answers with the new answer fragments.
Our solution will make use of the nondeterminism monad, called the "list" monad by the unenlightened. As we iterate over the rules, we will expand each one in turn, test every possible combination with the old answers, and then filter out the impossible ones.
At first, this will cause a combinatorial explosion of possible answers, but as new rules are added, we will eventually reach a point where each additional rule manages only to decrease the number of possible solutions, until there is only one remaining.
> applyRules answer rules = foldM applyRule answer rules
> where applyRule a r = catMaybes [overlay a x | x <- expandRule (length a) r]
From the definition of applyRules, it is clear that our overlay operation needs to have type Answer -> Answer -> Maybe Answer. If any two answers are both defined and different from each other, we return Nothing, and otherwise we return the most defined of the two fields.
> overlay old new = sequence $ zipWith overlay' old new
> where overlay' old new = sequence $ zipWith overlay'' old new
> overlay'' "" "" = Just ""
> overlay'' "" n = Just n
> overlay'' o "" = Just o
> overlay'' o n
> | o == n = Just o
> | otherwise = Nothing
Before any constraints are applied, the answer is entirely undefined, so the process of solving consists simply of applying all the rules to an initial empty answer, and seeing what results. In this case, there is only one answer, but removing one or more rules from the list can make other solutions equally valid.
To see how each additional rule changes the set of possible answers, you can try something like "mapM_ print . applyRules emptyAnswer . take ## $ rules" in GHCi, for all the numbers between 1 and 20.
(This post is Literate Haskell, meaning that it can be copied and pasted in its entirety into a *.lhs file, and then run with runhaskell)
