Hanoilike

Hanoilike.hs

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])))