Created
August 26, 2011 06:47
-
-
Save metaxy/1172845 to your computer and use it in GitHub Desktop.
Hanoilike
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
import Data.List | |
data Box = A | B | C | D | X deriving (Show,Eq) | |
boxLength = 4 | |
type Zeile = [Box] | |
type All = (Zeile,Zeile) | |
start :: All | |
start = ([X,X,X,X],[A,B,C,D]) | |
end :: All | |
end = ([X,X,X,X],[B,C,D,A]) | |
diff (a,b) (c,d) = diff' b d | |
diff' a b = foldl1 (+) (map comp (zip a b)) | |
comp (a,b) | |
| a == b = 0 | |
| otherwise = 1 | |
fs x = ([X,X,X,X], x) | |
shortest x y | |
| d == 0 = [x] | |
| d == 2 = swap2 x y | |
| d == 3 = swap3 x y | |
| d == 4 = swap4 x y | |
where | |
d = diff x y | |
per [] = [[]] | |
per xs = [x:ys | x <- xs, ys <- per (delete x xs)] | |
--swap2 :: All -> All -> [All] | |
swap2 x y = rolling swap2' (per allPos) [x] y | |
swap3 x y = rolling swap3' (per allPos) [x] y | |
swap4 x y = swap4' [x] y [0,1,2,3] | |
rolling f perm changes y = roll perm changes | |
where | |
roll [] changes = changes | |
roll (a:as) changes = roll as res | |
where | |
res = f changes y a | |
allPos = [0,1,2,3] | |
swap2' changes (p,b) args | |
| ((a !! p1) == (b !! p2)) && ((a !! p2) == (b !! p1)) = changes ++ [st1,st2,st3] | |
| otherwise = changes | |
where | |
changes_l = last changes | |
o = fst changes_l | |
a = snd changes_l | |
st1 = ((s3 (b !! p1) o), (s2 X a)) | |
st2 = (fst(st1) , (s1 X (s2 (b !! p2) (snd st1)))) | |
st3 = ((s3 X (fst st2)) , (s1 (b !! p1) (snd st2))) | |
p1 = args !! 0 | |
p2 = args !! 1 | |
p3 = args !! 2 | |
s1 a b = replaceAt p1 a b | |
s2 a b = replaceAt p2 a b | |
s3 a b = replaceAt p3 a b | |
swap3' changes (p,b) args | |
| ((a !! p1) == (b !! p1)) && (a!! p2) == (b !! p3) && (a!!p3) ==(b !!p4) = changes ++ [st1,st2,st3,st4] | |
| otherwise = changes | |
where | |
changes_l = last changes | |
o = fst changes_l | |
a = snd changes_l | |
p1 = args !! 0 | |
p2 = args !! 1 | |
p3 = args !! 2 | |
p4 = args !! 3 | |
st1 = ((s1 (a !! p2) o), (s2 X a)) | |
st2 = (fst st1, replaceAt st2ps X (s2 ((snd st1) !! st2ps) (snd st1))) | |
st3 = (fst st2, replaceAt st3ps X (replaceAt st2ps ((snd st2) !! st3ps) (snd st2))) | |
st4 = (s1 X (fst st3), replaceAt p3 (a !! p2) (snd st3)) | |
--s var wohin | |
s1 a b = replaceAt p1 a b | |
s2 a b = replaceAt p2 a b | |
s3 a b = replaceAt p3 a b | |
s4 a b = replaceAt p4 a b | |
st2ps | |
| a !! p2 == b !! p3 = p4 | |
| a !! p2 == b !! p4 = p3 | |
st3ps | |
| a !! p2 == b !! p3 = p3 | |
| a !! p2 == b !! p4 = p4 | |
swap4' changes (p,b) args = changes ++ [st1,st2,st3,st4,st5,st6] | |
where | |
changes_l = last changes | |
o = fst changes_l | |
a = snd changes_l | |
p1 = args !! 0 | |
p2 = args !! 1 | |
p3 = args !! 2 | |
p4 = args !! 3 | |
st1 = ((pl roof (a !! weg) o), (pl weg X a)) | |
st2 = (fst st1, (pl weg (a !! aufweg1Pos) (pl aufweg1Pos X (snd st1)))) | |
st3 = (fst st1, (pl aufweg1Pos (a !! aufweg2Pos) (pl aufweg2Pos X (snd st2)))) | |
st4 = (pl weg ((fst st3) !! roof) o, snd st3) | |
st5 = (fst st4, (pl aufweg2Pos (a !! roof) (pl roof X (snd st4)))) | |
st6 = (o, (pl roof ( a !! weg) (snd st5))) | |
roof = last(elemo (a !! weg) b) | |
aufweg1Pos = last(elemo (b !! weg) a) | |
aufweg2Pos = last(elemo (b !! aufweg1Pos) a) | |
weg = p1 | |
elemo x = findIndices (x==) | |
pl = replaceAt | |
replaceAt pos newVar list = insertAt' list [] pos | |
where | |
insertAt' (x:xs) new pos | |
| pos == 0 = insertAt' xs (new ++ [newVar]) (pos-1) | |
| otherwise = insertAt' xs (new ++ [x]) (pos-1) | |
insertAt' [] new pos = new | |
succeced x = length x >= 3 | |
test = map succeced (map (shortest start) (map fs (per [A,B,C,D]))) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment