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
Note that
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 ()