A backtracking solver for the Mondrian puzzle in Haskell (purely declaratively, list-based, no arrays)

Mondrian.hs

-- | The Mondrian puzzle.
--   <https://www.wissenschaft-shop.de/spiele-mit-iq/Mondrian-Blocks-wiss.html>
--
-- Task: place on a 8x8 board (64 squares) tiles of sizes
--
--   * 1x1, 1x2, 1x3, 1x4, 1x5  (15 squares occupied)
--   * 2x2, 2x3, 2x4, 2x5       (28 squares)
--   * 3x3, 3x4                 (21 squares)
--
-- Strategy:
--
--   * Solve by backtracking.
--   * Put down tiles in order of decreasing size (largest tiles first).
--   * Keep list of tile placements (rectangular area occupied by tile).
--   * Enumerate possible placements of next tile, iterate them.
--

import Data.Function (on)
import Data.List  ((\\), nub, sortBy)
import Data.Tuple (swap)

boardWidth :: Int
boardWidth = 8

boardHeight :: Int
boardHeight = 8

-- | A tile is characterized by its size.
--
--   Tiles can be placed horizontally or vertically, so the pairs are ordered @(smaller, larger)@.

type Tile = (Int,Int)
type Tiles = [Tile]

allTiles :: Tiles
allTiles =
  [ (3,4), (3,3)
  , (2,5), (2,4), (2,3), (2,2)
  , (1,5), (1,4), (1,3), (1,2), (1,1)
  ]

-- | If we mean a tile in a certain orientation, we speak of /oriented tile/.

type OrientedTile = Tile

-- | A position is the left-upper corner of the placed tile,
--   starting with 0.

type Position = (Int,Int)

-- | A placement is a rectangular area occupied by a tile.

type Placement = (Position, OrientedTile)

-- | Possible placements of a oriented tile on the empty board.

tilePositions :: OrientedTile -> [Position]
tilePositions (width, height) =
  [ (left, top) | left <- [0..boardWidth-width], top <- [0..boardHeight-height] ]

-- | Possible placements of a tile, considering both orientations.

tilePlacements :: Tile -> [Placement]
tilePlacements tile =
  [ (position, orientedTile)
  | orientedTile <- nub [ tile, swap tile ]
  , position <- tilePositions orientedTile
  ]

-- | A (partial) solution is a list of non-overlapping placements.

type Placements      = [Placement]
type PartialSolution = Placements
type Solution        = PartialSolution

-- | Do two stripes, given by starting coordinate and length, overlap?

overlap1d :: (Int,Int) -> (Int,Int) -> Bool
overlap1d (s1,l1) (s2,l2) = or
  [ s1 <= s2 && s2 < s1 + l1  -- first stripe contains second start coordinate
  , s2 <= s1 && s1 < s2 + l2  -- second stripe contains first start coordinate
  ]

-- | Do two areas overlap?
--
-- n-dimensional cubes overlap if they overlap in /every/ dimension.

overlap :: Placement -> Placement -> Bool
overlap ((l1,t1), (w1,h1)) ((l2,t2), (w2,h2)) = and
  [ overlap1d (l1,w1) (l2,w2)
  , overlap1d (t1,h1) (t2,h2)
  ]

-- | Possible placements of a tile so that it does not overlap with existing placements.

possiblePlacements :: Tile -> PartialSolution -> Placements
possiblePlacements tile solution =
  filter (\ placement -> not $ any (overlap placement) solution)
  $ tilePlacements tile

-- | Complete a partial solution by placing the remaining tiles.
--
-- This is a naive backtracking solver.

solveInOrder :: Tiles -> PartialSolution -> [Solution]
solveInOrder []             solution = return solution
solveInOrder (tile : tiles) solution = do
  placement <- possiblePlacements tile solution
  solveInOrder tiles (placement : solution)

-- A variant that reorders unused tiles by their placement possibilities,
-- so that tiles with fewer possibilities are placed first.
-- No noticeable speed up on the examples below.

solveByLeastPlacements :: Tiles -> PartialSolution -> [Solution]
solveByLeastPlacements []    solution = return solution
solveByLeastPlacements tiles solution = do
  placement <- placements
  solveByLeastPlacements restTiles (placement : solution)
  where
  -- Get tile with least number of possible placements.
  (tile, placements) : tilePlacements =
   sortBy (compare `on` length . snd) $
   map (\ tile -> (tile, possiblePlacements tile solution)) tiles
  restTiles :: Tiles
  restTiles = map fst tilePlacements

solve = solveInOrder

-- * Puzzles
-------------------------------------------------------------------------------------

-- | A puzzle is a partial solution that waits to be completed.

type Puzzle = PartialSolution

solvePuzzle :: Puzzle -> [Solution]
solvePuzzle placements = solve remainingTiles placements
  where
  remainingTiles = (allTiles \\ setTiles) \\ map swap setTiles
  setTiles       = map snd placements

-- Puzzle 1:
--
--   left ->
-- t . . . . . . x .
-- o . . . . . . x .
-- p . . . . . . * .
--   . . . . . . * .
-- | . . . . . . * .
-- v . . x . . . . .
--   . . . . . . . .
--   . . . . . . . .

puzzle1 = zip [(2,5), (6,0), (6,2)]
              [(1,1), (1,2), (1,3)]

-- | Puzzle 1 has exactly 1 solution.
-- >>> solutions1
-- [[((3,2),(1,4)),((7,0),(1,5)),((2,6),(2,2)),((0,5),(2,3)),((0,0),(4,2)),((4,0),(2,5)),((0,2),(3,3)),((4,5),(4,3)),((2,5),(1,1)),((6,0),(1,2)),((6,2),(1,3))]]
solutions1 = solvePuzzle puzzle1

-- Puzzle 2:
--
--   left ->
-- t x . . x x . . .
-- o x . . . . . . .
-- p x * . . . . . .
--   . . . . . . . .
-- | . . . . . . . .
-- v . . . . . . . .
--   . . . . . . . .
--   . . . . . . . .

puzzle2 = flip zip [(1,1), (2,1), (1,3)]
                   [(1,2), (3,0), (0,0)]

-- | Puzzle 2 has exactly 1 solution.
-- >>> solutions2
-- [[((2,7),(4,1)),((2,2),(1,5)),((1,0),(2,2)),((3,1),(2,3)),((6,4),(2,4)),((0,3),(2,5)),((3,4),(3,3)),((5,0),(3,4)),((1,2),(1,1)),((3,0),(2,1)),((0,0),(1,3))]]
solutions2 = solvePuzzle puzzle2


-- Puzzle 3:
--
--   left ->
-- t x . . . . . . .
-- o x . . . . . . .
-- p x . . . . . . .
--   . . . . . . x x
-- | . . . . . . . .
-- v . . x . . . . .
--   . . . . . . . .
--   . . . . . . . .

puzzle3 = [ ((0,0), (1,3)), ((6,3), (2,1)), ((2,5), (1,1)) ]

-- | Puzzle 3 has exactly 1 solution.
-- >>> solutions3
-- [[((1,2),(1,4)),((0,3),(1,5)),((1,6),(2,2)),((6,0),(2,3)),((6,4),(2,4)),((1,0),(5,2)),((3,5),(3,3)),((2,2),(4,3)),((0,0),(1,3)),((6,3),(2,1)),((2,5),(1,1))]]
solutions3 = solvePuzzle puzzle3