Tree: 親子関係の付け替え ref: https://qiita.com/nobsun/items/27fe53516cbb90ba02e2

file0.txt

import Data.Tree

data Lab = A | B | C | D | E | F | G | H | I | J | K | L | M | N | O | P | Q | R | S | T | U | V | W | X | Y | Z
  deriving (Eq,Ord,Enum,Bounded,Show,Read)

sample :: Tree Lab
sample = Node A [Node B [Node C [Node D []
                                ,Node E []]
                        ,Node F [Node G []
                                ,Node H []]]
                ,Node I [Node J [Node K []
                                ,Node L []]
                        ,Node M [Node N []
                                ,Node O []]]]

file1.txt

reparented :: Tree Lab
reparented = Node F [Node B [Node A [Node I [Node J [Node K []
                                                    ,Node L []]
                                            ,Node M [Node N []
                                                    ,Node O []]]]
                            ,Node C [Node D []
                                    ,Node E []]]
                    ,Node G []
                    ,Node H []]

file10.txt

searchDown :: Eq a => a -> Zipper a -> [Zipper a]
searchDown x z@(Node y ys, bs) =
  bool id (z:) (x == y) (concatMap (searchDown x) (downs z))

file11.txt

downs :: Zipper a -> [Zipper a]
downs (Node r rs, bs) = map zipper (select rs)
  where
    zipper (ps,x,qs) = (x,(ps,r,qs):bs)

select :: [a] -> [([a],a,[b])]
select = para f []
  where
    f x (xs, yss)   = ([], x, xs) : map (add x) yss
    add y (ys,z,zs) = (y:ys,z,zs)

para :: (a -> ([a], b) -> b) -> b -> [a] -> b
para _ e []     = e
para f e (x:xs) = f x (xs, para f e xs)

file2.txt

reparent :: Eq a => a -> Tree a -> Maybe (Tree a)

file3.txt

reparent x = maybe Nothing (Just . promote) . search x

file4.txt

type Zipper a = (Tree a, [Crumb a])

current :: Zipper a -> Tree a
current (n,_)  = n

crumbs :: Zipper a -> [Crumb a]
crumbs (_,cs) = cs

file5.txt

type Crumb a = ([Tree a], a, [Tree a])

elders :: Crumb a -> [Tree a]
elders (es,_,_) = es

parentLabel :: Crumb a -> a
parentLabel (_,a,_) = a

youngers :: Crumb a -> [Tree a]
youngers (_,_,ys) = ys

file6.txt

toZipper :: Tree a -> Zipper a
toZipper = (,[])

fromZipper :: Zipper a -> Tree a
fromZipper = current . upMost

file7.txt

up :: Zipper a -> Maybe (Zipper a)
up z = case crumbs z of
  []     -> Nothing
  (b:bs) -> Just $ (Node (parentLabel b) (elders b++current z : youngers b), bs)

upMost :: Zipper a -> Zipper a
upMost z = maybe z upMost (up z)

file8.txt

promote :: Zipper a -> Tree a
promote (t,bs) = fromZipper (foldl f (t,[]) bs)
  where
    f (Node lab cs, ds) (ps,r,qs) = (Node r (ps ++ qs), ([],lab,cs) : ds)

file9.txt

search :: Eq a => a -> Tree a -> Maybe (Zipper a)
search x t = listToMaybe (searchDown x (toZipper t))