[99p]VonKoch

import Data.List
import Data.Function

----- predefined graphs
type Arcgraph a = [(a, a)]
vkgraphtest :: Arcgraph Int
vkgraphtest = [(1,2),(1,3)]
vkgraph0 :: Arcgraph Int
vkgraph0 = [(1,2),(1,4),(1,7),(2,3),(2,5),(5,6)]
vkgraph1 :: Arcgraph Int
vkgraph1 = [(1,6),(2,6),(3,6),(4,6),(5,6),(5,7),(5,8),
            (5,10),(8,9),(10,11),(11,12),(11,13),(13,14)]
successlabel = [(1,1),(6,14),(2,2),(3,3),(4,4),(5,5),(7,13),(8,12),(10,11),(11,6),(12,10),(9,9),(13,8),(14,7)]

----- VonKoch Conjecture (graceful tree labeling)
  --- A very slow , not applicable solution by permutation
dist :: [Int] ->Arcgraph Int ->[Int]
dist l g = map (\x -> abs(l!!(fst x -1) - l!!(snd x -1))) g
vonPermu :: Arcgraph Int ->[[Int]]
vonPermu [] = []
vonPermu g = filter (\x -> sort (eds x) == [1..edge]) (permutations [1..edge+1])
            where edge = length g
                  eds x = dist x g

  --- Solution with a deterministic search
  --- This solution doesnot return all possible labelings
validLabel :: Ord a => Int -> [(a, Int)] -> Arcgraph a -> [(a, Int)]
validLabel _ [] _ = []
validLabel k labels g = [ (node, snd l + k) | node <- adj labels, l <- labels, (if node < fst l then (node, fst l) else (fst l, node)) `elem` g, (snd l + k) `elem` ([1..n] \\ (map snd labels)) ]
                     ++ [ (node, snd l - k) | node <- adj labels, l <- labels, (if node < fst l then (node, fst l) else (fst l, node)) `elem` g, (snd l - k) `elem` ([1..n] \\ (map snd labels)) ]
                        where n = length g + 1
                              adj [] = []
                              adj labels = nub([ fst x | x <- g, snd x `elem` (map fst labels) ] ++ [ snd x | x <- g, fst x `elem` (map fst labels) ]) \\ (map fst labels)
vkSearch :: Ord a => Int -> Arcgraph a -> [[(a, Int)]] -> [[(a, Int)]]
vkSearch 1 g labellists = labellists
vkSearch n g labellists = vkSearch (n-1) g (concatMap (newLabel (n-1)) labellists)
                          where newLabel k labels = [ labels ++ [s] | s <- validLabel k labels g ]
vonKoch :: Arcgraph Int -> [[Int]]
vonKoch [] = []
vonKoch g = vkk $ concatMap (vkSearch n g) [ [[(i,1)]] | i <- [1..n] ]
            where n = length g + 1
                  vkk :: Ord a => [[(a, Int)]] -> [[Int]]
                  vkk [] = []
                  vkk labellists = map extractlabel labellists
                                   where extractlabel labels = map snd $ sortBy (compare `on` fst) labels