Editing Rubiks Cube (section)

== Rubik's Cube as space transformation, with a solver ==

by Péter Diviánszky

A Rubik's Cube configuration can be represented by telling how to transform the space such that the 27 small cubes in the original configuration are moved and rotated to make up the current configuration.

<haskell>
type CubeFun = (Int, Int, Int) -> (Int, Int, Int)
</haskell>

The identity function represents the original cube.

The mid points of the 27 small cubes are (x,y,z) where x,y,z ∈ {-10,0,10}.
The magnification by 10 is needed because I wanted to avoid floating point calculation. The smaller lengths are used to explore how the space transformation alters directions around the mid points of the small cubes.

The colors are represented with space directions. For example, the direction
(1,0,0) is the color of the face of the original cube in that direction. This direction is called 'x'. The color of the opposite face is represented by (-1,0,0) which is called 'X'.
'y', 'Y', 'z', 'Z' correspond to the other colors, respectively.

The rotations are also represented with space directions. For example 'x' represents one quarter move of the top face around the 'x' axis in positive direction. 'X' represents one quarter move of the opposite face around the 'x' axis in negative direction.
'y', 'Y', 'z', 'Z' correspond to other rotations, respectively.

Here is the full source code implementing the moves, a solver, a reader and a pretty printer:

<haskell>
import Data.List
import Data.Maybe
import System.Environment

div10 x = (x + 5) `div` 10
mod10 x = (x + 5) `mod` 10 - 5

map3 f (x, y, z) = (f x, f y, f z)
zipW3 (*) (x, y, z) (x', y', z') = (x * x', y * y', z * z')
inner p q = x + y + z where (x, y, z) = zipW3 (*) p q
rot3 [a, b, c] p = map3 (inner p . dirVec) (a, b, c)

dirVec 'x' = ( 1, 0, 0)
dirVec 'y' = ( 0, 1, 0)
dirVec 'z' = ( 0, 0, 1)
dirVec 'X' = (-1, 0, 0)
dirVec 'Y' = ( 0,-1, 0)
dirVec 'Z' = ( 0, 0,-1)
dirVec '-' = ( 0, 0, 0)

type CubeFun = (Int, Int, Int) -> (Int, Int, Int)

cubeAt p x | map3 div10 x == p = x
cubeAt _ x = map3 ((10*) . div10) x

faces = map words [" -  Zyx  -   - "
                  ,"yXz xyz Yxz XYz"
                  ," -  zyX  -   - "]

readCube :: String -> CubeFun
readCube s p = foldr1 (zipW3 (+))
    [ map3 (* if dirVec q == map3 mod10 p then 11 else 10) $
        dirVec $ lines s !! (4*l - y + 1) !! (7*c + 2*(x + 1))
    | (l, face) <- zip [2,1,0] faces
    , (c, m@[q,_,_]) <- zip [2,1,0,3] face
    , (1, x, y) <- [rot3 m $ map3 div10 p] ]

showCube :: CubeFun -> String
showCube c = unlines $ map (unlines . map unwords . transpose . map face) faces
  where
    face "-" = replicate 3 "      "
    face f = [ unwords [ filter ((== map3 mod10 (c $ rot3 f (11, x, y))) . dirVec) "xyzXYZ-"
                       | x <- [-10,0,10]] ++ " "
             | y <- [10,0,-10]]

type Rotation = Char

decodeCube :: [Rotation] -> CubeFun
decodeCube = foldr (.) id . map rot
  where
    rot d p | div10 (dirVec d `inner` p) <= 0 = p
    rot d p = rot3 (fromJust $ lookup d $ zip "xyzXYZ" $ words "xZy zyX Yxz xzY Zyx yXz") p

