@@ -2,81 +2,31 @@ module Data.Tree where
22
33import Prelude
44
5−import Control.Apply (lift2)
5+import Control.Comonad.Cofree (Cofree, head, mkCofree, tail, (:<))
66import Control.Monad.Rec.Class (Step(..), tailRec)
7−import Data.Foldable (class Foldable, foldMap, foldlDefault, foldrDefault)
8−import Data.Generic (class Generic, gEq, gShow)
7+import Data.Generic (class Generic)
98import Data.List (List(..), snoc, (:))
109import Data.Monoid (power)
11−import Data.Traversable (class Traversable, Accum, sequenceDefault, traverse)
10+import Data.Traversable (Accum)
1211
1312-- | A Rose, or multi-way tree, with values of type `a`.
14−newtype Tree a = Node { value :: a
15− , children :: Forest a
16− }
13+type Tree a = Cofree List a
1714
18−-- | A `Forest` is a list of `Tree`s.
1915type Forest a = List (Tree a)
2016
2117-- | Create a `Tree` from a `Node` value of type `a` and a `Forest` of children.
2218mkTree :: forall a. a -> Forest a -> Tree a
23−mkTree a cs = Node { value: a, children: cs }
24−
25−infix 5 mkTree as |>
26−
27−-- Instances
28−
29−derive instance genericTree :: Generic a => Generic (Tree a)
30−
31−instance eqTree :: Generic a => Eq (Tree a) where
32− eq = gEq
33−
34−instance showTree' :: Generic a => Show (Tree a) where
35− show = gShow
36−
37−instance functorTree :: Functor Tree where
38− map f (Node {value:v, children: c}) = mkTree (f v) (tailRec go {current: c, result: Nil})
39− where
40− go {current: Nil, result: r} = Done r
41− go {current: c:cs, result: r} =
42− Loop {current: cs, result: snoc r (mkTree (f (nodeValue c)) (tailRec go {current: (nodeChildren c), result: Nil })) }
43−
44−instance applyTree :: Apply Tree where
45− apply (Node {value: f, children: fs}) tx@(Node {value: x, children: xs})
46− = Node {value: (f x), children: ((map <<< map) f xs) <> (map ((flip apply) tx) fs)}
47−
48−instance applicativeTree :: Applicative Tree where
49− pure = (flip $ mkTree) Nil
50−
51−instance bindTree :: Bind Tree where
52− bind tx@(Node {value: x, children: xs}) f =
53− let (Node {value: b, children: bs}) = f x in
54− Node {value: b, children: bs <> (map ((flip bind) f) xs)}
55−
56−instance monadTree :: Monad Tree
57−
58−instance foldableTree :: Foldable Tree where
59− foldMap f (Node {value: x, children: xs}) = (f x) <> (foldMap (foldMap f) xs)
60− foldl f = foldlDefault f
61− foldr f = foldrDefault f
62−
63−instance traversableTree :: Traversable Tree where
64− traverse f (Node {value: x, children: xs}) =
65− lift2 (\a b -> Node {value: a, children: b}) (f x) (traverse (traverse f) xs)
66−
67− sequence x = sequenceDefault x
68−
69−-- Other functions
19+mkTree = mkCofree
7020
7121-- | Draw a 2D `String` representation of a `Tree String`.
7222drawTree :: Tree String -> String
73−drawTree t = tailRec go {level: 0, drawn: (nodeValue t) <> "\n", current: (nodeChildren t)}
23+drawTree t = tailRec go {level: 0, drawn: (head t) <> "\n", current: (tail t)}
7424 where
7525 go :: _ -> Step _ String
7626 go {level: l, drawn: s, current: Nil} = Done s
7727 go {level: l, drawn: s, current: c:cs } =
78− let drawn = (power " " l) <> "|----> " <> (nodeValue c) <> "\n" in
79− Loop {level: l, drawn: s <> drawn <> (tailRec go {level: l + 1, drawn: "", current: (nodeChildren c)}) , current: cs}
28+ let drawn = (power " " l) <> "|----> " <> (head c) <> "\n" in
29+ Loop {level: l, drawn: s <> drawn <> (tailRec go {level: l + 1, drawn: "", current: (tail c)}) , current: cs}
8030
8131-- | Draw a 2D `String` representation of a `Tree` composed of `Show`able
8232-- | elements.
@@ -86,44 +36,37 @@ showTree = drawTree <<< (map show)
8636-- | Scan a `Tree`, accumulating values of `b` there are constant across `Node`s
8737-- | that have the same parent.
8838scanTree :: forall a b. (a -> b -> b) -> b -> Tree a -> Tree b
89−scanTree f b n@(Node {value: x, children: xs}) =
90− let fb = f x b
91− in fb |> (tailRec go {b: fb, current: xs, final: Nil})
39+scanTree f b n =
40+ let fb = f (head n) b
41+ in fb :< (tailRec go {b: fb, current: (tail n), final: Nil})
9242 where
9343 go :: _ -> Step _ (Forest b)
9444 go {b: b', current: Nil, final: final} = Done final
9545 go {b: b', current: c:cs, final: final} =
96− let fb' = f (nodeValue c) b'
97− in Loop {b: b', current: cs, final: snoc final (fb' |> tailRec go {b: fb', current: (nodeChildren c), final: Nil})}
46+ let fb' = f (head c) b'
47+ in Loop {b: b', current: cs, final: snoc final (fb' :< tailRec go {b: fb', current: (tail c), final: Nil})}
9848
9949-- | Scan a `Tree`, accumulating values of `b` there are constant across `Node`s
10050-- | that have the same parent, and returning a `Tree` of type `c`.
10151scanTreeAccum :: forall a b c. (a -> b -> Accum b c) -> b -> Tree a -> Tree c
102−scanTreeAccum f b n@(Node {value: x, children: xs}) =
103− let fb = f x b
104− in fb.value |> (tailRec go {b: fb.accum , current: xs, final: Nil})
52+scanTreeAccum f b n =
53+ let fb = f (head n) b
54+ in fb.value :< (tailRec go {b: fb.accum , current: (tail n), final: Nil})
10555 where
10656 go :: _ -> Step _ (Forest c)
10757 go {b: b', current: Nil, final: final} = Done final
10858 go {b: b', current: c:cs, final: final} =
109− let fb' = f (nodeValue c) b'
110− in Loop {b: b', current: cs, final: snoc final (fb'.value |> tailRec go {b: fb'.accum, current: (nodeChildren c), final: Nil})}
111−
112−-- Setters and getters
113−nodeValue :: forall a. Tree a -> a
114−nodeValue (Node r) = r.value
115−
116−nodeChildren :: forall a. Tree a -> Forest a
117−nodeChildren (Node r) = r.children
59+ let fb' = f (head c) b'
60+ in Loop {b: b', current: cs, final: snoc final (fb'.value :< tailRec go {b: fb'.accum, current: (tail c), final: Nil})}
11861
62+-- | Set the value of a node.
11963setNodeValue :: forall a. a -> Tree a -> Tree a
120−setNodeValue a (Node r) = Node r { value = a }
64+setNodeValue a n = a :< (tail n)
12165
66+-- | Modify the value of a node.
12267modifyNodeValue :: forall a. (a -> a) -> Tree a -> Tree a
123−modifyNodeValue f (Node r) = Node r { value = f r.value }
68+modifyNodeValue f n = f (head n) :< tail n
12469
70+-- | Append a child to a node.
12571appendChild :: forall a. Tree a -> Tree a -> Tree a
126−appendChild n (Node r) = Node r { children = snoc r.children n }
127−
128−setChildren :: forall a. Forest a -> Tree a -> Tree a
129−setChildren cs (Node r) = Node r { children = cs }
72+appendChild c n = head n :< snoc (tail n) c