Skip to content

Instantly share code, notes, and snippets.

@moser
Created September 22, 2015 21:30
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
Star You must be signed in to star a gist
Save moser/691147cc2bedd783bbf2 to your computer and use it in GitHub Desktop.
Solving a minotauros cube in haskell: see blog post: http://moserei.de/2015/09/22/haskell-minotauros-cube.html
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')
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment