@@ -1,2 +1,107 @@
11module Data.Tree where
22
3+import Prelude
4+
5+import Control.Apply (lift2)
6+import Control.Monad.Rec.Class (Step(..), tailRec)
7+import Data.Foldable (class Foldable, foldMap, foldlDefault, foldrDefault)
8+import Data.List (List(..), head, snoc, tail, (:))
9+import Data.Monoid (power)
10+import Data.Traversable (class Traversable, sequenceDefault, traverse)
11+
12+-- | A Rose, or multi-way tree, with values of type `a`.
13+newtype Tree a = Node { value :: a
14+ , children :: Forest a
15+ }
16+
17+-- | A `Forest` is a list of `Tree`s.
18+type Forest a = List (Tree a)
19+
20+-- | Create a `Tree` from a `Node` value of type `a` and a `Forest` of children.
21+mkTree :: forall a. a -> Forest a -> Tree a
22+mkTree a cs = Node { value: a, children: cs }
23+
24+infix 5 mkTree as |>
25+
26+-- Instances
27+
28+instance functorTree :: Functor Tree where
29+ map f (Node {value:v, children: c}) = mkTree (f v) (tailRec go {current: c, result: Nil})
30+ where
31+ go {current: Nil, result: r} = Done r
32+ go {current: c:cs, result: r} =
33+ Loop {current: cs, result: snoc r (mkTree (f (nodeValue c)) (tailRec go {current: (nodeChildren c), result: Nil })) }
34+
35+instance applyTree :: Apply Tree where
36+ apply (Node {value: f, children: fs}) tx@(Node {value: x, children: xs})
37+ = Node {value: (f x), children: ((map <<< map) f xs) <> (map ((flip apply) tx) fs)}
38+
39+instance applicativeTree :: Applicative Tree where
40+ pure = (flip $ mkTree) Nil
41+
42+instance bindTree :: Bind Tree where
43+ bind tx@(Node {value: x, children: xs}) f =
44+ let (Node {value: b, children: bs}) = f x in
45+ Node {value: b, children: bs <> (map ((flip bind) f) xs)}
46+
47+instance monadTree :: Monad Tree
48+
49+instance foldableTree :: Foldable Tree where
50+ foldMap f (Node {value: x, children: xs}) = (f x) <> (foldMap (foldMap f) xs)
51+ foldl f = foldlDefault f
52+ foldr f = foldrDefault f
53+
54+instance traversableTree :: Traversable Tree where
55+ traverse f (Node {value: x, children: xs}) =
56+ lift2 (\a b -> Node {value: a, children: b}) (f x) (traverse (traverse f) xs)
57+
58+ sequence x = sequenceDefault x
59+
60+-- Other functions
61+
62+-- | Draw a 2D `String` representation of a `Tree String`.
63+drawTree :: Tree String -> String
64+drawTree t = tailRec go {level: 0, drawn: (nodeValue t) <> "\n", current: (nodeChildren t)}
65+ where
66+ go :: _ -> Step _ String
67+ go {level: l, drawn: s, current: Nil} = Done s
68+ go {level: l, drawn: s, current: c:cs } =
69+ let drawn = (power " " l) <> "|----> " <> (nodeValue c) <> "\n" in
70+ Loop {level: l, drawn: s <> drawn <> (tailRec go {level: l + 1, drawn: "", current: (nodeChildren c)}) , current: cs}
71+
72+-- | Draw a 2D `String` representation of a `Tree` composed of `Show`able
73+-- | elements.
74+showTree :: forall a. Show a => Tree a -> String
75+showTree = drawTree <<< (map show)
76+
77+-- | Scan a `Tree`, accumulating values of `b` there are constant across `Node`s
78+-- | that have the same parent.
79+scanTree :: forall a b. (a -> b -> b) -> b -> Tree a -> Tree b
80+scanTree f b n@(Node {value: x, children: xs}) =
81+ let fb = f x b
82+ in fb |> (tailRec go {b: fb, current: xs, final: Nil})
83+ where
84+ go :: _ -> Step _ (Forest b)
85+ go {b: b', current: Nil, final: final} = Done final
86+ go {b: b', current: c:cs, final: final} =
87+ let fb' = f (nodeValue c) b'
88+ in Loop {b: b', current: cs, final: snoc final (fb' |> tailRec go {b: fb', current: (nodeChildren c), final: Nil})}
89+
90+-- Setters and getters
91+nodeValue :: forall a. Tree a -> a
92+nodeValue (Node r) = r.value
93+
94+nodeChildren :: forall a. Tree a -> Forest a
95+nodeChildren (Node r) = r.children
96+
97+setNodeValue :: forall a. a -> Tree a -> Tree a
98+setNodeValue a (Node r) = Node r { value = a }
99+
100+modifyNodeValue :: forall a. (a -> a) -> Tree a -> Tree a
101+modifyNodeValue f (Node r) = Node r { value = f r.value }
102+
103+appendChild :: forall a. Tree a -> Tree a -> Tree a
104+appendChild n (Node r) = Node r { children = snoc r.children n }
105+
106+setChildren :: forall a. Forest a -> Tree a -> Tree a
107+setChildren cs (Node r) = Node r { children = cs }