Solving a Pycon puzzle... in Haskell
I was at Pycon Ireland last week-end. The event was quite successful and amazingly so considering it was a first for Dublin.
One of the highlights was one of those puzzles made of 13 plastic pieces to reassemble into a 4x4x4 cube (all pieces composed by 5 or 4 basic 1x1x1 cubes), brought by the guy at the Google stand. On Sunday, during the sprint session, the most successful one in terms of attendance and enthusiasm was an effort to solve the puzzle in python, cut short by the end of Pycon. The project seems to be ongoing at this time.
As the problem is very combinatorial in flavour, I thought the best tool for the job would be Haskell, which lends itself to concise expression of mathematical ideas. So I made an attempt at the implementation. Running it all night long gave me a few tens of solutions.
Some Haskell constructs are particularly interesting in the solution.
The monadic >>= operation for lists was used for the generation of all possible roto-translations of the pieces. If a function
f :: Bitmap -> [ Bitmap ] f bm = ... a certain list of Bimaps derived from bm ...yields a family of variations of a piece representation (for instance all translations, or all rotations around an axis), and g is another such function, then the expression
f bm >>= greturns all variations generated by g of all variations generated by f of the initial piece bm.
In the solution this is used in
-- All 24 rotations rotations bm = rotationsx bm >>= axischangex
which generates all the rotated versions of the piece bm by first rotating it in the 4 possible ways around the x-axis (including the null rotation) and then applying to each the 6 possible axis changes.
A useful tool was the use of axis transpositions to change the behaviour of some functions from one axis to the other. txy, txz and tyz transform a piece into one having two of the axis swapped. If one has implemented a function
f :: Bitmap -> acomputing a certain property for the x axis, then the composite function
f . txywill compute the same property along the y-axis and f . txz the same along the z-axis.
Similarly, one can transform a rotation around one axis to a rotation around another one by composing on the left and right with an axis transposition.
So, rotation around the y-axis and translation along it are defined as
shifty = txy' . shiftx rotatey = txy' rotatexwhere
-- Transpose, apply and transpose back x and y txy' f = txy . f . txy
shifty = txy' . shiftxand not
shifty = txy' shiftxbecause shiftx takes an additional parameter (the number of steps for the translations), so the three following expressions are equivalent
shifty i bm = txy' ( shiftx i ) bm shifty i = txy' ( shiftx i ) shifty = txy' . shiftxand I chose the shortest one.
Here is the complete code (subject to change if I spot any bug):
module Main where import Data.List ( transpose, nub, sortBy ) import Data.Bits import Data.Word -- Encoding of the 13 blocks composing the puzzle pms = [ [ [ 1, 3, 6 ] ] , [ [ 6, 3 ], [ 0, 1 ] ] , [ [ 2, 7 ], [ 2 ] ] , [ [ 0, 6 ], [ 2, 3 ] ] , [ [ 2, 7 ], [ 0, 1 ] ] , [ [ 1, 7 ], [ 0, 1 ] ] , [ [ 1, 7 ], [ 1 ] ] , [ [ 2, 7, 2 ] ] , [ [ 3, 1 ], [ 0, 1 ] ] , [ [ 4, 7 ], [ 0, 1 ] ] , [ [ 2, 7 ], [ 0, 2 ] ] , [ [ 6, 2 ], [ 0, 3 ] ] , [ [ 2, 7, 1 ] ] ] coord2bitmap :: Int -> [ Int ] coord2bitmap i = p' i  0 where p' _ x 4 = x p' dat part c = p'( dat `div` 2 ) ( part ++ [ dat `mod` 2 ] ) ( c + 1 ) pl2bitmap :: [ Int ] -> [ [ Int ] ] pl2bitmap c = map coord2bitmap $ take 4 $ c ++ repeat 0 pm2bitmap :: [ [ Int ] ] -> Bitmap pm2bitmap c = map pl2bitmap $ take 4 $ c ++ repeat  type Bitmap = [ [ [ Int ] ] ] bms = map pm2bitmap pms bm2string = concat . map plane2string . txy plane2string pl = ( concat $ map row2string pl ) ++ "\n" row2string r = ( map ( \ i -> if i == 0 then ' ' else 'X' ) r ) ++ "|" -- Transpose x and y axis txy = transpose -- Transpose, apply and transpose back x and y txy' f = txy . f . txy -- Same as above, for x-z and y-z tyz = map transpose txz = txy' tyz tyz' f = tyz . f . tyz txz' f = txz . f . txz -- Count number of ending free planes along an axis freex :: Bitmap -> Int freex bm = let isNot0 :: [ [ Int ] ] -> Bool isNot0 = any ( /= 0 ) . concat in case filter ( isNot0 . fst ) $ zip ( reverse bm ) [ 0 .. 4 ] of ( _ , x ) : _ -> x  -> error "Should never happen. Empty piece?" freey = freex . txy freez = freex . txz -- Shift i positions in one direction shiftx 0 bm = bm shiftx ( i + 1 ) bm = take 4 $ replicate 4 ( replicate 4 0 ) : shiftx i bm shifty = txy' . shiftx shiftz = txz' . shiftx -- Translations translations :: Bitmap -> [ Bitmap ] translations bm = [ shiftx i ( shifty j ( shiftz k bm ) ) | i <- [ 0 .. freex bm ] , j <- [ 0 .. freey bm ] , k <- [ 0 .. freez bm ] ] -- 90 degree rotation around one axis rotatex :: Bitmap -> Bitmap rotatex = tyz . map ( map reverse ) rotatey = txy' rotatex rotatez = txz' rotatex -- All 4 rotations around x rotationsx :: Bitmap -> [ Bitmap ] rotationsx bm = take 4 $ iterate rotatex bm -- All 6 basic rotations changing the x axis axischangex bm = map ( $ bm ) [ id, rotatey, rotatey . rotatey, rotatey . rotatey . rotatey, rotatez, rotatez . rotatez . rotatez ] -- All 24 rotations rotations bm = rotationsx bm >>= axischangex -- Word representation of a Bitmap toWord :: Bitmap -> Word64 toWord bm = foldl setBit 0 bits where bits = map fst $ filter ( (/=0) . snd ) $ zip [ 0.. ] $ concat ( map concat bm ) -- Word representations of all roto-translations toFullReprs bm = nub $ map toWord $ translations bm >>= rotations -- Word representations of all translations toTransReprs bm = nub $ map toWord $ translations bm -- Disjoint union of (possibly roto-translated) pieces -- One could use a tree of equivalent configurations instead of [ Word64 ] type Assembly = ( [ Word64 ], Word64 ) -- Join two assemblys joinAssemblys :: Assembly -> Assembly -> Assembly joinAssemblys ( l1, w1 ) ( l2, w2 ) = ( l1 ++ l2, w1 .|. w2 ) intersects :: Assembly -> Assembly -> Bool intersects ( _, w1 ) ( _, w2 ) = w1 .&. w2 /= 0 collisionFree :: [ Assembly ] -> [ Assembly ] -> [ Assembly ] collisionFree ws1 ws2 = concat $ map ( collisionFree1 ws2 ) ws1 collisionFree1 :: [ Assembly ] -> Assembly -> [ Assembly ] collisionFree1 ws1 w2 = map snd $ filter fst $ map ( \ w1 -> ( not $ intersects w1 w2, joinAssemblys w1 w2 ) ) ws1 main = do -- For each piece, list of possible word representations -- the first one is only translated to factor out rotations of the same solution let options = sortBy ( \ a b -> compare ( length a ) ( length b ) ) $ map ( map ( \ x -> ( [ x ], x ) ) ) $ toTransReprs ( head bms ) : map toFullReprs ( tail bms ) -- Generate and show solutions sequence $ map ( putStrLn . show ) $ foldl1 collisionFree options return ()