MagicBlocks.hs

{-

A program searching for solutions of a board puzzle
given by a friend.

The aim is to fill in a 8 by 8 square using the
given 8 pieces. Each piece has a particular shape and
can be rotated and flipped.

I am not satisfied with this program yet. The program
generates too many superficially different solutions:
pieces placed in different orders are considered different
solutions. I have yet to find a way to supress some of them.

Run by
  solveBoard (initSt, allReps) !! N
to get the Nth solution.

Shin-Cheng Mu, Jan 2020.
[email protected]

-}

import Control.Monad
import Data.List

-------------------------------------------------------
-- Start with something general, not problem-specific.

-- A genearl function searching for solutions,
-- from a given state |st|, until a state that satisfies
-- |goal| is found.
-- It returns the history of states.
-- Function |nextSt| is used to generate next states.

solve :: MonadPlus m =>
  (st -> Bool) -> (st -> m st) -> st -> m [st]
solve goal nextSt st | goal st = return [st]
solve goal nextSt st = do
   st' <- nextSt st
   sts <- solve goal nextSt st'
   return (st:sts)

-- States of many problems can be modelled using a
--  (Status, Items) pair, where each item can be used
--  only once.

-- The following function selects one item from a
-- list of items, using a function |match|.

selectItem :: MonadPlus m => (a -> m b) -> [a] -> m (b, [a])
selectItem match []     = mzero
selectItem match (x:xs) =
  (match x >>= \y -> return (y, xs)) `mplus`
  (selectItem match xs >>= \(y, xs') -> return (y,(x:xs')))

-- |selectUpdate match upd safe st xs| selects an item from
-- |xs|, uses that item to update the state |st| (using |upd|),
-- and keeps only |safe| states.

selectUpdate :: MonadPlus m =>
    (a -> m b) ->
    (st -> b -> m st) ->
    (st -> Bool) ->
    st -> [a] -> m (st, [a])
