Instantly share code, notes, and snippets.

# moser/solve.hs Created Sep 22, 2015

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')
to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.