Skip to content

Instantly share code, notes, and snippets.

@moser moser/solve.hs
Created Sep 22, 2015

Embed
What would you like to do?
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
You can’t perform that action at this time.