git.iko.soy/rowtype-yoga/purescript-yoga-tree
on master help sign in
Back Trees by Arrays
commitedbc26333e1956819b8c834c34a509c56a26a5e0 authorMark Eibes <mark.eibes@gmail.com> dateMon 29 Aug 2022, 10:54 (4 years ago) parent8c63cbe
10 files changed+660−711
compare with master
unifiedsplit
package.json+3−3 packages.dhall+2−2 spago.dhall+2−1 src/Data/Tree.purs−104 src/Data/Tree/Zipper.purs−297 src/Yoga/Tree.purs+92 src/Yoga/Tree/Zipper.purs+333 test.dhall+19−3 test/Example.purs+24−42 test/Main.purs+185−259
package.json+3−3
@@ -1,8 +1,8 @@
11{
2− "name": "purescript-tree",
2+ "name": "purescript-yoga-tree",
33 "version": "4.0.0",
4− "description": "A Tree data structure inspired by haskell's Data.Tree",
4+ "description": "A Tree data structure inspired by Haskell's Data.Tree",
55 "main": "index.js",
66 "author": "Daniel Fortes",
77 "license": "MIT"
8−}
8+}
packages.dhall+2−2
@@ -1,5 +1,5 @@
11let upstream =
2− https://github.com/purescript/package-sets/releases/download/psc-0.14.5-20220203/packages.dhall
3− sha256:f8905bf5d7ce9d886cf4ef1c5893ab55de0b30c82c2b4137f272d075000fbc50
2+ https://github.com/purescript/package-sets/releases/download/psc-0.15.4-20220822/packages.dhall
3+ sha256:908b4ffbfba37a0a4edf806513a555d0dbcdd0cde7abd621f8d018d2e8ecf828
44
55in upstream
spago.dhall+2−1
@@ -3,7 +3,8 @@
33, repository = "https://github.com/jordanmartinez/purescript-tree-rose"
44, name = "tree-rose"
55, dependencies =
6− [ "control"
6+ [ "arrays"
7+ , "control"
78 , "foldable-traversable"
89 , "free"
910 , "lists"
src/Data/Tree.pursdeleted−104
@@ -1,104 +0,0 @@
1−module Data.Tree where
2−
3−import Prelude
4−
5−import Control.Comonad.Cofree (Cofree, head, mkCofree, tail, (:<))
6−import Control.Monad.Rec.Class (Step(..), tailRec)
7−import Data.List (List(..), snoc, (:))
8−import Data.Monoid (power)
9−import Data.Traversable (Accum)
10−
11−-- | A Rose, or multi-way tree, with values of type `a`. To access the
12−-- | root of the Tree's value, use `Control.Comonad.Cofree (head)`. To
13−-- | access the root's children, use `Control.Comonad.Cofree (tail)`
14−type Tree a = Cofree List a
15−
16−-- | A type alias for the children of a Tree's root value.
17−type Forest a = List (Tree a)
18−
19−-- | Create a `Tree` from a `Node` value of type `a` and a `Forest` of children.
20−mkTree :: forall a. a -> Forest a -> Tree a
21−mkTree = mkCofree
22−
23−-- | Draw a 2D `String` representation of a `Tree String`.
24−drawTree :: Tree String -> String
25−drawTree = drawTree' 0
26−
27−-- | Draw a 2D `String` representation of a `Tree String`,
28−-- | starting the indent at the given level
29−drawTree' :: Int -> Tree String -> String
30−drawTree' level t = do
31− let
32− treeRoot = (power " " level) <> "|----> " <> (head t) <> "\n"
33− treeChildren = drawForest' (level + 1) (tail t)
34− treeRoot <> treeChildren
35−
36−-- | Draw a 2D `String` representation of a `Forest String`,
37−drawForest :: Forest String -> String
38−drawForest = drawForest' 0
39−
40−-- | Draw a 2D `String` representation of a `Forest String`,
41−-- | starting the indent at the given level
42−drawForest' :: Int -> Forest String -> String
43−drawForest' level forest = tailRec goForest { level: level, drawn: "", current: forest }
44− where
45− goForest
46− :: { current :: Forest String, drawn :: String, level :: Int }
47− -> Step { current :: Forest String, drawn :: String, level :: Int } String
48− goForest { drawn: s, current: Nil } = Done s
49− goForest { level: l, drawn: s, current: c : cs } = do
50− let
51− drawnTree = drawTree' l c
52− Loop { level: l, drawn: s <> drawnTree, current: cs }
53−
54−-- | Draw a 2D `String` representation of a `Tree` composed of `Show`able
55−-- | elements.
56−showTree :: forall a. Show a => Tree a -> String
57−showTree tree = drawTree (show <$> tree)
58−
59−-- | Draw a 2D `String` representation of a `Forest` composed of `Show`able
60−-- | elements.
61−showForest :: forall a. Show a => Forest a -> String
62−showForest forest = drawForest ((\tree -> show <$> tree) <$> forest)
63−
64−-- | Scan a `Tree`, accumulating values of `b` there are constant across `Node`s
65−-- | that have the same parent.
66−scanTree :: forall a b. (a -> b -> b) -> b -> Tree a -> Tree b
67−scanTree f b n = do
68− let
69− fb = f (head n) b
70− fb :< (tailRec go { b: fb, current: (tail n), final: Nil })
71− where
72− go :: { final :: Forest b, current :: Forest a, b :: b } -> Step { final :: Forest b, current :: Forest a, b :: b } (Forest b)
73− go { current: Nil, final: final } = Done final
74− go { b: b', current: c : cs, final: final } = do
75− let
76− fb' = f (head c) b'
77− Loop { b: b', current: cs, final: snoc final (fb' :< tailRec go { b: fb', current: (tail c), final: Nil }) }
78−
79−-- | Scan a `Tree`, accumulating values of `b` there are constant across `Node`s
80−-- | that have the same parent, and returning a `Tree` of type `c`.
81−scanTreeAccum :: forall a b c. (a -> b -> Accum b c) -> b -> Tree a -> Tree c
82−scanTreeAccum f b n = do
83− let
84− fb = f (head n) b
85− fb.value :< (tailRec go { b: fb.accum, current: (tail n), final: Nil })
86− where
87− go :: { final :: Forest c, current :: Forest a, b :: b } -> Step { final :: Forest c, current :: Forest a, b :: b } (Forest c)
88− go { current: Nil, final: final } = Done final
89− go { b: b', current: c : cs, final: final } = do
90− let
91− fb' = f (head c) b'
92− Loop { b: b', current: cs, final: snoc final (fb'.value :< tailRec go { b: fb'.accum, current: (tail c), final: Nil }) }
93−
94−-- | Set the value of a node.
95−setNodeValue :: forall a. a -> Tree a -> Tree a
96−setNodeValue a n = a :< (tail n)
97−
98−-- | Modify the value of a node.
99−modifyNodeValue :: forall a. (a -> a) -> Tree a -> Tree a
100−modifyNodeValue f n = f (head n) :< tail n
101−
102−-- | Append a child to a node.
103−appendChild :: forall a. Tree a -> Tree a -> Tree a
104−appendChild c n = head n :< snoc (tail n) c
src/Data/Tree/Zipper.pursdeleted−297
@@ -1,297 +0,0 @@
1−module Data.Tree.Zipper where
2−
3−import Prelude
4−
5−import Control.Alt ((<|>))
6−import Control.Comonad.Cofree (head, tail, (:<))
7−import Data.List (List(Nil), drop, reverse, take, (!!), (:))
8−import Data.Maybe (Maybe(Just, Nothing))
9−import Data.Tree (Forest, Tree, mkTree, modifyNodeValue, setNodeValue)
10−
11−-- | The `Loc` type describes the location of a `Node` inside a `Tree`. For this
12−-- | we store the current `Node`, the sibling nodes that appear before the current
13−-- | node, the sibling nodes that appear after the current node, and a `List` of
14−-- | `Loc`ations that store the parent node locations up to the root of the three.
15−-- |
16−-- | So, effectively, the `parents` field records the path travelled in the
17−-- | tree to reach the level of the current `Node` starting from the tree's root,
18−-- | and the `before` and `after` fields describe its location in the current
19−-- | level.
20−newtype Loc a = Loc
21− { node :: Tree a
22− , before :: Forest a
23− , after :: Forest a
24− , parents :: List (Loc a)
25− }
26−
27−derive newtype instance eqLoc :: Eq a => Eq (Loc a)
28−
29−-- -- Cursor movement
30−
31−-- | Move the cursor to the next sibling.
32−next :: forall a. Loc a -> Maybe (Loc a)
33−next (Loc r) =
34− case r.after of
35− Nil -> Nothing
36− (c : cs) -> Just $ Loc r
37− { node = c
38− , before = r.node : r.before
39− , after = cs
40− }
41−
42−-- -- | Move the cursor to the previous sibling.
43−prev :: forall a. Loc a -> Maybe (Loc a)
44−prev (Loc r) =
45− case r.before of
46− Nil -> Nothing
47− (c : cs) -> Just $ Loc r
48− { node = c
49− , before = cs
50− , after = r.node : r.after
51− }
52−
53−-- -- | Move the cursor to the first sibling.
54−first :: forall a. Loc a -> Loc a
55−first l@(Loc r) =
56− case reverse r.before of
57− Nil -> l
58− c : cs -> Loc r
59− { node = c
60− , before = Nil
61− , after = cs <> r.after
62− }
63−
64−-- -- | Move the cursor to the last sibling.
65−last :: forall a. Loc a -> Loc a
66−last l@(Loc r) =
67− case reverse r.after of
68− Nil -> l
69− c : cs -> Loc r
70− { node = c
71− , before = cs <> (r.node : r.before)
72− , after = Nil
73− }
74−
75−-- -- | Move the cursor to the parent `Node`.
76−up :: forall a. Loc a -> Maybe (Loc a)
77−up l@(Loc r) =
78− case r.parents of
79− Nil -> Nothing
80− (p : ps) -> Just $ Loc
81− { node: (value p) :< (siblings l)
82− , before: before p
83− , after: after p
84− , parents: ps
85− }
86−
87−-- | Move the cursor to the root of the tree.
88−root :: forall a. Loc a -> Loc a
89−root l =
90− case up l of
91− Nothing -> l
92− Just p -> root p
93−
94−-- | Move the cursor to the first child of the current `Node`.
95−firstChild :: forall a. Loc a -> Maybe (Loc a)
96−firstChild n =
97− case children n of
98− Nil -> Nothing
99− c : cs ->
100− Just $ Loc
101− { node: c
102− , before: Nil
103− , after: cs
104− , parents: n : (parents n)
105− }
106−
107−-- | Move the cursor to the first child of the current `Node`.
108−down :: forall a. Loc a -> Maybe (Loc a)
109−down = firstChild
110−
111−-- | Move the cursor to the last child of the current `Node`.
112−lastChild :: forall a. Loc a -> Maybe (Loc a)
113−lastChild n =
114− case reverse (children n) of
115− Nil -> Nothing
116− c : cs ->
117− Just $ Loc
118− { node: c
119− , before: cs
120− , after: Nil
121− , parents: n : (parents n)
122− }
123−
124−-- | Move the cursor to a specific sibling by it's index.
125−siblingAt :: forall a. Int -> Loc a -> Maybe (Loc a)
126−siblingAt i l@(Loc r) = do
127− p <- up l
128− c <- (children p) !! i
129− let before' = reverse $ take i (children p)
130− let after' = drop (i + 1) (children p)
131− pure $ Loc
132− { node: c
133− , before: before'
134− , after: after'
135− , parents: r.parents
136− }
137−
138−-- | Move the cursor to a specific child of the current `Node` by it's index.
139−childAt :: forall a. Int -> Loc a -> Maybe (Loc a)
140−childAt i p = (firstChild p) >>= (siblingAt i)
141−
142−-- | Retrieve the `Tree` representation, i.e., returns the root `Node` of the
143−-- | current tree.
144−toTree :: forall a. Loc a -> Tree a
145−toTree = node <<< root
146−
147−-- | Get a `Loc`ation representation from a given `Tree`.
148−fromTree :: forall a. Tree a -> Loc a
149−fromTree n = Loc
150− { node: n
151− , before: Nil
152− , after: Nil
153− , parents: Nil
154− }
155−
156−-- | Set the `Node` at the current position.
157−setNode :: forall a. Tree a -> Loc a -> Loc a
158−setNode a (Loc r) = Loc r { node = a }
159−
160−-- | Set the `Node` at the current position.
161−modifyNode :: forall a. (Tree a -> Tree a) -> Loc a -> Loc a
162−modifyNode f (Loc r) = Loc r { node = f r.node }
163−
164−-- | Set the value of the current `Node`.
165−setValue :: forall a. a -> Loc a -> Loc a
166−setValue a l = setNode (setNodeValue a (node l)) l
167−
168−-- | Modify the value of the current `Node`.
169−modifyValue :: forall a. (a -> a) -> Loc a -> Loc a
170−modifyValue f l = setNode (modifyNodeValue f (node l)) l
171−
172−-- -- insert and delete nodes
173−
174−-- | Insert a node after the current position, and move cursor to the new node.
175−insertAfter :: forall a. Tree a -> Loc a -> Loc a
176−insertAfter n (Loc r) = Loc r
177− { node = n
178− , before = r.node : r.before
179− }
180−
181−-- | Insert a node before the current position, and move cursor to the new node.
182−insertBefore :: forall a. Tree a -> Loc a -> Loc a
183−insertBefore n (Loc r) = Loc r
184− { node = n
185− , after = r.node : r.after
186− }
187−
188−-- | Insert a node as a child to the current node, and move cursor to the new node.
189−insertChild :: forall a. Tree a -> Loc a -> Loc a
190−insertChild n l =
191− case down l of
192− Just c -> insertAfter n c
193− Nothing -> Loc
194− { node: n
195− , after: Nil
196− , before: Nil
197− , parents: l : (parents l)
198− }
199−
200−-- | Delete the node in the current position.
201−delete :: forall a. Loc a -> Loc a
202−delete l@(Loc r) =
203− case r.after of
204− c : cs -> Loc r
205− { node = c
206− , after = cs
207− }
208− Nil ->
209− case r.before of
210− c : cs -> Loc r
211− { node = c
212− , before = cs
213− }
214− Nil ->
215− case r.parents of
216− Nil -> l
217− c : _ -> Loc
218− { node: mkTree (value c) Nil
219− , before: before c
220− , after: after c
221− , parents: parents c
222− }
223−
224−-- Searches
225−
226−-- | Search down and to the right for the first occurence where the given predicate is true and return the Loc
227−findDownWhere :: ∀ a. (a -> Boolean) -> Loc a -> Maybe (Loc a)
228−findDownWhere predicate loc | predicate $ value loc = Just loc
229−findDownWhere predicate loc = lookNext <|> lookDown
230− where
231− lookNext = next loc >>= findDownWhere predicate
232− lookDown = down loc >>= findDownWhere predicate
233−
234−-- | Search for the first occurence of the value `a` downwards and to the right.
235−findDown :: forall a. Eq a => a -> Loc a -> Maybe (Loc a)
236−findDown a = findDownWhere (_ == a)
237−
238−-- | Search to the left and up for the first occurence where the given predicate is true and return the Loc
239−findUpWhere :: ∀ a. (a -> Boolean) -> Loc a -> Maybe (Loc a)
240−findUpWhere predicate loc | predicate $ value loc = Just loc
241−findUpWhere predicate loc = lookPrev <|> lookUp
242− where
243− lookPrev = prev loc >>= findUpWhere predicate
244− lookUp = up loc >>= findUpWhere predicate
245−
246−-- | Search for the first occurence of the value `a` upwards and to the left,
247−findUp :: forall a. Eq a => a -> Loc a -> Maybe (Loc a)
248−findUp a = findUpWhere (_ == a)
249−
250−-- | Search from the root of the tree for the first occurrence where the given predicate is truen and return the Loc
251−findFromRootWhere :: ∀ a. (a -> Boolean) -> Loc a -> Maybe (Loc a)
252−findFromRootWhere predicate loc | predicate $ value loc = Just loc
253−findFromRootWhere predicate loc = findDownWhere predicate $ root loc
254−
255−-- | Search for the first occurence of the value `a` starting from the root of
256−-- | the tree.
257−findFromRoot :: forall a. Eq a => a -> Loc a -> Maybe (Loc a)
258−findFromRoot a = findFromRootWhere (_ == a)
259−
260−-- | flattens the Tree into a List depth first.
261−flattenLocDepthFirst :: ∀ a. Loc a -> List (Loc a)
262−flattenLocDepthFirst loc = loc : (go loc)
263− where
264− go :: Loc a -> List (Loc a)
265− go loc' =
266− let
267− downs = goDir loc' down
268− nexts = goDir loc' next
269− in
270− downs <> nexts
271−
272− goDir :: Loc a -> (Loc a -> Maybe (Loc a)) -> List (Loc a)
273− goDir loc' dirFn = case (dirFn loc') of
274− Just l -> l : go l
275− Nothing -> Nil
276−
277−-- Setters and Getters
278−node :: forall a. Loc a -> Tree a
279−node (Loc r) = r.node
280−
281−value :: forall a. Loc a -> a
282−value = head <<< node
283−
284−before :: forall a. Loc a -> Forest a
285−before (Loc r) = r.before
286−
287−after :: forall a. Loc a -> Forest a
288−after (Loc r) = r.after
289−
290−parents :: forall a. Loc a -> List (Loc a)
291−parents (Loc r) = r.parents
292−
293−children :: forall a. Loc a -> Forest a
294−children = tail <<< node
295−
296−siblings :: forall a. Loc a -> Forest a
297−siblings (Loc r) = (reverse r.before) <> (r.node : r.after)
src/Yoga/Tree.pursnew file+92
@@ -0,0 +1,92 @@
1+module Yoga.Tree where
2+
3+import Prelude
4+import Control.Comonad.Cofree (Cofree, head, mkCofree, tail, (:<))
5+import Control.Monad.Rec.Class (Step(..), tailRec)
6+import Data.Array (snoc, uncons)
7+import Data.Maybe (Maybe(..))
8+import Data.Monoid (power)
9+import Data.Traversable (Accum)
10+
11+-- | A Rose, or multi-way tree, with values of type `a`.
12+type Tree a =
13+ Cofree Array a
14+
15+type Forest a =
16+ Array (Tree a)
17+
18+-- | Create a `Tree` from a `Node` value of type `a` and a `Forest` of children.
19+mkTree ∷ ∀ a. a -> Forest a -> Tree a
20+mkTree = mkCofree
21+
22+mkLeaf ∷ ∀ a. a -> Tree a
23+mkLeaf = flip mkTree []
24+
25+leaf :: forall a. a -> Tree a
26+leaf = mkLeaf
27+
28+-- | Draw a 2D `String` representation of a `Tree String`.
29+drawTree ∷ Tree String -> String
30+drawTree t = tailRec go { level: 0, drawn: (head t) <> "\n", current: (tail t) }
31+ where
32+ go ∷ { current ∷ Forest String, drawn ∷ String, level ∷ Int } -> Step { current ∷ Forest String, drawn ∷ String, level ∷ Int } String
33+ go x = case x { current = uncons x.current } of
34+ { drawn: s, current: Nothing } -> Done s
35+ { level: l, drawn: s, current: Just { head: c, tail: cs } } ->
36+ let
37+ drawn = (power " " l) <> "|----> " <> (head c) <> "\n"
38+ in
39+ Loop { level: l, drawn: s <> drawn <> (tailRec go { level: l + 1, drawn: "", current: (tail c) }), current: cs }
40+
41+-- | Draw a 2D `String` representation of a `Tree` composed of `Show`able
42+-- | elements.
43+showTree ∷ ∀ a. Show a => Tree a -> String
44+showTree = drawTree <<< (map show)
45+
46+-- | Scan a `Tree`, accumulating values of `b` there are constant across `Node`s
47+-- | that have the same parent.
48+scanTree ∷ ∀ a b. (a -> b -> b) -> b -> Tree a -> Tree b
49+scanTree f b n =
50+ let
51+ fb = f (head n) b
52+ in
53+ fb :< (tailRec go { b: fb, current: (tail n), final: [] })
54+ where
55+ go ∷ { final ∷ Forest b, current ∷ Forest a, b ∷ b } -> Step { final ∷ Forest b, current ∷ Forest a, b ∷ b } (Forest b)
56+ go x = case x { current = uncons x.current } of
57+ { current: Nothing, final } -> Done final
58+ { b: b', current: Just { head: c, tail: cs }, final } ->
59+ let
60+ fb' = f (head c) b'
61+ in
62+ Loop { b: b', current: cs, final: snoc final (fb' :< tailRec go { b: fb', current: (tail c), final: [] }) }
63+
64+-- | Scan a `Tree`, accumulating values of `b` there are constant across `Node`s
65+-- | that have the same parent, and returning a `Tree` of type `c`.
66+scanTreeAccum ∷ ∀ a b c. (a -> b -> Accum b c) -> b -> Tree a -> Tree c
67+scanTreeAccum f b n =
68+ let
69+ fb = f (head n) b
70+ in
71+ fb.value :< (tailRec go { b: fb.accum, current: (tail n), final: [] })
72+ where
73+ go ∷ { final ∷ Forest c, current ∷ Forest a, b ∷ b } -> Step { final ∷ Forest c, current ∷ Forest a, b ∷ b } (Forest c)
74+ go x = case (x { current = uncons x.current }) of
75+ { current: Nothing, final } -> Done final
76+ { b: b', current: Just { head: c, tail: cs }, final } ->
77+ let
78+ fb' = f (head c) b'
79+ in
80+ Loop { b: b', current: cs, final: snoc final (fb'.value :< tailRec go { b: fb'.accum, current: (tail c), final: [] }) }
81+
82+-- | Set the value of a node.
83+setNodeValue ∷ ∀ a. a -> Tree a -> Tree a
84+setNodeValue a n = a :< (tail n)
85+
86+-- | Modify the value of a node.
87+modifyNodeValue ∷ ∀ a. (a -> a) -> Tree a -> Tree a
88+modifyNodeValue f n = f (head n) :< tail n
89+
90+-- | Append a child to a node.
91+appendChild ∷ ∀ a. Tree a -> Tree a -> Tree a
92+appendChild c n = head n :< snoc (tail n) c
src/Yoga/Tree/Zipper.pursnew file+333
@@ -0,0 +1,333 @@
1+module Yoga.Tree.Zipper where
2+
3+import Prelude
4+import Control.Alt ((<|>))
5+import Control.Comonad.Cofree (head, tail, (:<))
6+import Data.Array (drop, reverse, take, uncons, (!!), (:))
7+import Data.Maybe (Maybe(Just, Nothing))
8+import Yoga.Tree (Forest, Tree, mkTree, modifyNodeValue, setNodeValue)
9+
10+-- | The `Loc` type describes the location of a `Node` inside a `Tree`. For this
11+-- | we store the current `Node`, the sibling nodes that appear before the current
12+-- | node, the sibling nodes that appear after the current node, and a `Array` of
13+-- | `Loc`ations that store the parent node locations up to the root of the three.
14+-- |
15+-- | So, effectively, the `parents` field records the path travelled in the
16+-- | tree to reach the level of the current `Node` starting from the tree's root,
17+-- | and the `before` and `after` fields describe its location in the current
18+-- | level.
19+newtype Loc a = Loc
20+ { node ∷ Tree a
21+ , before ∷ Forest a
22+ , after ∷ Forest a
23+ , parents ∷ Array (Loc a)
24+ }
25+
26+instance eqLoc ∷ Eq a => Eq (Loc a) where
27+ eq (Loc r1) (Loc r2) =
28+ (r1.node == r2.node)
29+ && (r1.before == r2.before)
30+ && (r1.after == r2.after)
31+ && (r1.parents == r2.parents)
32+
33+-- -- Cursor movement
34+-- | Move the cursor to the next sibling.
35+next ∷ ∀ a. Loc a -> Maybe (Loc a)
36+next (Loc r) = case uncons r.after of
37+ Nothing -> Nothing
38+ Just { head: c, tail: cs } ->
39+ Just
40+ $ Loc
41+ { node: c
42+ , before: r.node : r.before
43+ , after: cs
44+ , parents: r.parents
45+ }
46+
47+-- -- | Move the cursor to the previous sibling.
48+prev ∷ ∀ a. Loc a -> Maybe (Loc a)
49+prev (Loc r) = case uncons r.before of
50+ Nothing -> Nothing
51+ Just { head: c, tail: cs } ->
52+ Just
53+ $ Loc
54+ { node: c
55+ , before: cs
56+ , after: r.node : r.after
57+ , parents: r.parents
58+ }
59+
60+-- -- | Move the cursor to the first sibling.
61+first ∷ ∀ a. Loc a -> Loc a
62+first l@(Loc r) = case uncons r.before of
63+ Nothing -> l
64+ Just { head: c, tail: cs } ->
65+ Loc
66+ $
67+ { node: c
68+ , before: []
69+ , after: (reverse cs) <> r.after
70+ , parents: r.parents
71+ }
72+
73+-- -- | Move the cursor to the last sibling.
74+last ∷ ∀ a. Loc a -> Loc a
75+last l@(Loc r) = case uncons (reverse r.after) of
76+ Nothing -> l
77+ Just { head: c, tail: cs } ->
78+ Loc
79+ $
80+ { node: c
81+ , before: cs <> r.before
82+ , after: []
83+ , parents: r.parents
84+ }
85+
86+-- -- | Move the cursor to the parent `Node`.
87+up ∷ ∀ a. Loc a -> Maybe (Loc a)
88+up l@(Loc r) = case uncons r.parents of
89+ Nothing -> Nothing
90+ Just { head: p, tail: ps } ->
91+ Just
92+ $ Loc
93+ { node: (value p) :< (siblings l)
94+ , before: before p
95+ , after: after p
96+ , parents: ps
97+ }
98+
99+-- | Move the cursor to the root of the tree.
100+root ∷ ∀ a. Loc a -> Loc a
101+root l = case up l of
102+ Nothing -> l
103+ Just p -> root p
104+
105+-- | Move the cursor to the first child of the current `Node`.
106+firstChild ∷ ∀ a. Loc a -> Maybe (Loc a)
107+firstChild n = case uncons (children n) of
108+ Nothing -> Nothing
109+ Just { head: c, tail: cs } ->
110+ Just
111+ $ Loc
112+ { node: c
113+ , before: []
114+ , after: cs
115+ , parents: n : (parents n)
116+ }
117+
118+-- | Move the cursor to the first child of the current `Node`.
119+down ∷ ∀ a. Loc a -> Maybe (Loc a)
120+down = firstChild
121+
122+-- | Move the cursor to the last child of the current `Node`.
123+lastChild ∷ ∀ a. Loc a -> Maybe (Loc a)
124+lastChild p = last <$> down p
125+
126+-- | Move the cursor to a specific sibling by it's index.
127+siblingAt ∷ ∀ a. Int -> Loc a -> Maybe (Loc a)
128+siblingAt i l@(Loc r) = case up l of
129+ Nothing -> Nothing
130+ Just p -> case (children p) !! i of
131+ Nothing -> Nothing
132+ Just c ->
133+ let
134+ before' = reverse $ take i (children p)
135+ after' = drop (i + 1) (children p)
136+ in
137+ Just
138+ $ Loc
139+ { node: c
140+ , before: before'
141+ , after: after'
142+ , parents: r.parents
143+ }
144+
145+-- | Move the cursor to a specific child of the current `Node` by it's index.
146+childAt ∷ ∀ a. Int -> Loc a -> Maybe (Loc a)
147+childAt i p = (firstChild p) >>= (siblingAt i)
148+
149+-- | Retrieve the `Tree` representation, i.e., returns the root `Node` of the
150+-- | current tree.
151+toTree ∷ ∀ a. Loc a -> Tree a
152+toTree = node <<< root
153+
154+-- | Get a `Loc`ation representation from a given `Tree`.
155+fromTree ∷ ∀ a. Tree a -> Loc a
156+fromTree n =
157+ Loc
158+ { node: n
159+ , before: []
160+ , after: []
161+ , parents: []
162+ }
163+
164+-- | Set the `Node` at the current position.
165+setNode ∷ ∀ a. Tree a -> Loc a -> Loc a
166+setNode a (Loc r) =
167+ Loc
168+ { node: a
169+ , before: r.before
170+ , after: r.after
171+ , parents: r.parents
172+ }
173+
174+-- | Set the `Node` at the current position.
175+modifyNode ∷ ∀ a. (Tree a -> Tree a) -> Loc a -> Loc a
176+modifyNode f (Loc r) =
177+ Loc
178+ { node: f r.node
179+ , before: r.before
180+ , after: r.after
181+ , parents: r.parents
182+ }
183+
184+-- | Set the value of the current `Node`.
185+setValue ∷ ∀ a. a -> Loc a -> Loc a
186+setValue a l = setNode (setNodeValue a (node l)) l
187+
188+-- | Modify the value of the current `Node`.
189+modifyValue ∷ ∀ a. (a -> a) -> Loc a -> Loc a
190+modifyValue f l = setNode (modifyNodeValue f (node l)) l
191+
192+-- -- insert and delete nodes
193+-- | Insert a node after the current position, and move cursor to the new node.
194+insertAfter ∷ ∀ a. Tree a -> Loc a -> Loc a
195+insertAfter n l =
196+ Loc
197+ { node: n
198+ , after: after l
199+ , before: (node l) : (before l)
200+ , parents: parents l
201+ }
202+
203+-- | Insert a node before the current position, and move cursor to the new node.
204+insertBefore ∷ ∀ a. Tree a -> Loc a -> Loc a
205+insertBefore n l =
206+ Loc
207+ { node: n
208+ , after: (node l) : (after l)
209+ , before: before l
210+ , parents: parents l
211+ }
212+
213+-- | Insert a node as a child to the current node, and move cursor to the new node.
214+insertChild ∷ ∀ a. Tree a -> Loc a -> Loc a
215+insertChild n l = case down l of
216+ Just c -> insertAfter n c
217+ Nothing ->
218+ Loc
219+ { node: n
220+ , after: []
221+ , before: []
222+ , parents: l : (parents l)
223+ }
224+
225+-- | Delete the node in the current position.
226+delete ∷ ∀ a. Loc a -> Loc a
227+delete l@(Loc r) = case uncons r.after of
228+ Just { head: c, tail: cs } ->
229+ Loc
230+ { node: c
231+ , before: r.before
232+ , after: cs
233+ , parents: r.parents
234+ }
235+ Nothing -> case uncons r.before of
236+ Just { head: c, tail: cs } ->
237+ Loc
238+ { node: c
239+ , before: cs
240+ , after: r.after
241+ , parents: r.parents
242+ }
243+ Nothing -> case uncons r.parents of
244+ Nothing -> l
245+ Just { head: c } ->
246+ Loc
247+ { node: mkTree (value c) []
248+ , before: before c
249+ , after: after c
250+ , parents: parents c
251+ }
252+
253+-- Searches
254+-- | Search down and to the right for the first occurence where the given predicate is true and return the Loc
255+findDownWhere ∷ ∀ a. (a -> Boolean) -> Loc a -> Maybe (Loc a)
256+findDownWhere predicate loc
257+ | predicate $ value loc = Just loc
258+
259+findDownWhere predicate loc = lookNext <|> lookDown
260+ where
261+ lookNext = next loc >>= findDownWhere predicate
262+
263+ lookDown = down loc >>= findDownWhere predicate
264+
265+-- | Search for the first occurence of the value `a` downwards and to the right.
266+findDown ∷ ∀ a. Eq a => a -> Loc a -> Maybe (Loc a)
267+findDown a = findDownWhere (_ == a)
268+
269+-- | Search to the left and up for the first occurence where the given predicate is true and return the Loc
270+findUpWhere ∷ ∀ a. (a -> Boolean) -> Loc a -> Maybe (Loc a)
271+findUpWhere predicate loc
272+ | predicate $ value loc = Just loc
273+
274+findUpWhere predicate loc = lookPrev <|> lookUp
275+ where
276+ lookPrev = prev loc >>= findUpWhere predicate
277+
278+ lookUp = up loc >>= findUpWhere predicate
279+
280+-- | Search for the first occurence of the value `a` upwards and to the left,
281+findUp ∷ ∀ a. Eq a => a -> Loc a -> Maybe (Loc a)
282+findUp a = findUpWhere (_ == a)
283+
284+-- | Search from the root of the mkTree for the first occurrence where the given predicate is truen and return the Loc
285+findFromRootWhere ∷ ∀ a. (a -> Boolean) -> Loc a -> Maybe (Loc a)
286+findFromRootWhere predicate loc
287+ | predicate $ value loc = Just loc
288+
289+findFromRootWhere predicate loc = findDownWhere predicate $ root loc
290+
291+-- | Search for the first occurence of the value `a` starting from the root of
292+-- | the tree.
293+findFromRoot ∷ ∀ a. Eq a => a -> Loc a -> Maybe (Loc a)
294+findFromRoot a = findFromRootWhere (_ == a)
295+
296+-- | flattens the Tree into a Array depth first.
297+flattenLocDepthFirst ∷ ∀ a. Loc a -> Array (Loc a)
298+flattenLocDepthFirst loc = loc : (go loc)
299+ where
300+ go ∷ Loc a -> Array (Loc a)
301+ go loc' =
302+ let
303+ downs = goDir loc' down
304+ nexts = goDir loc' next
305+ in
306+ downs <> nexts
307+
308+ goDir ∷ Loc a -> (Loc a -> Maybe (Loc a)) -> Array (Loc a)
309+ goDir loc' dirFn = case (dirFn loc') of
310+ Just l -> l : go l
311+ Nothing -> []
312+
313+-- Setters and Getters
314+node ∷ ∀ a. Loc a -> Tree a
315+node (Loc r) = r.node
316+
317+value ∷ ∀ a. Loc a -> a
318+value = head <<< node
319+
320+before ∷ ∀ a. Loc a -> Forest a
321+before (Loc r) = r.before
322+
323+after ∷ ∀ a. Loc a -> Forest a
324+after (Loc r) = r.after
325+
326+parents ∷ ∀ a. Loc a -> Array (Loc a)
327+parents (Loc r) = r.parents
328+
329+children ∷ ∀ a. Loc a -> Forest a
330+children = tail <<< node
331+
332+siblings ∷ ∀ a. Loc a -> Forest a
333+siblings (Loc r) = (reverse r.before) <> (r.node : r.after)
test.dhall+19−3
@@ -1,4 +1,20 @@
11let config = ./spago.dhall
2−in config // { sources = config.sources # [ "test/**/*.purs" ]
3− , dependencies = [ "console", "spec" ]
4− }
2+
3+in config
4+ // { sources = config.sources # [ "test/**/*.purs" ]
5+ , dependencies =
6+ [ "console"
7+ , "spec"
8+ , "aff"
9+ , "arrays"
10+ , "control"
11+ , "effect"
12+ , "foldable-traversable"
13+ , "free"
14+ , "lists"
15+ , "maybe"
16+ , "partial"
17+ , "prelude"
18+ , "tailrec"
19+ ]
20+ }
test/Example.purs+24−42
@@ -2,15 +2,15 @@ module Test.Example where
22
33import Prelude
44
5−import Control.Comonad.Cofree (Cofree, head, mkCofree, tail, (:<))
5+import Control.Comonad.Cofree (head, tail, (:<))
66import Control.Monad.Rec.Class (Step(..), tailRec)
7−import Data.List.Types (List(..), (:))
8−import Data.Maybe (Maybe, maybe)
7+import Data.Array (uncons)
8+import Data.Maybe (Maybe(..), maybe)
99import Data.Monoid (power)
10−import Data.Tree (Tree)
11−import Data.Tree.Zipper (fromTree, toTree, modifyValue, down, next, root)
1210import Effect (Effect)
1311import Effect.Console (log)
12+import Yoga.Tree (Tree, mkLeaf)
13+import Yoga.Tree.Zipper (fromTree, toTree, modifyValue, down, next, root)
1414
1515-- Serves only to make this file runnable
1616main :: Effect Unit
@@ -30,45 +30,26 @@ main = do
3030
3131-- These examples show how to create a Tree
3232rootOnly_mkCoFree :: Tree String
33−rootOnly_mkCoFree = mkCofree "root" Nil
33+rootOnly_mkCoFree = mkLeaf "root"
3434
3535rootOnly_alias :: Tree String
36−rootOnly_alias = "root" :< Nil -- `:<` is the alias for `mkCofree`
36+rootOnly_alias = "root" :< [] -- `:<` is the alias for `mkCofree`
3737
3838rootWithLeaves :: Tree String
3939rootWithLeaves =
4040 "root" :<
41− ( ( "leaf" :< Nil )
42− : ( "leaf" :< Nil )
43− : ( "leaf" :< Nil )
44− : Nil
45− )
41+ []
4642
4743rootWithBranchesAndLeaves :: Tree String
4844rootWithBranchesAndLeaves =
49− "1" :<
50− ( ( "1.1" :<
51− ( ( "1.1.1" :< Nil )
52− : ( "1.1.2" :< Nil )
53− : Nil
54− )
55− )
56− : ( "1.2" :< Nil )
57− : ( "1.3" :<
58− ( ( "1.3.1" :< Nil )
59− : ( "1.3.2" :< Nil )
60− : Nil
61− )
62− )
63− : Nil
64− )
45+ "1" :< []
6546
6647-- In our code, we will need to iterate through a Tree and do something
6748-- with each of its contents. Such a function has already been done
6849-- via `drawTree`, which iterates through a tree's contents
6950-- and converts it into a String, indenting them according to their respective
7051-- level:
71−-- https://github.com/dmbfm/purescript-tree/blob/v1.3.2/src/Data/Tree.purs#L21-L21
52+-- https://github.com/dmbfm/purescript-tree/blob/v1.3.2/src/Yoga/Tree.purs#L21-L21
7253
7354-- The below example is a reproduction of the above code but differs from
7455-- it in that the names are more clearly defined to make it easier to see
@@ -82,19 +63,20 @@ drawTree' tree =
8263 in
8364 tailRec go {level: 1, result: root <> "\n", current: children }
8465 where
85− go :: { level :: Int, result :: String, current :: List (Cofree List String) }
86− -> Step { level :: Int, result :: String, current :: List (Cofree List String) } String
87− go {level: l, result: s, current: Nil } = Done s
88− go rec@{level: l, result: s, current: (Cons thisTree remainingTrees) } =
89− let
90− levelRoot = head thisTree
91− levelChildren = tail thisTree
92− content = (power " " l) <> levelRoot <> "\n"
93− in Loop
94− rec { current = remainingTrees
95− , result = rec.result <> content <>
96− (tailRec go { level: l + 1, result: "", current: levelChildren })
97− }
66+ go :: { level :: Int, result :: String, current :: Array (Tree String) }
67+ -> Step { level :: Int, result :: String, current :: Array (Tree String) } String
68+ go rec@{level: l, result: s, current } =
69+ case uncons current of
70+ Nothing -> Done s
71+ Just { head: thisTree, tail: remainingTrees } -> do
72+ let levelRoot = head thisTree
73+ let levelChildren = tail thisTree
74+ let content = (power " " l) <> levelRoot <> "\n"
75+ Loop
76+ rec { current = remainingTrees
77+ , result = rec.result <> content <>
78+ (tailRec go { level: l + 1, result: "", current: levelChildren })
79+ }
9880
9981
10082-- Since we'll also be using the Zipper for the Tree (the `Loc` type),
test/Main.purs+185−259
@@ -3,10 +3,7 @@ module Test.Main where
33import Prelude
44
55import Control.Comonad.Cofree (head, (:<))
6−import Data.List (List(Nil), (:))
76import Data.Maybe (Maybe(..), fromJust)
8−import Data.Tree (Tree, mkTree, scanTree)
9−import Data.Tree.Zipper (down, findDownWhere, findFromRoot, findUp, flattenLocDepthFirst, fromTree, insertAfter, modifyValue, next, toTree, value, firstChild, lastChild)
107import Effect (Effect)
118import Effect.Aff (launchAff_)
129import Partial.Unsafe (unsafePartial)
@@ -14,58 +11,63 @@ import Test.Spec (describe, it)
1411import Test.Spec.Assertions (shouldEqual)
1512import Test.Spec.Reporter (consoleReporter)
1613import Test.Spec.Runner (runSpec)
14+import Yoga.Tree (Tree, leaf, scanTree, showTree)
15+import Yoga.Tree.Zipper (down, findDownWhere, findFromRoot, findUp, flattenLocDepthFirst, fromTree, modifyValue, next, toTree, value)
16+
17+newtype SpecTree a = SpecTree (Tree a)
18+
19+instance Show a => Show (SpecTree a) where
20+ show (SpecTree t) = showTree t
21+
22+derive instance (Eq a) => Eq (SpecTree a)
1723
1824sampleTree :: Tree Int
1925sampleTree =
2026 1 :<
21− (2 :< Nil)
22− : (3 :< Nil)
23− : (4 :<
24− (5 :< Nil)
25− : (6 :<
26− (7 :< Nil) : Nil)
27− : (8 :< Nil)
28− : Nil
29− )
30− : Nil
27+ [ leaf 2
28+ , leaf 3
29+ , 4 :<
30+ [ leaf 5
31+ , 6 :< [ leaf 7 ]
32+ , leaf 8
33+ ]
34+
35+ ]
3136
3237main :: Effect Unit
33−main = launchAff_ $ runSpec [consoleReporter] do
38+main = launchAff_ $ runSpec [ consoleReporter ] do
3439 describe "Tree" do
3540
3641 it "mkTree" do
37− let t = mkTree 10 Nil
42+ let t = 10 :< []
3843 shouldEqual (head t) 10
3944
4045 it "Functor" do
41− let result =
42− 2 :<
43− (3 :< Nil)
44− : (4 :< Nil)
45− : (5 :<
46− (6 :< Nil)
47− : (7 :<
48− (8 :< Nil) : Nil)
49− : (9 :< Nil)
50− : Nil
51− )
52− : Nil
53− shouldEqual (eq (((+)1) <$> sampleTree) result) true
46+ let
47+ result = 2 :<
48+ [ leaf 3
49+ , leaf 4
50+ , 5 :<
51+ [ leaf 6
52+ , 7 :< [ leaf 8 ]
53+ , leaf 9
54+ ]
55+ ]
56+ SpecTree (((+) 1) <$> sampleTree) `shouldEqual` SpecTree result
5457
5558 it "scanTree" do
56− let result =
57− 1 :<
58− (3 :< Nil)
59− : (4 :< Nil)
60− : (5 :<
61− (10 :< Nil)
62− : (11 :<
63− (18 :< Nil) : Nil)
64− : (13 :< Nil)
65− : Nil
66− )
67− : Nil
68− shouldEqual (eq (scanTree (\a b -> a + b) 0 sampleTree) result) true
59+ let
60+ result =
61+ 1 :<
62+ [ leaf 3
63+ , leaf 4
64+ , 5 :<
65+ [ leaf 10
66+ , 11 :< [ leaf 18 ]
67+ , leaf 13
68+ ]
69+ ]
70+ SpecTree (scanTree (\a b -> a + b) 0 sampleTree) `shouldEqual` SpecTree result
6971
7072 describe "Zipper" do
7173
@@ -75,221 +77,145 @@ main = launchAff_ $ runSpec [consoleReporter] do
7577
7678 let root' = unsafePartial $ toTree $ modifyValue (\a -> 2 * a) (fromJust $ down root)
7779 let root'' = unsafePartial $ toTree $ modifyValue (\a -> 2 * a) (fromJust $ down >=> next >=> next >=> down $ root)
78− let result =
79− 1 :<
80− (4 :< Nil)
81− : (3 :< Nil)
82− : (4 :<
83− (5 :< Nil)
84− : (6 :<
85− (7 :< Nil) : Nil)
86− : (8 :< Nil)
87− : Nil
88− )
89− : Nil
90−
91− let result' =
92− 1 :<
93− (2 :< Nil)
94− : (3 :< Nil)
95− : (4 :<
96− (10 :< Nil)
97− : (6 :<
98− (7 :< Nil) : Nil)
99− : (8 :< Nil)
100− : Nil
101− )
102− : Nil
103−
104− shouldEqual (eq root' result) true
105− shouldEqual (eq root'' result') true
106−
107− it "Insert" do
108−
109− let root1 = unsafePartial $ toTree $ insertAfter (mkTree 100 Nil) (fromJust $ down root)
110− let root2 = unsafePartial $ toTree $ insertAfter (mkTree 100 Nil) (fromJust $ (down root) >>= next >>= next >>= down >>= next >>= down)
111− let root3 = unsafePartial $ toTree $ insertAfter (mkTree 100 Nil) (fromJust $ (firstChild root))
112− let root4 = unsafePartial $ toTree $ insertAfter (mkTree 100 Nil) (fromJust $ (lastChild root))
113−
114− let result1 =
115− 1 :<
116− (2 :< Nil)
117− : (100 :< Nil)
118− : (3 :< Nil)
119− : (4 :<
120− (5 :< Nil)
121− : (6 :<
122− (7 :< Nil) : Nil)
123− : (8 :< Nil)
124− : Nil
125− )
126− : Nil
127−
128− let result2 =
129− 1 :<
130− (2 :< Nil)
131− : (3 :< Nil)
132− : (4 :<
133− (5 :< Nil)
134− : (6 :<
135− (7 :< Nil)
136− : (100 :< Nil)
137− : Nil)
138− : (8 :< Nil)
139− : Nil
140− )
141− : Nil
142− let result3 =
143− 1 :<
144− (2 :< Nil)
145− : (100 :< Nil)
146− : (3 :< Nil)
147− : (4 :<
148− (5 :< Nil)
149− : (6 :<
150− (7 :< Nil)
151− : Nil
152− )
153− : (8 :< Nil)
154− : Nil
155− )
156− : Nil
157− let result4 =
158− 1 :<
159− (2 :< Nil)
160− : (3 :< Nil)
161− : (4 :<
162− (5 :< Nil)
163− : (6 :<
164− (7 :< Nil) : Nil)
165− : (8 :< Nil)
166− : Nil
167− )
168− : (100 :< Nil)
169− : Nil
170− shouldEqual (eq root1 result1) true
171− shouldEqual (eq root2 result2) true
172− shouldEqual (eq root3 result3) true
173− shouldEqual (eq root4 result4) true
174−
175− it "Should findDownWhere with single node" do
176− let tree = 1 :< Nil
177− let loc = fromTree tree
178− shouldEqual (Just 1) ((findDownWhere (_ == 1) loc) <#> value)
179−
180− it "Should findDownWhere with 2 nodes and 2 levels" do
181− let tree = 1 :<
182− (2 :< Nil)
183− : Nil
184− -- log $ showTree tree
185− let loc = fromTree tree
186− shouldEqual (Just 2) ((findDownWhere (_ == 2) loc) <#> value)
187−
188− it "Should findDownWhere with 3 nodes and 2 levels" do
189− let tree = 1 :<
190− (2 :< Nil)
191− : (3 :< Nil)
192− : Nil
193− -- log $ showTree tree
194− let loc = fromTree tree
195− shouldEqual (Just 3) ((findDownWhere (_ == 3) loc) <#> value)
196−
197− it "Should findDownWhere with 4 nodes and 2 levels" do
198− let tree = 1 :<
199− (2 :< Nil)
200− : (3 :< Nil)
201− : (4 :< Nil)
202− : Nil
203− -- log $ showTree tree
204− let loc = fromTree tree
205− shouldEqual (Just 4) ((findDownWhere (_ == 4) loc) <#> value)
206−
207− it "Should findDownWhere with 5 nodes and 3 levels" do
208− let tree = 1 :<
209− (2 :< Nil)
210− : (3 :< Nil)
211− : (4 :<
212− (5 :< Nil)
213− : Nil)
214− : Nil
215− -- log $ showTree tree
216− let loc = fromTree tree
217− shouldEqual (Just 5) ((findDownWhere (_ == 5) loc) <#> value)
218−
219− it "Should findDownWhere with 6 nodes and 3 levels" do
220− let tree = 1 :<
221− (2 :< Nil)
222− : (3 :< Nil)
223− : (4 :<
224− (5 :< Nil)
225− : (6 :< Nil)
226− : Nil)
227− : Nil
228− -- log $ showTree tree
229− let loc = fromTree tree
230− shouldEqual (Just 6) ((findDownWhere (_ == 6) loc) <#> value)
231−
232− it "Should findDownWhere with 7 nodes and 4 levels" do
233− let tree = 1 :<
234− (2 :< Nil)
235− : (3 :< Nil)
236− : (4 :<
237− (5 :< Nil)
238− : (6 :<
239− (7 :< Nil) : Nil)
240− : Nil)
241− : Nil
242− -- log $ showTree tree
243− let loc = fromTree tree
244− shouldEqual (Just 7) ((findDownWhere (_ == 7) loc) <#> value)
245−
246− it "Should findDownWhere with 8 nodes and 4 levels" do
247− let tree = 1 :<
248− (2 :< Nil)
249− : (3 :< Nil)
250− : (4 :<
251− (5 :< Nil)
252− : (6 :<
253− (7 :< Nil) : Nil)
254− : (8 :< Nil)
255− : Nil)
256− : Nil
257− -- log $ showTree tree
258− let loc = fromTree tree
259− shouldEqual (Just 8) ((findDownWhere (_ == 8) loc) <#> value)
260−
261− it "Should findDownWhere with 8 nodes and 4 levels with a step back" do
262− let tree = 1 :<
263− (2 :< Nil)
264− : (3 :< Nil)
265− : (4 :<
266− (5 :< Nil)
267− : (6 :<
268− (7 :< Nil) : Nil)
269− : (8 :< Nil)
270− : Nil)
271− : Nil
272− -- log $ showTree tree
273− let loc = fromTree tree
274− shouldEqual (Just 7) ((findDownWhere (_ == 7) loc) <#> value)
275−
276− it "Should find 7 from the sampleTree" do
277− shouldEqual (Just 7) (findDownWhere (_ == 7) (fromTree sampleTree) <#> value)
278−
279− it "Should find 8 from the sampleTree (the bottom) and then find 1 (the top) with findUp" do
280− let eight = unsafePartial $ fromJust $ findDownWhere (_ == 8) $ fromTree sampleTree
281− shouldEqual (Just 1) (findUp 1 eight <#> value)
282−
283− it "Should find 8 from the sampleTree (the bottom) but then not find 7 because it would require a downward traversal" do
284− let eight = unsafePartial $ fromJust $ findDownWhere (_ == 8) $ fromTree sampleTree
285− shouldEqual Nothing (findUp 7 eight <#> value)
286−
287− it "Should find 8 from the sampleTree (the bottom) and then find 7 using findFromRoot" do
288− let eight = unsafePartial $ fromJust $ findDownWhere (_ == 8) $ fromTree sampleTree
289− shouldEqual (Just 7) (findFromRoot 7 eight <#> value)
290−
291− it "Should flatten the Tree into a list of locations following a depth first pattern" do
292− let flat = map value $ flattenLocDepthFirst $ fromTree sampleTree
293− --log $ showTree sampleTree
294− --log $ show flat
295− shouldEqual flat (1 : 2 : 3 : 4 : 5 : 6 : 7 : 8 : Nil)
80+
81+ let
82+ result =
83+ 1 :<
84+ [ leaf 4
85+ , leaf 3
86+ , 4 :<
87+ [ leaf 5
88+ , 6 :< [ leaf 7 ]
89+ , leaf 8
90+ ]
91+
92+ ]
93+
94+ let
95+ result' =
96+ 1 :<
97+ [ 2 :< []
98+ , 3 :< []
99+ , 4 :<
100+ [ 10 :< []
101+ , 6 :< [ 7 :< [] ]
102+ , 8 :< []
103+ ]
104+ ]
105+
106+ SpecTree root' `shouldEqual` SpecTree result
107+ SpecTree root'' `shouldEqual` SpecTree result'
108+
109+ -- it "Insert" do
110+
111+ -- let root1 = unsafePartial $ toTree $ insertAfter (mkLeaf 100) (fromJust $ down root)
112+ -- let root2 = unsafePartial $ toTree $ insertAfter (mkLeaf 100) (fromJust $ (down root) >>= next >>= next >>= down >>= next >>= down)
113+ -- let root3 = unsafePartial $ toTree $ insertAfter (mkLeaf 100) (fromJust $ (firstChild root))
114+ -- let root4 = unsafePartial $ toTree $ insertAfter (mkLeaf 100) (fromJust $ (lastChild root))
115+
116+ -- let result1 = 1 :< []
117+ -- let result2 = 1 :< []
118+ -- let result3 = 1 :< []
119+ -- let result4 = 1 :< []
120+ -- shouldEqual (eq root1 result1) true
121+ -- shouldEqual (eq root2 result2) true
122+ -- shouldEqual (eq root3 result3) true
123+ -- shouldEqual (eq root4 result4) true
124+
125+ it "Should findDownWhere with single node" do
126+ let tree = 1 :< []
127+ let loc = fromTree tree
128+ shouldEqual (Just 1) ((findDownWhere (_ == 1) loc) <#> value)
129+
130+ it "Should findDownWhere with 2 nodes and 2 levels" do
131+ let tree = 1 :< [ leaf 2 ]
132+ let loc = fromTree tree
133+ shouldEqual (Just 2) ((findDownWhere (_ == 2) loc) <#> value)
134+
135+ it "Should findDownWhere with 3 nodes and 2 levels" do
136+ let tree = 1 :< [ leaf 2, leaf 3 ]
137+ let loc = fromTree tree
138+ shouldEqual (Just 3) ((findDownWhere (_ == 3) loc) <#> value)
139+
140+ it "Should findDownWhere with 4 nodes and 2 levels" do
141+ let tree = 1 :< (leaf <$> [ 2, 3, 4 ])
142+ let loc = fromTree tree
143+ shouldEqual (Just 4) ((findDownWhere (_ == 4) loc) <#> value)
144+
145+ it "Should findDownWhere with 5 nodes and 3 levels" do
146+ let
147+ tree = 1 :<
148+ [ leaf 2
149+ , leaf 3
150+ , 4 :< [ leaf 5 ]
151+ ]
152+ -- log $ showTree tree
153+ let loc = fromTree tree
154+ shouldEqual (Just 5) ((findDownWhere (_ == 5) loc) <#> value)
155+
156+ it "Should findDownWhere with 6 nodes and 3 levels" do
157+ let
158+ tree = 1 :<
159+ [ leaf 2
160+ , leaf 3
161+ , 4 :< [ leaf 5, leaf 6 ]
162+ ]
163+ -- log $ showTree tree
164+ let loc = fromTree tree
165+ shouldEqual (Just 6) ((findDownWhere (_ == 6) loc) <#> value)
166+
167+ it "Should findDownWhere with 7 nodes and 4 levels" do
168+ let
169+ tree = 1 :<
170+ [ leaf 2
171+ , leaf 3
172+ , 4 :< [ leaf 5, 6 :< [ leaf 7 ] ]
173+ ]
174+ -- log $ showTree tree
175+ let loc = fromTree tree
176+ shouldEqual (Just 7) ((findDownWhere (_ == 7) loc) <#> value)
177+
178+ it "Should findDownWhere with 8 nodes and 4 levels" do
179+ let
180+ tree = 1 :<
181+ [ leaf 2
182+ , leaf 3
183+ , 4 :< [ leaf 5, 6 :< [ leaf 7 ] ]
184+ , leaf 8
185+ ]
186+ -- log $ showTree tree
187+ let loc = fromTree tree
188+ shouldEqual (Just 8) ((findDownWhere (_ == 8) loc) <#> value)
189+
190+ it "Should findDownWhere with 8 nodes and 4 levels with a step back" do
191+ let
192+ tree = 1 :<
193+ [ leaf 2
194+ , leaf 3
195+ , 4 :< [ leaf 5, 6 :< [ leaf 7 ] ]
196+ , leaf 8
197+ ]
198+ -- log $ showTree tree
199+ let loc = fromTree tree
200+ shouldEqual (Just 7) ((findDownWhere (_ == 7) loc) <#> value)
201+
202+ it "Should find 7 from the sampleTree" do
203+ shouldEqual (Just 7) (findDownWhere (_ == 7) (fromTree sampleTree) <#> value)
204+
205+ it "Should find 8 from the sampleTree (the bottom) and then find 1 (the top) with findUp" do
206+ let eight = unsafePartial $ fromJust $ findDownWhere (_ == 8) $ fromTree sampleTree
207+ shouldEqual (Just 1) (findUp 1 eight <#> value)
208+
209+ it "Should find 8 from the sampleTree (the bottom) but then not find 7 because it would require a downward traversal" do
210+ let eight = unsafePartial $ fromJust $ findDownWhere (_ == 8) $ fromTree sampleTree
211+ shouldEqual Nothing (findUp 7 eight <#> value)
212+
213+ it "Should find 8 from the sampleTree (the bottom) and then find 7 using findFromRoot" do
214+ let eight = unsafePartial $ fromJust $ findDownWhere (_ == 8) $ fromTree sampleTree
215+ shouldEqual (Just 7) (findFromRoot 7 eight <#> value)
216+
217+ it "Should flatten the Tree into a list of locations following a depth first pattern" do
218+ let flat = map value $ flattenLocDepthFirst $ fromTree sampleTree
219+ --log $ showTree sampleTree
220+ --log $ show flat
221+ shouldEqual flat [1,2,3,4,5,6,7,8]