encodeCube :: CubeFun -> Maybe [Rotation]
encodeCube cfun = listToMaybe $ filter (\c -> showCube (cfun . decodeCube c) == showCube id)
  $ foldl (flip $ concatMap . solvePiece) [""] $ map unzip $ init $ tails
    [(( 1,-1, 1),"x")
    ,(( 1,-1,-1),"Z")
    ,(( 1, 1, 1),"y")
    ,(( 1, 1,-1),"yyzzxxyyXXzzzXXyyxxzzyZyyyZZyyyZyyy")
    ,(( 0, 1,-1),"yyZZyyZZzxxYYZYYzzzYzzYYYxxZZyXX")
    ,(( 0, 1, 1),"zzzYYxxyyZXXyyxxzz")
    ,((-1,-1,-1),"X")
    ,(( 1, 1, 0),"zxxZzXXZZYXXzzxxyyyZZZ")
    ,((-1, 1,-1),"ZZzxxyyzyyZZZxxYYzXzzzXXXYYYzzXXYYYXXZZZzzz")
    ,(( 0,-1,-1),"ZZyyzzzYYyyZyyzzyyyZYYyyzzzy")
    ,(( 1, 0,-1),"zzzyyXXyyzzYYxxyyZZZyyyZYYyyzzzy")
    ,((-1,-1, 1),"XXZXXZZZyyzyyyzzzXXzzzXXzyyy zzxxZZZYYzXXZZZXXYYzzzxxxyyxxxZzzzyXXyyyzzz")
    ,((-1,-1, 0),"yyxxZZyyzzXYYzzyyxxxyy")
    ,((-1, 0,-1),"YYZZZXXZYYyyzzzxxzYYyyyZYYyyzzzy")
    ,((-1, 1, 0),"ZZZYYXXyyzzYYxxZZZzzzyxxzzxxyz")
    ,(( 0,-1, 1),"xxzzzyyXXYYZYYXXyyzzxx")
    ,(( 1,-1, 0),"ZyyxxYYZZYYxxZZZzzzyzzxxzzyzzz")
    ,(( 1, 0, 1),"YyyyxYyyyZYyyyXXYYYyZYYYyxYYYyzz")]
  where
    solvePiece (fixed: _, moves) p = try [] [""]
      where
        try _ [] = []
        try acc (p': cs)
            | sc `elem` acc = try acc cs
            | sc == showCube (cubeAt fixed) = [p' ++ p]
            | otherwise = try (sc: acc) $ cs ++ map (p' ++) (moves >>= words)
          where
            sc = showCube $ cubeAt fixed . decodeCube p' . decodeCube p . cfun

main = do
    args <- getArgs
    c <- case args of
      [s] | all (`elem` "xyzXYZ") s -> pure $ decodeCube s
          | otherwise -> readCube <$> readFile s
    putStr $ showCube c
    putStrLn $ maybe "not solvable" ("solution: " ++) $ encodeCube c
</haskell>

A sample input file:

<pre>
       Z x x               
       x z y               
       z Y Y               

X Y x  y X Z  x Z Z  y y Y 
z Y Y  Z x X  z y z  x X y 
x x Y  X y Z  y Z X  y Y z 

       z X X               
       Z Z X               
       Y z z               
</pre>

The corresponding output (the solution is not normalized):

<pre>
solution: YyyyxYyyyZYyyyXXYYYyZYYYyxYYYyzzxxzzzyyXXYYZYYXXyyzzxxZZZYYXXyyzzYYxxZZZzzzyxxzzxxyzZZZYYXXyyzzYYxxZZZzzzyxxzzxxyzZyyxxYYZZYYxxZZZzzzyzzxxzzyzzzYYZZZXXZYYyyzzzxxzYYyyyZYYyyzzzyxxzzzyyXXYYZYYXXyyzzxxyyxxZZyyzzXYYzzyyxxxyyYYZZZXXZYYyyzzzxxzYYyyyZYYyyzzzyXXZXXZZZyyzyyyzzzXXzzzXXzyyyzzzyyXXyyzzYYxxyyZZZyyyZYYyyzzzyZZyyzzzYYyyZyyzzyyyZYYyyzzzyyyxxZZyyzzXYYzzyyxxxyyyyxxZZyyzzXYYzzyyxxxyyZZzxxyyzyyZZZxxYYzXzzzXXXYYYzzXXYYYXXZZZzzzXXZXXZZZyyzyyyzzzXXzzzXXzyyyXXZXXZZZyyzyyyzzzXXzzzXXzyyyzxxZzXXZZYXXzzxxyyyZZZZZzxxyyzyyZZZxxYYzXzzzXXXYYYzzXXYYYXXZZZzzzZZzxxyyzyyZZZxxYYzXzzzXXXYYYzzXXYYYXXZZZzzzXZZzxxyyzyyZZZxxYYzXzzzXXXYYYzzXXYYYXXZZZzzzzzzYYxxyyZXXyyxxzzXzxxZzXXZZYXXzzxxyyyZZZyyZZyyZZzxxYYZYYzzzYzzYYYxxZZyXXzxxZzXXZZYXXzzxxyyyZZZXyyzzxxyyXXzzzXXyyxxzzyZyyyZZyyyZyyyyyzzxxyyXXzzzXXyyxxzzyZyyyZZyyyZyyyyyZZyyZZzxxYYZYYzzzYzzYYYxxZZyXXyZZyyzzxxyyXXzzzXXyyxxzzyZyyyZZyyyZyyyXxyyyzzxxyyXXzzzXXyyxxzzyZyyyZZyyyZyyyy
</pre>