Advertisement
Guest User

Haskell Nonogram Solver

a guest
Feb 3rd, 2012
219
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. -----------------------------
  2. -- Nonogram Solving Module --
  3. -----------------------------
  4.  
  5. module Nonogram
  6. (
  7.     Grid,
  8.     Line,
  9.     Cell(..),
  10.  
  11.     PuzzleDefinition,
  12.     LineDefinition,
  13.     Strip,
  14.  
  15.     solvePuzzle
  16. ) where
  17.  
  18. --
  19. -- Imports
  20. --
  21.  
  22. import Data.List
  23. import Control.Exception
  24.  
  25. --
  26. -- Types
  27. --
  28.  
  29. -- A puzzle definition is consisted of a list of row definitions and column definitions.
  30. -- Note: The length of the rows should be equal to the amount of columns and vice versa.
  31. type PuzzleDefinition = ([LineDefinition], [LineDefinition])
  32.  
  33. -- A line defintion is consited of a list of strips of black cells.
  34. type LineDefinition = [Strip]
  35.  
  36. -- A strip defines the length of the sequence of consequtive black cells in a line.
  37. -- Note: Strips should be positive numbers.
  38. --       There shouldn't be strips of zero length.
  39. type Strip = Int
  40.  
  41. -- A grid is consisted of a list of rows.
  42. type Grid = [Line]
  43.  
  44. -- A line is consisted of a list of cells.
  45. type Line = [Cell]
  46.  
  47. -- Cell is a data type that defines the state of a single cell.
  48. -- Note: The Unknown state could be represented differently,
  49. --       perhaps as a non-deterministic computation (i.e. [White, Black]).
  50. --       This way maybe some of the functions could be expressed more elegantly.
  51. data Cell = Unknown
  52.           | Black
  53.           | White
  54.           deriving (Eq, Show)
  55.  
  56. --
  57. -- Functions
  58. --
  59.  
  60. -- This function takes a puzzle definition and returns the solution grid to that puzzle.
  61. -- If the puzzle cannot be solved without guesses, the resulting grid will contain Unknown cells.
  62. solvePuzzle :: PuzzleDefinition -> Grid
  63. solvePuzzle puzzleDef =
  64.     let (rows, cols) = puzzleDef
  65.         width = length cols
  66.         hight = length rows
  67.         grid = unknownGrid width hight
  68.     in solveGrid puzzleDef grid
  69.  
  70. -- This function takes a grid size (width and hight), and returns a grid filled with Unknown cells.
  71. unknownGrid :: Int -> Int -> Grid
  72. unknownGrid width hight = replicate hight (unknownLine width)
  73.  
  74. -- This function takes a line length, and returns a line filled with Unknown cells.
  75. unknownLine :: Int -> Line
  76. unknownLine lineLength = replicate lineLength Unknown
  77.  
  78. -- This function takes a puzzle definition and a grid, and returns the solved grid.
  79. -- If the grid cannot be solved without guesses, some cells in the solution will be Unknown.
  80. solveGrid :: PuzzleDefinition -> Grid -> Grid
  81. solveGrid puzzleDef rows =
  82.     let (rowDefs, colDefs) = puzzleDef
  83.         -- Solve grid using row definitions
  84.         solvedRows = zipWith solveLine rowDefs rows
  85.         -- Transpose grid to get the columns
  86.         cols = transpose solvedRows
  87.         -- Solve grid using column definitions
  88.         solvedCols = zipWith solveLine colDefs cols
  89.         -- Transpose grid again to get the rows
  90.         newRows = transpose solvedCols
  91.     in -- If solving the columns didn't improve the solution,
  92.        -- Then we solved the grid as much as possible (without guesses).
  93.        -- Else, continue solving the grid based on the information we obtained
  94.        -- at this step.
  95.        if newRows == solvedRows
  96.        then newRows
  97.        else solveGrid puzzleDef newRows
  98.  
  99. -- This function takes a line definition and a line, and returns the solved line.
  100. -- If the line cannot be completely solved, some cells will remain Unknown.
  101. -- If the line has not possible solution, an error is produced.
  102. solveLine :: LineDefinition -> Line -> Line
  103. solveLine lineDef line =
  104.     let solutions = (lineSolutions lineDef line)
  105.         mergedSolution = foldr1 mergeSolutions solutions
  106.     in if null solutions
  107.        then error "Line has no possible solution"
  108.        else mergedSolution
  109.  
  110. -- This function takes a line definition and a line, and returns all the possible
  111. -- solutions to that line.
  112. lineSolutions :: LineDefinition -> Line -> [Line]
  113. lineSolutions lineDef line = filter (isSolution lineDef) (linePermutaions line)
  114.  
  115. -- This function takes a line definition and a line, and checks whether the line
  116. -- is a solution to the line definition.
  117. isSolution :: LineDefinition -> Line -> Bool
  118. isSolution strips cells =
  119.     let blocks = group cells
  120.         blackBlocks = filter ((==Black) . head) blocks
  121.         blackBlocksLengths = map length blackBlocks
  122.     in blackBlocksLengths == strips
  123.  
  124. -- This function takes a line, and returns all possible permutations of that line.
  125. -- I.E. for every Unknown cell, it produces a line with that cell White, and a
  126. -- line with that cell Black.
  127. linePermutaions :: Line -> [Line]
  128. linePermutaions (Unknown:cells) =
  129.     let otherLinePermutations = linePermutaions cells
  130.         unknownIsBlackPremutations = map (Black:) otherLinePermutations
  131.         unknownIsWhitePremutations = map (White:) otherLinePermutations
  132.     in unknownIsBlackPremutations ++ unknownIsWhitePremutations
  133. linePermutaions (knownCell:cells) = map (knownCell:) (linePermutaions cells)
  134. linePermutaions [] = [[]]
  135.  
  136. -- This function takes two lines (that are possible solutions to a line definition),
  137. -- and returns a line that is a merge of these solutions.
  138. -- Merging solutions keeps cells that are equal in both solutions.
  139. -- Unknown cells are placed instead of cells that are not equal.
  140. mergeSolutions :: Line -> Line -> Line
  141. mergeSolutions a b = zipWith keepCellIfEqual a b
  142.  
  143. -- This function takes two cells, and returns the first if they are equal,
  144. -- otherwise it returns an Unknown cell.
  145. keepCellIfEqual :: Cell -> Cell -> Cell
  146. keepCellIfEqual a b =
  147.     if a == b
  148.     then a
  149.     else Unknown
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement