Solving Logic Grid Puzzles in Haskell
November 6, 2009 at 2:48 pm | In coding, haskell | 2 CommentsTags: coding, 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.
> import Data.Maybe
> import Control.Monad
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.
> type Entry = [String]
> type Answer = [Entry]
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.
> rules =
> [ 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 [ "", "England", "", "", "Red", "" ]
> , 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 [ "", "", "", "Water", "", "" ]
> , 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
> data Rule = Literal Entry
> | Adjacent Entry Entry
> | Follows Entry Entry
> deriving (Show)
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 :: Int -> Rule -> [Answer]
> 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 -> [Rule] -> [Answer]
> 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 :: Answer -> Answer -> Maybe Answer
> 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.
> main = showAnswers . applyRules emptyAnswer $ rules
> where emptyAnswer = replicate 5 . replicate 6 $ ""
> showAnswers = mapM_ $ mapM_ print
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)
Brian’s (Purely) Functional Brain
October 14, 2009 at 9:16 pm | In haskell | 15 CommentsTags: anythingyoucandohaskellcandobetter, brians brain, haskell
So about a week ago I came across an interesting post in which the author implemented the Brian’s Brain cellular automaton in 67 lines of Clojure. Not about to let my favorite language be outdone, I thought I’d see how well Haskell would do with the same task.
Then I was kept horribly busy for a week by schoolwork, so a couple of days ago I started playing around with the problem. The results? Not too shabby!
So first of all, we’ll be needing some imports. Since (for some odd reason) Haskell requires all imports up front, and since this blog post is supposed to be Literate Haskell, you’ll have to just trust me that we’ll need these for now:
> import Data.Array -- Used to store the world state for processing > import System.Random -- Used to generate the initial random world > import Control.Monad -- Used for some fancy looping constructs > import Control.Concurrent -- Used to fork the quit event handler > import Graphics.UI.SDL as SDL -- Used to draw the pretty pictures > import Control.Parallel.Strategies
Cells can be either On, Dying, or Off:
> data Cell = Off | Dying | On deriving (Eq, Enum)
For convenience, let’s define some constants:
> worldX = 90 -- The horizontal size of the world > worldY = 90 -- The vertical size of the world > cellSize = 8 -- The overall size of a cell > border = 1 -- The border width between cells > screenX = worldX * cellSize -- The horizontal size of the world, in pixels > screenY = worldY * cellSize -- The vertical size of the world, in pixels > fillSize = cellSize - border -- The size of the filled area in each cell
Cells progress from On to Dying to Off, and they turn on only when they have exactly two live neighbors.
> stepCell (On, _) = Dying -- Live cells always start to die > stepCell (Dying, _) = Off -- Dying cells always turn off > stepCell (Off, 2) = On -- If a dead cell has 2 live neighbors, turn on > stepCell (Off, _) = Off -- Otherwise, just stay turned off
Since we know from the rules that we’ll need the ability to count a cell’s live neighbors, let’s get that out of the way next.
> getPeers world (x,y) = (world ! (x,y), length . filter (== On) $ neighbors) > where neighbors = [getCell x y | x <- [x-1 .. x+1], y <- [y-1 .. y+1]] > getCell x y = world ! (clip worldX x, clip worldY y) > clip max val | val < 1 = clip max $ val + max - 1 > | val > max = clip max $ val - max + 1 > | otherwise = val
So now we have all the pieces to progress from one world state to the next. For each position in the array, we need to look up all its neighbors, count the live ones, and then pass that data to the stepCell function. The helper function indexArray creates an array of cell indices. We map over this array to generate new values for each cell.
The `using` parArr rwhnf‘ is some Haskell magic which causes the array to be evaluated in parallel:
> indexArray x y = listArray ((1,1),(x,y)) [(a,b) | a <- [1..x], b <- [1..y]] > stepWorld w = newWorld `using` parArr rwhnf > where newWorld = fmap (stepCell . getPeers w) $ indexArray worldX worldY
Now we have all we need to run a simulation, but it’s not quite enough if you insist on getting some pretty pictures. For my fancy display purposes, I happen to like SDL.
The main function initializes SDL, generates a random initial state, produces an infinite list of future world states from that, and then draws each of the states in turn:
> main = do rng <- newStdGen > SDL.init [SDL.InitVideo] > SDL.setCaption "Brian's Purely Functional Brain" "Brian's Brain" > surface <- SDL.setVideoMode screenX screenY 24 [SDL.DoubleBuf] > forkIO . forever $ waitEvent >>= \e -> when (e == Quit) quit > mapM (drawWorld surface) (iterate stepWorld $ world rng) > where world = listArray ((1,1),(worldX,worldY)) . map toEnum . randomRs (0,2)
And our world drawing function is positively boring. We map over each combination of X and Y values, draw each one, and then flip the resulting image on-screen:
> drawWorld s w = do sequence [draw x y | x <- [1..worldX], y <- [1..worldY]] > SDL.flip s > where draw x y = SDL.fillRect s (Just rect) . color $ w ! (x,y) > where rect = SDL.Rect (scale x) (scale y) fillSize fillSize > scale n = (n - 1) * cellSize > color On = SDL.Pixel 0x00FFFFFF > color Dying = SDL.Pixel 0x00888888 > color Off = SDL.Pixel 0x00000000
To take full advantage of the parallelism in this program, you’ll need to compile with the threaded runtime and run it on multiple OS threads.
ghc -O3 -threaded --make BriansBrain.hs ./BriansBrain +RTS -N2
And then just sit back and watch the mesmerising patterns.
This code is available on Hackage and GitHub.
Pretty Colors
Haskell While Loop
September 15, 2009 at 9:48 pm | In haskell | 2 CommentsIn the past week, while working on three completely unrelated Haskell projects, I have found myself in need of a while loop. So I came up with this one:
-- | For some reason Control.Monad doesn't provide a 'while'
-- function, even though it has a 'forever' function.
while :: Monad m => m Bool -> m a -> m ()
while predicate action = do
b <- predicate
if b then action >> while predicate action
else return ()
Hoogle shows no functions with that type signature, and I couldn’t find anything in the documentation that seemed to fit the bill. This seems like a rather fundamental function for getting stuff done, is there something I’m missing?
EDIT: The most code-golfed version I have yet come up with is `while p a = p >>= flip when (a >> while p a)` can anyone improve on that?
The Magic Dot
August 24, 2009 at 11:45 am | In haskell | 6 CommentsTags: fmap, haskell, prelude
So, reading about functors the other day, I noticed something interesting. Specifically, I noticed that in the case of functions, fmap is equivalent to the composition operation. I think fmap is possibly the coolest function in all of Haskell, so it annoys me when it requires six characters just to use it as an infix operator.
So I present what is, character-for-character, the coolest Haskell trick I have seen so far:
import Prelude hiding ((.)) import Control.Monad.Instances a . b = a `fmap` b infixr 9 .
And now, all sorts of fun little tricks are possible, like replacing "map succ $ [0..9]" with "succ . [0..9]", and replacing "getLine >>= return . (+1) . read" with "(+1) . read . getLine"
And of course, the same function composition magic still works like always. Maybe it’s just me, but something this simple, elegant, and fun to use just makes me happy inside.
But finally, I have to ask: is there any way of specifically declaring that a module *replaces* the standard Prelude (or even better, individual elements of it)? It would be really nice to just type import Prelude.MagicDot and not have to also bother with adding import Prelude hiding ((.))
Haskell Exceptions
July 18, 2009 at 6:36 pm | In haskell | Leave a CommentTags: error handling, haskell
Haskell’s absolute worst feature, in my opinion, is its system of exceptions. I have yet to see a single use of exceptions that wouldn’t be better served by the use of a “Maybe” or an “Either” type. Luckily, in a small nod to sanity, Haskell provides ‘Control.Exception.Base.try’, which returns an Either type, with the exception left, and the value right.
Once you have that, it becomes easy to implement some sane functionality for exception handling, such as my current favorite functions, ‘defaultOnError’ and ‘errorToMaybe’:
defaultOnError :: a -> IO a -> IO a
defaultOnError d a = do tryValue <- try a
case tryValue of
Left _ -> return d
Right v -> return v
errorToMaybe :: IO a -> IO (Maybe a)
errorToMaybe a = do tryValue <- try a
case tryValue of
Left _ -> return $ Nothing
Right v -> return $ Just v
Useful Haskell List Function
July 12, 2009 at 3:09 pm | In haskell | Leave a CommentI keep finding myself with a long list of elements, which I need to split into a list of lists of those elements. For example, I need to go from [0,1,2,3,4,5,6,7,8] to [[0,1,2],[3,4,5],[6,7,8]].
So far, the best function I have found to do this is
split :: Int -> [a] -> [[a]]
split n = unfoldr (\r -> case r of [] -> Nothing; x -> Just $ splitAt n x)
But that seems a little bit overcomplicated for such a simple function. Am I missing a better, more obvious solution?
Super-Makefile has levelled up! SuperMakefile became BashBuild!
May 8, 2009 at 11:55 pm | In coding | Leave a CommentI had just about reached the limits of what was possible with just a makefile, but I still felt like adding more. So I rewrote the thing today as a shell script. Now, you simply call it as ‘./configure’, and it generates the Makefile for you. The script is still configured in much the same manner as the old Makefile, except now you don’t have to specify a compiler.
More importantly, the rewrite has allowed a whole bunch of new tricks, including:
- Command-line specification of the install prefix
- Now the commands are familiar to anyone who has ever done a “./configure && make && sudo make install” before
- Out of source builds are now implemented
- Autodetection of the C compiler
And most importantly:
- Plenty of room to grow
Unfortunately, the code took a major step backwards in attractiveness. Over the next few days I may tinker around with it in an attempt to make it not look quite so bad, and possibly move more logic out into the configure script.
Other major news of the day: I finally dumped bzr for git, just so I could use GitHub. The new project is named BashBuild.
Revenge of the Super-Makefile
May 5, 2009 at 8:35 pm | In coding | Leave a CommentTags: c, coding, makefile
So today I found some more things that the old Makefile was lacking. An “install” target, a “.PHONY” target to prevent breakage down the line, and the ability to recursively build subprojects. A few hours later, I have this:
PROJECT=foo VERSION=0.0.1 SOURCES=bar.c baz.c SUBPROJECTS=xyzzy fnord LIBRARY=-lm INCPATHS=xyzzy fnord LIBPATHS=fnord PREFIX=/usr/local LDFLAGS= CFLAGS=-c -Wall -g CC=gcc # ------------ MAGIC BEGINS HERE ------------- # We want subprojects to use these variables export CC export PREFIX # Automatic generation of some important lists OBJECTS=$(SOURCES:.c=.o) INCFLAGS=$(foreach TMP,$(INCPATHS),-I$(TMP)) LIBFLAGS=$(foreach TMP,$(LIBPATHS),-L$(TMP)) # Set up the output file names for the different output types ifeq "$(LIBRARY)" "shared" BINARY=lib$(PROJECT).so else ifeq "$(LIBRARY)" "static" BINARY=lib$(PROJECT).a else BINARY=$(PROJECT) endif all: $(SOURCES) $(SUBPROJECTS) $(BINARY) $(BINARY): $(OBJECTS) ifdef SOURCES # Assemble the object files into the right type of binary ifeq "$(LIBRARY)" "static" ar rcs $(BINARY) $(OBJECTS) else ifeq "$(LIBRARY)" "shared" $(CC) -shared $(LIBFLAGS) $(OBJECTS) $(LDFLAGS) -o $@ else $(CC) $(LIBFLAGS) $(OBJECTS) $(LDFLAGS) -o $@ endif endif $(SUBPROJECTS): make -e -C $@ .c.o: $(CC) $(INCFLAGS) $(CFLAGS) -fPIC $< -o $@ install: @ for i in $(SUBPROJECTS); do make -e -C $${i} install; done ifdef SOURCES ifeq "$(LIBRARY)" "static" install $(BINARY) $(PREFIX)/lib else ifeq "$(LIBRARY)" "shared" install $(BINARY) $(PREFIX)/lib else install $(BINARY) $(PREFIX)/bin endif endif distclean: rm -f $(BINARY) $(OBJECTS) @ for i in $(SUBPROJECTS); do make -C $${i} distclean; done clean: rm -f $(OBJECTS) @ for i in $(SUBPROJECTS); do make -C $${i} clean; done .PHONY: all clean distclean install $(SUBPROJECTS)
It’s longer, but not by too much, and now I can safely say it has everything I have ever needed in a fancy build system. It would be nice if I could get pretty colourized output, but this Makefile reliably builds, cleans, and installs the projects I have tested it on.
The Super-Makefile
May 4, 2009 at 8:36 pm | In coding | Leave a CommentTags: c, coding, makefile
After toying with build systems off and on for months, I concluded today that make is about as advanced as I ever need to get for my projects. In the past, I recall using this gem of a Makefile. But my needs in a build process have grown a little. First of all, I now prefer C to C++, so that had to be changed. Then I had to go about adding static and shared library abilities to it. Then I added “clean” and “distclean” build targets, and include and library search paths got introduced somewhere along the way.
After good half hour of modification, I had the following Makefile, posted here mainly so I can find it easily from any computer. By modifying the first six variables defined in the Makefile, it can be adapted to almost any C project of reasonable complexity. It has no support for cross-platform library identification, out-of-source builds, or debug and release build toggles. But on the other hand, I can never get those things to work right any way.
Toggling between static library, shared library, and executable build modes is performed by setting the LIBRARY variable to “static”, “shared”, or anything that isn’t those two values.
PROJECT=foo SOURCES=bar.c baz.c LIBRARY=nope INCPATHS=../some_other_project/ LIBPATHS=../yet_another_project/ LDFLAGS=-ldosomething CFLAGS=-c -Wall CC=gcc # ------------ MAGIC BEGINS HERE ------------- # Automatic generation of some important lists OBJECTS=$(SOURCES:.c=.o) INCFLAGS=$(foreach TMP,$(INCPATHS),-I$(TMP)) LIBFLAGS=$(foreach TMP,$(LIBPATHS),-L$(TMP)) # Set up the output file names for the different output types ifeq "$(LIBRARY)" "shared" BINARY=lib$(PROJECT).so LDFLAGS += -shared else ifeq "$(LIBRARY)" "static" BINARY=lib$(PROJECT).a else BINARY=$(PROJECT) endif all: $(SOURCES) $(BINARY) $(BINARY): $(OBJECTS) # Link the object files, or archive into a static library ifeq "$(LIBRARY)" "static" ar rcs $(BINARY) $(OBJECTS) else $(CC) $(LIBFLAGS) $(OBJECTS) $(LDFLAGS) -o $@ endif .c.o: $(CC) $(INCFLAGS) $(CFLAGS) -fPIC $< -o $@ distclean: clean rm -f $(BINARY) clean: rm -f $(OBJECTS)
Fixing Broken Macros with Eval and Quasiquote
March 21, 2009 at 8:20 pm | In coding, lisp, scheme, tutorial | 2 CommentsTags: eval, macro, scheme
Recently, I found myself needing to deal with a “convenience” macro, which quoted several of its arguments for me before passing them along to the real function. Unfortunately, only the macro was exported from the library, and I was unable to access the base function.
(define-syntax convenient-function (syntax-rules () ((_ arg1 arg2) (much-harder-function 'arg1 'arg2))))
How useful. To save me a handful of quotes, I lose the ability to programmatically generate my arguments.
As I was loath to reimplement the entire library just to regain that ability, I looked for another solution. Thankfully, I found one.
(define (much-harder-function arg1 arg2) (eval `(convenient-function ,arg1 ,arg2) (environment '(convenient-lib))))
As far as I can tell, this circumvents the macro’s quoting features entirely to allow me to pass in a dynamically generated symbol. While it won’t work with functions which modify the environment, it worked well in my case, and allowed me to move on to more interesting code.
Blog at WordPress.com. | Theme: Pool by Borja Fernandez.
Entries and comments feeds.
