Solving a minotauros cube in haskell: see blog post: http://moserei.de/2015/09/22/haskell-minotauros-cube.html

solve.hs

import Data.Maybe
import Data.List
import qualified Data.Set as Set

type Point = (Int, Int, Int)
type Shape = Set.Set Point

keys = [1..3]
allKeys = [(x, y, z) | x <- keys, y <- keys, z <- keys]

empty :: Shape
empty = Set.empty
full = Set.fromList allKeys

-- The shapes, sorted by their size (that's just a little optimization to keep
-- the first levels of the DFS tree slim, the algorithm works without the
-- sorting, too).
shapes = reverse $ map Set.fromList $
           sortBy (\a b -> compare (length a) (length b))
           [
             [         (2,2,1),
              (1,1,1), (2,1,1), (3,1,1)],

             [(1,2,1), (2,2,1),
                       (2,1,1), (3,1,1), (3,1,2)],

             [         (2,2,1),
              (1,1,1), (2,1,1), (3,1,1), (3,1,2)],

             [         (2,2,1), (2,2,2),
              (1,1,1), (2,1,1)],

             [(1,2,2),
              (1,2,1),
              (1,1,1), (2,1,1)],

             [         (2,2,1), (2,3,1),
              (1,1,1), (2,1,1),
                       (2,1,2)]
           ]

-- Rotation of two of three dims
rt :: (Int, Int) -> (Int, Int)
rt (1, 1) = (1, 3)
rt (1, 2) = (2, 3)
rt (1, 3) = (3, 3)
rt (2, 1) = (1, 2)
rt (2, 2) = (2, 2)
rt (2, 3) = (3, 2)
rt (3, 1) = (1, 1)
rt (3, 2) = (2, 1)
rt (3, 3) = (3, 1)

rotateX (x, y, z) =
  let
    (y', z') = rt (y, z)
  in (x, y', z')

rotateY (x, y, z) =
  let
    (x', z') = rt (x, z)
  in (x', y, z')

rotateZ (x, y, z) =
  let
    (x', y') = rt (x, y)
  in (x', y', z)

allTuple :: (a -> Bool) -> (a, a, a) -> Bool
allTuple f (a, b, c) = all f [a, b, c]

-- check validity of shapes, ie. if all coords are between 1 and 3
valid shape =
  let
    shapeL = Set.toList shape
    pred = map (\tpl -> allTuple (<=3) tpl && allTuple (>=1) tpl) shapeL
  in
    all (id) pred

-- subtract a shape from another
subtr :: Shape -> Shape -> Maybe Shape
subtr a b =
  if Set.isSubsetOf b a then Just (Set.difference a b) else Nothing

move :: Shape -> (Int, Int, Int) -> Maybe Shape
move shape (dx, dy, dz) =
  let
    mover = (\(x, y, z) -> (x + dx, y + dy, z + dz))
    moved = Set.map mover shape
  in
    if valid moved then Just moved else Nothing

-- move shape to lower coordinates as far as possible
normalize :: Shape -> Shape
normalize as =
  let
    moves = [-3..0]
    candidates = [ move as (x, y, z) | x <- moves, y <- moves, z <- moves ]
    filtered = filter isJust candidates
  in
    fromJust (head filtered)

-- move shape to all valid positions
allPos :: Shape -> [Shape]
allPos shape =
  let
    moves = [0..2]
    normalized = normalize shape
    candidates = [ move normalized (x, y, z) | x <- moves, y <- moves, z <- moves ]
  in
    map fromJust $ filter isJust candidates

times :: Int -> (a -> a) -> a -> a
times 0 f s = s
times n f s = times (n-1) f (f s)

-- all (unique) valid rotations of a shape
allRot :: Shape -> [Shape]
allRot shape =
  let
    counts = [0..3]
    normalized = normalize shape
    funs = [ (times xr rotateX) . (times yr rotateY) . (times zr rotateZ)
             | xr <- counts, yr <- counts, zr <- counts ]
    candidates = map (\fun -> normalize (Set.map fun normalized)) funs
    uniqueCandidates = group $ sort candidates
  in
    map head uniqueCandidates

-- The real "algorithm":
-- It starts with a full shape and subtracts all possible rotations/positions
-- of a shape from it. For each now smaller shape it tries the next shape...
-- Because of the laziness this a DFS and quite fast.
match :: Shape -> [Shape] -> Maybe [Shape]
match empty [] = Just []
match inp (firstShape : remainingShapes) =
  let
    -- all positions of all unique rotations
    allComb = foldr (++) [] $ map allPos $ allRot firstShape
    -- remaining shapes for allCombs (only valid ones)
    rests = map (\(c, r) -> (c, fromJust r)) $
              filter (isJust . snd) $
              map (\c -> (c, subtr inp c)) allComb
    -- recursion step
    mapped = map (\(c, r) -> (c : fromJust r)) $
               filter (isJust . snd) $
               map (\(c, r) -> (c, match r remainingShapes)) rests
  in
    listToMaybe mapped

-- Main: output lengths of the original and observed shapes, as well as the
-- real result.
solution = fromJust $ match full shapes
solution' = map Set.toList solution
lens = map (length . Set.toList) solution
len = foldr (+) 0 lens
slens = map (length . Set.toList) shapes
slen = foldr (+) 0 slens
main = print ((slen, len), (slens, lens), solution')