[Haskell-cafe] 1d-rubik

[Arie Groeneveld]

Hi all,

I read this on the J -programming forum
http://www.jsoftware.com/pipermail/programming/2007-June/007004.html

Maybe of interest, especially the part of generating the subgroup or
composing a more intelligent solver.

quote

I found an interesting game, as found on Andrew Nikitin's
MSX-BASIC page http://nsg.upor.net/msx/basic/basic.htm ,
and I am not sure if its solver has been given as a puzzle.
Here it goes.

1D Rubik's Cube is a line of 6 numbers with
original position:

1 2 3 4 5 6

which can be rotated in 3 different ways
in groups of four:
 _______              _______
(1 2 3 4)5 6 --(0)-> (4 3 2 1)5 6
  _______             _______
1(2 3 4 5)6 --(1)-> 1(5 4 3 2)6
    _______              _______
1 2(3 4 5 6) --(2)-> 1 2(6 5 4 3)

Given a scrambled line, return the shortest sequence of
rotations to restore the original position.

Examples:

solve 1 3 2 6 5 4
1 2 1
solve 5 6 2 1 4 3
0 2
solve 6 5 4 1 2 3
0 1 2

end quote


What follows is a kind of emulation (in the sense of the nature of the
J-program) of the solution of Roger Hui.
see http://www.jsoftware.com/pipermail/programming/2007-June/007006.html

Remarks:

  Rewards for me are learning and understanding J programming and
programming a Haskell solution for the same problem, plus a bit of group
theory.

  Roger Hui says that for his solution it's not guaranteed that the
rotation-sequence
is the shortest one


--------------------- PROGRAM --------------------------------------------

-- subgroup generators
-- all rotations are permutations of order 2 because they leave 2
elements in place
-- f.e. [3,2,1,0,4,5] has cycle product (1 4)(2 3)
rotaties :: [[Int]]
rotaties = [[3,2,1,0,4,5],[0,4,3,2,1,5],[0,1,5,4,3,2]]
ident :: [Int]
ident = [1..6]

rotix :: [[Int]]
rotix = [ [e] | e <- [0..2]]

-- flip consecutive part of the 1d-rubik
ds `roteer` d = map (ds !!) d

-- number of misplacements
-- equivalent to the parity-function of permutations or the order of a
permutation
-- it seemed that only even order permutations are solvable, indeed the
subgroup generated
-- contains only even permutations
mispl = sum . map (\[a,b] -> if b-a > 0 then 0 else 1) . combinationsOf 2

-- equivalent to J's : rotaties , ,/{"1/~ rotaties
-- to keep in order with the J program I had to change 'map (roteer x)'
to 'map (flip roteer x)'
rotzelf xs = concat $ xs : [ map (flip roteer x) xs | x <- xs ]

-- rotseqs equivalent to J-program line: q , , ,&.>/~ q
rotseqs xs = xs ++ (map concat $ [ [x,y] | x <- xs, y <- xs ])

-- mark duplicates function equivalent to J's ~: p
-- boolean array where a '0' marks a duplicate
markdups = domark []
domark _ [] = []
domark ys (x:xs)
         | x `elem` ys = 0 : domark (x:ys) xs
         | otherwise = 1 : domark (x:ys) xs

-- b <select> a
-- selects elements from array 'a' according to bool array 'b'
-- equivalent to J's m#n
[] `boolsel` _ = []
(b:bs) `boolsel` (x:xs)
         | b==1 = x: bs `boolsel` xs
         | otherwise = bs `boolsel` xs

-- after 5 iterations no further change occurs
-- the number of elements then reaches the order of the subgroup = 360
(subg, rseqs) = head . drop 4 . iterate tab $ (rotaties, rotix)
-- or : head . dropWhile ((/=360) . length . fst) . iterate tab $
(rotaties, rotix)
tab (ps , qs) = (bs `boolsel` rs, bs `boolsel` ts)
    where rs = rotzelf ps
          ts = rotseqs qs
          bs = markdups rs

solve :: [Int] -> [Int]
solve rs | odd . mispl $ rs = error " no solution possible...."
         | rs == ident = [] -- identity of the subgroup
         | otherwise = as
   where rs' = map (flip (-) 1) rs
         is = fromJust $ elemIndex rs' subg
         as = rseqs !! is

test = map solve [[1,3,2,6,5,4],[5,6,2,1,4,3],[6,5,4,1,2,3],[6,4,2,5,3,1]]


greetings

  @@i = Aai