[Haskell-cafe] 1d-rubik
Arie Groeneveld
bradypus at xs4all.nl
Thu Jun 21 04:38:34 EDT 2007
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
More information about the Haskell-Cafe
mailing list