Wednesday, April 29, 2009

Kenken constraints

There are several constraints in a kenken puzzle. First, each row and each column must have the numbers from 1 to the size of the puzzle with no repeats. Then each arithmetic constraint needs to be satisfied.

The row and column constraints are easy enough - just require that all the numbers in a row or column are different - and this works for partial rows/columns as well as full ones. Only the row code is included here (a following post will contain all of the code). This code checks all of the rows using a map that checks each row by index and uses a helper function "allDifferent" that checks to be sure that all the numbers in a row are different. I suspect there may be a better way using "nub" but this is simple enough.

allRowsOK p = do
s <- psize `liftM` getPuzzle
return $ and $ map (rowOK s p) [0..s-1]

rowOK s plist row = allDifferent (map avalue inrow)
where
inrow = filter (\x -> (row == (cy $ acell x))) plist

allDifferent [] = True
allDifferent (x:xs) = (not $ elem x xs) && allDifferent xs


The constraints are more difficult. These are checked with "checkCon" which takes a list of cell values, a target and an operator. A "+" constraint requires that the numbers so far add up to less than the target. A "*" constraint requires that the numbers so far add up to a divisor of the target. For divide and difference, a zero length list of cells is ok as is a list of cells with one entry and a list of cells with two entries is checked both ways and if either works the constraint is ok. This is tightened up a bit in a later version of the code, but this works for this simple version.


checkCon [] _ tgt _ = True
checkCon cl "=" tgt _ = tgt == cl !! 0
checkCon cl "*" tgt l = if length cl == l
then tgt == product cl
else 0== tgt `mod` (product cl)
checkCon cl "+" tgt l = if length cl == l
then tgt == sum cl
else tgt >= sum cl
checkCon cl "-" tgt _
| length cl > 2 = False
| length cl == 2 = abs(cl !! 0 - cl !! 1) == tgt
| length cl == 1 = True

checkCon cl "/" tgt _
| length cl > 2 = False
| length cl == 1 = True
| length cl == 2 = let a = cl !! 0
b = cl !! 1
in (a `div` b) == tgt || (b `div` a) == tgt

Tuesday, April 28, 2009

kenken parser

The parser for my kenken input format is simple and doesn't cope well with errors in the format. That's ok for me, as this was more or less an exercise in programming and not an attempt to build anything that anyone but me might use (and just became a blog post because, well, it was there).

In any case, I read in the file in one gulp using readFile, then pass that to the parse routine, so the parser is pure code. That gets passed to "parse" which breaks the input into lines (using "lines", natch), strips each input line of spaces and breaks the input into two parts at the first blank line. The size of the first list (the block of letters) is used to determine the size of the puzzle and then two helper functions are called, the first builds the list of cells and the second builds the list of constraints with the list of cells and the list of constraint definitions as its input.

Each of the lines in the block of cells is used to generate a Cell with the position derived using a counter passed to a recursive routine (I'd do it differently now, but rewriting would probably end up with my building a more robust parser and I'm not sure I want to do that).

Each constraint line is broken on the equals sign - the label for the constraint is the part before the equals, the target is the integer value of the list of digits and the operator (which must be present) is the last bit.

Without further ado, here is the parsing section of the solver (not all functions have types, but in later versions of this, the types are included pretty much everywhere).

parse :: String -> Puzzle
parse s = Puzzle {psize=size, origInput=plines, constraints=constraintList, pcells=cellList}
where
plines = map strip $ lines s
(cellLines, constraintLines) = break ([]==) plines
size = length cellLines
cellList = doCellLines 0 cellLines
constraintList = parseConstraintLines cellList $ tail constraintLines

doCellLines :: Int -> [String] -> [Cell]
doCellLines i [] = []
doCellLines i (l:ls) = let l1 = zip [0..] l
mkcell (xpos, y) = Cell { clabel=[y], cx=xpos, cy=i}
l2 = map mkcell l1
in l2 ++ (doCellLines (i+1) ls)

parseConstraintLines cells lines = map (parseConstraint cells) (filter ("" /=) lines)

parseConstraint cells l = Constraint {conlabel= label,
conop = op,
contarget = target,
concells = clist }
where
(label,rest) = break ('='==) l
(starget, op) = break (not.isDigit) $ tail rest
target = read starget
clist = filter (\c -> clabel c == label) cells
strip l = sl
where
sl = reverse $ dropWhile isSpace $ reverse $ dropWhile isSpace l

Friday, April 24, 2009

Simple kenken solver in haskell

Recently the NY Times started doing Kenken puzzles. These are numeric puzzles in the sudoku vein. For a good overview, see the wikipedia page where they have a nice sample puzzle.

I solved a couple of these and then decided that it was time to build a solver. My first solver (in Python) dissolved in a flurry of overcomplicated algorithms and data structures and I decided to start from scratch in Haskell (in part to try to improve my Haskell skills). First though, I needed an input format. I constructed one that was simple, easy to derive from a puzzle and easy to edit. In this format the puzzle grid is laid out with letters indicating the blocks and a list of constraints on the blocks on subsequent lines. Each constraint is a label (from the grid), an equals sign, a target value (numeric) and an operator ("+", "-", "/", "*", "=" - used when the value in the cell is set). This format has the advantage that it is easy for me to read and easy to parse.

The puzzle from the wikipedia entry is given below.

abbcdd
aeecfd
gghhfd
ggijkk
llijjm
nnnoom

a=11+
b=2/
c=20*
d=6*
e=3-
f=3/
g=240*
h=6*
i=6*
j=7+
k=30*
l=6*
m=9+
n=8+
o=2/



For example, the first block (labeled "a" in the square) needs to have a sum of 11.

My first solver was a simple backtracking recursive solver. It didn't use any constraint information except to verify that the current solution was ok.

To do this, I built several data structures. First, a Cell is an x,y location and a Constraint label (such as "a" above). I use the (x,y) information in the Cell to locate it rather than keeping a two dimensional array (or list of lists). This does mean that in several places I scan the list of cells to find a cell, but since the list of cells is typically small for these puzzles, that is not that much of a problem :


data Cell = Cell {
clabel :: String,
cx :: Int,
cy :: Int
}
deriving (Eq, Show)

Next, a Constraint is a label (from the puzzle input), a target value, an operation (as a string) and a list of cells. The list of cells could also be constructed as needed, but since checking the constraint always required looking at the list, I put this in.

data Constraint = Constraint
{ conlabel :: String,
conop :: String,
contarget :: Int,
concells :: [Cell]
}
deriving Show


An Assignment is a Cell - value pair, and we build up a list of possible assignments in a Possibility (that is, a possible solution). Assignments are not part of the puzzle, but are
carried around in the recursive calls.

data Assignment = Assignment { acell :: Cell, avalue :: Int }
deriving (Show, Eq)

type Possibility = [ Assignment ]

A puzzle has a size, the original input (which is useful for debugging), a list of constraints and a list of cells. Since I'd like to pass the puzzle around in lots of places, I'm building a State Monad of this as well.

data Puzzle = Puzzle {
psize :: Int,
origInput :: [String],
constraints :: [Constraint],
pcells :: [Cell]
}

type PuzzleM = StateT Puzzle IO


Next post: parsing the input.