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)