more kenken

My second kenken program is a bit longer and more complex. At the base is the old kenken program (see this post).

This program though tries to eliminate possibilities on each cell as it goes. There is a structure that ties cells to the set of possibilities that are currently available for that cell :

data CellPos = CellPos { 
       cpcell :: Cell, 
       cposs  :: [Int] 
     } deriving (Eq, Show)

These are all initialized at start up so that cposs contains the list of integers [1..size of puzzle], then as possible assignments for cells are explored, each such assignment is used to try to reduce the possibilities in each of these structures.

The solve function then :

• finds all of the cells with only one possibility and makes all those assignments
  
• sorts the cells with multiple possibilities so those with the fewest number of possibilities come first
  
• tries making all the assignments currently possible with the first cell (which will be one of those with the fewest possibilities still available)
  
• returns all solutions found.
  

Another difference (as noted above) is that this solver will try to find all possible solutions for a puzzle instead of just the first.

Here is the solve function (stripped of debug prints) :

solve cpl assList resultList = do 
  puz <- getPuzzle 
  s <- getSize 

  let sortedPossibilities = sortBy comparer cpl
      comparer x y        = compare (pcount x) (pcount y)
      uhOh                =   null sortedPossibilities  -- no assignments possible ?? 
                           || 0 == pcount (head sortedPossibilities) 

  -- if no assignments possible from here, just return the result list 
  -- otherwise if there are ways to do a single assignment (so the possiblity
  -- list for a cell contains only one value), do all of those 
  -- then double check to see if it is all possible, if so call solve recursively
  if uhOh 
    then return resultList  
    else do 
      let 
          oneChoices          = filter (\x -> 1 == pcount x) sortedPossibilities 
          newAssignments      = makeAssignments oneChoices 
          multiChoices        = filter (\x -> 1 < pcount x)  sortedPossibilities 
          currentAssignments  = assList ++ newAssignments 

      ok <- verify currentAssignments

      if not ok 
        then do return resultList -- verify failed 
        else if null multiChoices 
                then return $ currentAssignments:resultList 
                else if length newAssignments > 0  
                        then do  -- new assignments to do, try them 

                          constraints <- getConstraints 
                          let constrainedPossibilities = foldr (updateRCPossibilities currentAssignments constraints) multiChoices newAssignments

                          solve constrainedPossibilities currentAssignments resultList 
                        else do 
                               let 
                                  nextCell            = head multiChoices 
                                  needAssignments     = tail multiChoices 
                                  nextAssignments     = map (\x -> Assignment{ acell = cpcell nextCell, avalue=x}) $ cposs nextCell


                               -- now we have a cell with several possibilities, try each of those in sequence 
                               maybeRes <- mapM (\x -> solveWithAssignment x needAssignments currentAssignments []) nextAssignments 
                               return $ resultList ++ (concat $ filter (not.null) maybeRes) 

Kenken Comments

My (previously posted) simple kenken solver solved every kenken puzzle I tried it on but two (where I think I transcribed the problem wrong). For the most part it seemed fast enough - taking about a half a second per puzzle. Profiling shows that most of the work goes into checking the various constraints, so they might benefit from tuning.

I thought it might help to sort the cells before solving the puzzle to see if there was a benefit to (for instance) doing the cells in division and subtraction constraints first. It turns out that that doesn't help much. Worse yet, if the cells are sorted so that addition and multiplication are first the run time goes from less than a second to hours. I had expected the run time to increase, but the size of the increase was startling. After a bit of consideration though, the reason became apparent.

Currently the cells are processed along the top row, then the second row and so on, which means that once the top left cell has been assigned a tentative value, the cells in the first row (and first column) are already constrained by the row/column constraints as well as by the (local) constraints imposed by the blocks. Thus fewer possibilities need to be considered. If we have a puzzle in which there are two division constraints at two diagonally opposite corners, and these are considered first, then the row and column constraints will have little (or no) effect and the solver will be forced to consider many more possible values for the cells.

Thus, solving a row at a time from left to right is probably about as good an ordering as you can get for this (not very smart) solver.

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

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