selectUpdate match upd safe st xs = do
    (y,xs') <- selectItem match xs
    st' <- upd st y
    guard (safe st')
    return (st', xs')

----------------------------------------
-- Pieces

-- Now we start describing the problem.

-- We fill in the square from bottom to top.
-- Therefore, status of the square can be represented by
-- the number of blocks filled in each row.
-- The initial status is 8 zeros.

type Status = [Int]

initSt :: Status
initSt = [0,0,0,0,0,0,0,0]

-- The following board with piece X and Y (not Z yet) is
-- represented by [3,3,2,2,2,2,2,0]
--
--                Z Z Z
--      X X       Z Z Z
--      X X X X Y Y Y Z
--      X X Y Y Y Y Y Z
--
-- with Z added it is [3,3,2,2,2,4,4,4].
-- The aim is to try going from [0,0,0,0,0,0,0,0] to
-- [8,8,8,8,8,8,8,8].

-- A piece looking like
--         X
--     X X X
--     X X X
--         X
-- can be represented by ([1,1,0],[2,2,4]), where [2,2,4]
-- denotes the number of Xs in each column, while [1,1,0]
-- denotes the space below those Xs.

-- Note, however, that each piece can be flipped and rotated.
-- Therefore we start with a "textual" representation of pieces.

type Piece = [[Char]]

allPieces = [p0, p1, p2, p3, p4, p5, p6, p7]

p0 = ["XX  ",
      "XX  ",
      "XXXX"]
p1 = ["XX  ",
      "XXXX",
      "XX  "]
p2 = ["XXX  ",
      "XXXXX"]
p3 = ["XX  ",
      "XXXX",
      "  XX"]
p4 = ["XXX",
      "XXX",
      " XX"]
p5 = [" XX ",
      " XX ",
      "XXXX"]
p6 = ["XXXX",
      "XXXX"]
p7 = ["X  X",
      "X  X",
      "XXXX"]

-- It is transformed to our internal representation.
-- For convenience, the representation is turned 90 degree
-- counterclockwise.
-- For example, rep p5 = [([1,1,0],[2,2,4])]
-- There is a slight problem -- p7 cannot be represnted this way.
-- But it doesn't matter.

rep :: [[Char]] -> [([Int],[Int])]
rep p | and (map (all (' '==)) rests) = [(bases, heights)]
      | otherwise = []
  where bases = map (length . takeWhile (' '==)) p
        heights = map (length . takeWhile ('X'==) . dropWhile (' '==)) p
        rests = map (dropWhile ('X'==) . dropWhile (' '==)) p

-- rotating and flipping the textual representation.

rotate :: [[a]] -> [[a]]
rotate = transpose . map reverse

flipP :: [[a]] -> [[a]]
flipP = map reverse

-- a pieces is actually represented by *all* its rotations and
-- flipped rotations, sorted by width (for faster processing).

type Rep = [[([Int], [Int])]]

widths :: [Int]
widths = [2..5]

rotReps :: [[Char]] -> Rep
rotReps = groupW . nub . concat . map rep . allrots
  where allrots p = take 4 (iterate rotate p) ++
                      take 4 (iterate rotate (flipP p))
        groupW xs = map (\n -> filter ((n==) . length . fst) xs) widths

-- allReps contains all the pieces.

allReps :: [Rep]
allReps = map rotReps allPieces

---------------------------------------------
-- State

-- The state of the search is represented by
--   (Status, [Rep])
--  where Status is the current status of the board,
--  [Rep] is the list of pieces that can still be used.

type State = (Status, [Rep])

-- The function that generates the next states from
--  the current state.

nextSt :: MonadPlus m => State -> m State
nextSt (st, reps) = do
  w <- mfromList widths
  matchW w st reps

 -- place a piece on the board, at position i.

place :: Status -> (Int, [Int]) -> Status
place st (i,xs) = take i st ++ lzipWith (+) xs (drop i st)

 -- This is some trick for faster processing.
 -- Well, I hope it is faster.

type Windows = [[Int]]

windows :: Int -> [a] -> [[a]]
windows w xs = take (n-w+1) . map (take w) . iterate tail $ xs
  where n = length xs

norm :: [Int] -> [Int]
norm xs = map (\x -> x - m) xs
   where m = minimum xs

matchW :: MonadPlus m =>
    Int -> Status -> [Rep] -> m (Status, [Rep])
matchW w st reps =
  selectUpdate (matchRep ws . (!!i))
               (\st -> return . place st)
               (all (<= 8)) st reps
 where ws = map norm (windows w st)
       i = w - 2

matchRep :: MonadPlus m =>
    Windows -> [([Int], [Int])] -> m (Int, [Int])
matchRep ws rs = do
      (base, heights) <- mfromList rs
      j <- matchBase base ws
      return (j, heights)
 where
  matchBase :: MonadPlus m => [Int] -> [[Int]] -> m Int
  matchBase base =
     mfromList . map fst . filter ((base ==) . snd) . zip [0..]

--

solveBoard :: MonadPlus m => State -> m [[Int]]
solveBoard st =
  (traceToBoard . map fst) <$>
     solve goal nextSt st
 where goal (st, reps) = null reps && all (8==) st

traceToBoard :: [Status] -> [[Int]]
traceToBoard = tb 0 [[],[],[],[],[],[],[],[]]
 where tb i bs []  = bs
       tb i bs [_] = bs
       tb i bs (s0:s1:st) =
         let dif = zipWith (-) s1 s0
         in tb (1+i) (add i dif bs) (s1:st)
       add i dif bs = zipWith (addL i) dif bs
       addL i n xs = xs ++ take n (repeat i)

----
-- Utilitiies

mfromList :: MonadPlus m => [a] -> m a
mfromList [] = mzero
mfromList [x] = return x
mfromList (x:xs) = return x `mplus` mfromList xs

lzipWith :: (t -> t -> t) -> [t] -> [t] -> [t]
lzipWith op [] ys = ys
lzipWith op xs [] = xs
lzipWith op (x:xs) (y:ys) = (x `op` y) : lzipWith op xs ys