git.iko.soy/rowtype-yoga/purescript-yoga-tree
on master help sign in
swap
148d00652 ahead, 0 behind
15 files changed+814−533
since splitsnapshots
unifiedsplit
.gitignore+1 .travis.yml+3−3 LICENSE+8 README.md+19−5 bower.json+23−21 package.json+3−3 packages.dhall+5 spago.dhall+15 src/Data/Tree.purs−129 src/Data/Tree/Zipper.purs−252 src/Yoga/Tree.purs+92 src/Yoga/Tree/Zipper.purs+333 test.dhall+20 test/Example.purs+93 test/Main.purs+199−120
.gitignore+1
@@ -7,3 +7,4 @@
77/.purs*
88/.psa*
99.DS_Store
10+/.spago
.travis.yml+3−3
@@ -2,7 +2,7 @@ node_js:
22 - "node"
33language: node_js
44install:
5− - npm install -g purescript pulp bower
6− - bower install
5+ - npm install -g purescript spago
6+ - spago install
77script:
8− - pulp test
8+ - spago -x test.dhall test
LICENSEnew file+8
@@ -0,0 +1,8 @@
1+Copyright 2017-2018 Daniel Fortes,
2+Copyright 2019-2020 Jordan Martinez
3+
4+Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:
5+
6+The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.
7+
8+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
README.md+19−5
@@ -1,15 +1,29 @@
1−# purescript-tree
1+# purescript-yoga-tree
22
3−[![Build status](https://img.shields.io/travis/dmbfm/purescript-tree.svg)](https://travis-ci.org/dmbfm/purescript-tree)
3+Multi-way trees (Rose Trees) with Zippers.
44
5−Multi-way trees with Zippers.
5+This is a fork of `purescript-tree-rose` that uses `Array`s instead of `List`s.
66
77## Installation
88
99```
10−bower install purescript-tree
10+{ yoga-tree =
11+ { dependencies =
12+ [ "arrays"
13+ , "control"
14+ , "foldable-traversable"
15+ , "free"
16+ , "maybe"
17+ , "prelude"
18+ , "tailrec"
19+ ]
20+ , version = "master"
21+ , repo = "https://github.com/rowtype-yoga/purescript-yoga-tree.git"
22+ }
23+}
24+
1125```
1226
1327## Documentation
1428
15−Module documentation is [published on Pursuit](http://pursuit.purescript.org/packages/purescript-tree).
29+Module documentation is [published on Pursuit](http://pursuit.purescript.org/packages/purescript-yoga-tree).
bower.json+23−21
@@ -1,23 +1,25 @@
11{
2− "name": "purescript-tree",
3− "license": "MIT",
4− "ignore": [
5− "**/.*",
6− "node_modules",
7− "bower_components",
8− "output"
9− ],
10− "repository": {
11− "type": "git",
12− "url": "git://github.com/dmbfm/purescript-tree.git"
13− },
14− "dependencies": {
15− "purescript-prelude": "^3.1.0",
16− "purescript-console": "^3.0.0",
17− "purescript-lists": "^4.9.1"
18− },
19− "devDependencies": {
20− "purescript-psci-support": "^3.0.0",
21− "purescript-spec": "^1.0.0"
22− }
2+ "name": "purescript-yoga-tree",
3+ "license": [
4+ "MIT"
5+ ],
6+ "repository": {
7+ "type": "git",
8+ "url": "https://github.com/jordanmartinez/purescript-tree-rose"
9+ },
10+ "ignore": [
11+ "**/.*",
12+ "node_modules",
13+ "bower_components",
14+ "output"
15+ ],
16+ "dependencies": {
17+ "purescript-arrays": "^v7.0.0",
18+ "purescript-control": "^v6.0.0",
19+ "purescript-foldable-traversable": "^v6.0.0",
20+ "purescript-free": "^v7.0.0",
21+ "purescript-maybe": "^v6.0.0",
22+ "purescript-prelude": "^v6.0.1",
23+ "purescript-tailrec": "^v6.0.0"
24+ }
2325}
package.json+3−3
@@ -1,7 +1,7 @@
11{
2− "name": "purescript-tree",
3− "version": "1.0.0",
4− "description": "A Tree data structure inspired by haskell's Data.Tree",
2+ "name": "purescript-yoga-tree",
3+ "version": "4.0.0",
4+ "description": "A Tree data structure inspired by Haskell's Data.Tree",
55 "main": "index.js",
66 "author": "Daniel Fortes",
77 "license": "MIT"
packages.dhallnew file+5
@@ -0,0 +1,5 @@
1+let upstream =
2+ https://github.com/purescript/package-sets/releases/download/psc-0.15.4-20220822/packages.dhall
3+ sha256:908b4ffbfba37a0a4edf806513a555d0dbcdd0cde7abd621f8d018d2e8ecf828
4+
5+in upstream
spago.dhallnew file+15
@@ -0,0 +1,15 @@
1+{ sources = [ "src/**/*.purs" ]
2+, license = "MIT"
3+, repository = "https://github.com/jordanmartinez/purescript-tree-rose"
4+, name = "yoga-tree"
5+, dependencies =
6+ [ "arrays"
7+ , "control"
8+ , "foldable-traversable"
9+ , "free"
10+ , "maybe"
11+ , "prelude"
12+ , "tailrec"
13+ ]
14+, packages = ./packages.dhall
15+}
src/Data/Tree.pursdeleted−129
@@ -1,129 +0,0 @@
1−module Data.Tree where
2−
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.Generic (class Generic, gEq, gShow)
9−import Data.List (List(..), snoc, (:))
10−import Data.Monoid (power)
11−import Data.Traversable (class Traversable, Accum, sequenceDefault, traverse)
12−
13−-- | A Rose, or multi-way tree, with values of type `a`.
14−newtype Tree a = Node { value :: a
15− , children :: Forest a
16− }
17−
18−-- | A `Forest` is a list of `Tree`s.
19−type Forest a = List (Tree a)
20−
21−-- | Create a `Tree` from a `Node` value of type `a` and a `Forest` of children.
22−mkTree :: 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
70−
71−-- | Draw a 2D `String` representation of a `Tree String`.
72−drawTree :: Tree String -> String
73−drawTree t = tailRec go {level: 0, drawn: (nodeValue t) <> "\n", current: (nodeChildren t)}
74− where
75− go :: _ -> Step _ String
76− go {level: l, drawn: s, current: Nil} = Done s
77− 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}
80−
81−-- | Draw a 2D `String` representation of a `Tree` composed of `Show`able
82−-- | elements.
83−showTree :: forall a. Show a => Tree a -> String
84−showTree = drawTree <<< (map show)
85−
86−-- | Scan a `Tree`, accumulating values of `b` there are constant across `Node`s
87−-- | that have the same parent.
88−scanTree :: 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})
92− where
93− go :: _ -> Step _ (Forest b)
94− go {b: b', current: Nil, final: final} = Done final
95− 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})}
98−
99−-- | Scan a `Tree`, accumulating values of `b` there are constant across `Node`s
100−-- | that have the same parent, and returning a `Tree` of type `c`.
101−scanTreeAccum :: 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})
105− where
106− go :: _ -> Step _ (Forest c)
107− go {b: b', current: Nil, final: final} = Done final
108− 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
118−
119−setNodeValue :: forall a. a -> Tree a -> Tree a
120−setNodeValue a (Node r) = Node r { value = a }
121−
122−modifyNodeValue :: forall a. (a -> a) -> Tree a -> Tree a
123−modifyNodeValue f (Node r) = Node r { value = f r.value }
124−
125−appendChild :: 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 }
src/Data/Tree/Zipper.pursdeleted−252
@@ -1,252 +0,0 @@
1−module Data.Tree.Zipper where
2−
3−import Prelude
4−
5−import Data.Generic (class Generic, gEq, gShow)
6−import Data.List (List(..), drop, reverse, take, (!!), (:))
7−import Data.Maybe (Maybe(..))
8−import Data.Tree (Forest, Tree(..), mkTree, modifyNodeValue, nodeChildren, nodeValue, 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 `List` 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 { node :: Tree a
20− , before :: Forest a
21− , after :: Forest a
22− , parents :: List (Loc a)
23− }
24−
25−
26−derive instance genericLoc :: Generic a => Generic (Loc a)
27−
28−instance showLoc :: Generic a => Show (Loc a) where
29− show = gShow
30−
31−instance eqLoc :: Generic a => Eq (Loc a) where
32− eq = gEq
33−
34−-- Cursor movement
35−
36−-- | Move the cursor to the next sibling.
37−next :: forall a. Loc a -> Maybe (Loc a)
38−next (Loc r) =
39− case r.after of
40− Nil -> Nothing
41− (c:cs) -> Just $ Loc { 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 :: forall a. Loc a -> Maybe (Loc a)
49−prev (Loc r) =
50− case r.before of
51− Nil -> Nothing
52− (c:cs) -> Just $ Loc { node: c
53− , before: cs
54− , after: r.node : r.after
55− , parents: r.parents
56− }
57−
58−-- | Move the cursor to the first sibling.
59−first :: forall a. Loc a -> Loc a
60−first l@(Loc r) =
61− case r.before of
62− Nil -> l
63− c:cs -> Loc $ { node: c
64− , before: Nil
65− , after: (reverse cs) <> r.after
66− , parents: r.parents
67− }
68−
69−-- | Move the cursor to the last sibling.
70−last :: forall a. Loc a -> Loc a
71−last l@(Loc r) =
72− case reverse r.after of
73− Nil -> l
74− c:cs -> Loc $ { node: c
75− , before: cs <> r.before
76− , after: Nil
77− , parents: r.parents
78− }
79−
80−-- | Move the cursor to the parent `Node`.
81−up :: forall a. Loc a -> Maybe (Loc a)
82−up l@(Loc r) =
83− case r.parents of
84− Nil -> Nothing
85− (p:ps) -> Just $ Loc { node: mkTree (value p) (siblings l)
86− , before: before p
87− , after: after p
88− , parents: ps
89− }
90−
91−-- | Move the cursor to the root of the tree.
92−root :: forall a. Loc a -> Loc a
93−root l =
94− case up l of
95− Nothing -> l
96− Just p -> root p
97−
98−-- | Move the cursor to the first child of the current `Node`.
99−firstChild :: forall a. Loc a -> Maybe (Loc a)
100−firstChild p@(Loc r) =
101− case r.node of
102− Node { value: _, children: Nil } -> Nothing
103− Node { value: _, children: c:cs } ->
104− Just $ Loc { node: c
105− , before: Nil
106− , after: cs
107− , parents: p : r.parents
108− }
109−
110−-- | Move the cursor to the first child of the current `Node`.
111−down :: forall a. Loc a -> Maybe (Loc a)
112−down = firstChild
113−
114−-- | Move the cursor to the last child of the current `Node`.
115−lastChild :: forall a. Loc a -> Maybe (Loc a)
116−lastChild p@(Loc r) = last <$> down p
117−
118−-- | Move the cursor to a specific sibling by it's index.
119−siblingAt :: forall a. Int -> Loc a -> Maybe (Loc a)
120−siblingAt i l@(Loc r) =
121− case up l of
122− Nothing -> Nothing
123− Just p@(Loc r') ->
124− case (children p) !! i of
125− Nothing -> Nothing
126− Just c ->
127− let before = reverse $ take i (children p)
128− after = drop (i+1) (children p)
129− in Just $ Loc { node: c
130− , before: before
131− , after: after
132− , parents: r.parents
133− }
134−
135−-- | Move the cursor to a specific child of the current `Node` by it's index.
136−childAt :: forall a. Int -> Loc a -> Maybe (Loc a)
137−childAt i p = (firstChild p) >>= (siblingAt i)
138−
139−
140−-- | Retrieve the `Tree` representation, i.e., returns the root `Node` of the
141−-- | current tree.
142−toTree :: forall a. Loc a -> Tree a
143−toTree = node <<< root
144−
145−-- | Get a `Loc`ation representation from a given `Tree`.
146−fromTree :: forall a. Tree a -> Loc a
147−fromTree n = Loc { node: n
148− , before: Nil
149− , after: Nil
150− , parents: Nil
151− }
152−
153−-- | Set the `Node` at the current position.
154−setNode :: forall a. Tree a -> Loc a -> Loc a
155−setNode a (Loc r) = Loc { node: a
156− , before: r.before
157− , after: r.after
158− , parents: r.parents
159− }
160−
161−-- | Set the `Node` at the current position.
162−modifyNode :: forall a. (Tree a -> Tree a) -> Loc a -> Loc a
163−modifyNode f (Loc r) = Loc { node: f r.node
164− , before: r.before
165− , after: r.after
166− , parents: r.parents
167− }
168−
169−-- | Set the value of the current `Node`.
170−setValue :: forall a. a -> Loc a -> Loc a
171−setValue a l = setNode (setNodeValue a (node l)) l
172−
173−-- | Modify the value of the current `Node`.
174−modifyValue :: forall a. (a -> a) -> Loc a -> Loc a
175−modifyValue f l = setNode (modifyNodeValue f (node l)) l
176−
177−-- insert and delete nodes
178−
179−-- | Insert a node after the current position, and move cursor to the new node.
180−insertAfter :: forall a. Tree a -> Loc a -> Loc a
181−insertAfter n l = Loc { node: n
182− , after: after l
183− , before: (node l) : (before l)
184− , parents: parents l
185− }
186−
187−-- | Insert a node before the current position, and move cursor to the new node.
188−insertBefore :: forall a. Tree a -> Loc a -> Loc a
189−insertBefore n l = Loc { node: n
190− , after: (node l) : (after l)
191− , before: before l
192− , parents: parents l
193− }
194−
195−-- | Insert a node as a child to the current node, and move cursor to the new node.
196−insertChild :: forall a. Tree a -> Loc a -> Loc a
197−insertChild n l =
198− case down l of
199− Just c -> insertAfter n c
200− Nothing -> Loc { node: n
201− , after: Nil
202− , before: Nil
203− , parents: l : (parents l)
204− }
205−
206−-- | Delete the node in the current position.
207−delete :: forall a. Loc a -> Loc a
208−delete l@(Loc r) =
209− case r.after of
210− c:cs -> Loc { node: c
211− , before: r.before
212− , after: cs
213− , parents: r.parents
214− }
215− Nil ->
216− case r.before of
217− c:cs -> Loc { node: c
218− , before: cs
219− , after: r.after
220− , parents: r.parents
221− }
222−
223− Nil ->
224− case r.parents of
225− Nil -> l
226− c:cs -> Loc { node: mkTree (value c) Nil
227− , before: before c
228− , after: after c
229− , parents: parents c
230− }
231−
232−-- Setters and Getters
233−node :: forall a. Loc a -> Tree a
234−node (Loc r) = r.node
235−
236−value :: forall a. Loc a -> a
237−value = nodeValue <<< node
238−
239−before :: forall a. Loc a -> Forest a
240−before (Loc r) = r.before
241−
242−after :: forall a. Loc a -> Forest a
243−after (Loc r) = r.after
244−
245−parents :: forall a. Loc a -> List (Loc a)
246−parents (Loc r) = r.parents
247−
248−children :: forall a. Loc a -> Forest a
249−children = nodeChildren <<< node
250−
251−siblings :: forall a. Loc a -> Forest a
252−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.dhallnew file+20
@@ -0,0 +1,20 @@
1+let config = ./spago.dhall
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.pursnew file+93
@@ -0,0 +1,93 @@
1+module Test.Example where
2+
3+import Prelude
4+
5+import Control.Comonad.Cofree (head, tail, (:<))
6+import Control.Monad.Rec.Class (Step(..), tailRec)
7+import Data.Array (uncons)
8+import Data.Maybe (Maybe(..), maybe)
9+import Data.Monoid (power)
10+import Effect (Effect)
11+import Effect.Console (log)
12+import Yoga.Tree (Tree, mkLeaf)
13+import Yoga.Tree.Zipper (fromTree, toTree, modifyValue, down, next, root)
14+
15+-- Serves only to make this file runnable
16+main :: Effect Unit
17+main = do
18+ log "rootOnly_alias"
19+ log $ drawTree' rootOnly_alias
20+ log "----"
21+ log "rootWithLeaves"
22+ log $ drawTree' rootWithLeaves
23+ log "----"
24+ log "rootWithBranchesAndLeaves"
25+ log $ drawTree' rootWithBranchesAndLeaves
26+ log "----"
27+ log "exampleZipper"
28+ log $ maybe "" identity exampleZipper
29+
30+
31+-- These examples show how to create a Tree
32+rootOnly_mkCoFree :: Tree String
33+rootOnly_mkCoFree = mkLeaf "root"
34+
35+rootOnly_alias :: Tree String
36+rootOnly_alias = "root" :< [] -- `:<` is the alias for `mkCofree`
37+
38+rootWithLeaves :: Tree String
39+rootWithLeaves =
40+ "root" :<
41+ []
42+
43+rootWithBranchesAndLeaves :: Tree String
44+rootWithBranchesAndLeaves =
45+ "1" :< []
46+
47+-- In our code, we will need to iterate through a Tree and do something
48+-- with each of its contents. Such a function has already been done
49+-- via `drawTree`, which iterates through a tree's contents
50+-- and converts it into a String, indenting them according to their respective
51+-- level:
52+-- https://github.com/dmbfm/purescript-tree/blob/v1.3.2/src/Yoga/Tree.purs#L21-L21
53+
54+-- The below example is a reproduction of the above code but differs from
55+-- it in that the names are more clearly defined to make it easier to see
56+-- the pattern one will follow.
57+
58+drawTree' :: Tree String -> String
59+drawTree' tree =
60+ let
61+ root = head tree
62+ children = tail tree
63+ in
64+ tailRec go {level: 1, result: root <> "\n", current: children }
65+ where
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+ }
80+
81+
82+-- Since we'll also be using the Zipper for the Tree (the `Loc` type),
83+-- we need to know how that works. For a clearer idea of what a 'Zipper' is,
84+-- see 'Design Patterns/Zipper.md':
85+exampleZipper :: Maybe String
86+exampleZipper = do
87+ let node1 = fromTree rootWithBranchesAndLeaves
88+ node1_1 <- down node1
89+ node1_1_1 <- down node1_1
90+ node1_1_2 <- next node1_1_1
91+ let node1_1_2a = modifyValue (\s -> s <> " a") node1_1_2
92+ let rootWithModification = root node1_1_2a
93+ pure $ drawTree' $ toTree rootWithModification
test/Main.purs+199−120
@@ -2,141 +2,220 @@ module Test.Main where
22
33import Prelude
44
5−import Control.Monad.Eff (Eff)
6−import Control.Monad.Eff.Class (liftEff)
7−import Control.Monad.Eff.Console (CONSOLE, log)
8−import Data.List (List(..), (:))
9−import Data.List.Partial (head)
10−import Data.Maybe (fromJust)
11−import Data.Tree (Tree, mkTree, nodeChildren, nodeValue, scanTree, showTree, (|>))
12−import Data.Tree.Zipper (down, fromTree, insertAfter, modifyValue, next, toTree)
5+import Control.Comonad.Cofree (head, (:<))
6+import Data.Maybe (Maybe(..), fromJust)
7+import Effect (Effect)
8+import Effect.Aff (launchAff_)
139import Partial.Unsafe (unsafePartial)
1410import Test.Spec (describe, it)
1511import Test.Spec.Assertions (shouldEqual)
1612import Test.Spec.Reporter (consoleReporter)
17−import Test.Spec.Runner (RunnerEffects, run)
13+import 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)
1823
1924sampleTree :: Tree Int
20−sampleTree =
21− 1 |>
22− (2 |> Nil)
23− : (3 |> Nil)
24− : (4 |>
25− (5 |> Nil)
26− : (6 |>
27− (7 |> Nil) : Nil)
28− : (8 |> Nil)
29− : Nil
30− )
31− : Nil
32−
33−main :: forall e. Eff (RunnerEffects e) Unit
34−main = run [consoleReporter] do
35− describe "Tree" do
25+sampleTree =
26+ 1 :<
27+ [ leaf 2
28+ , leaf 3
29+ , 4 :<
30+ [ leaf 5
31+ , 6 :< [ leaf 7 ]
32+ , leaf 8
33+ ]
34+
35+ ]
36+
37+main :: Effect Unit
38+main = launchAff_ $ runSpec [ consoleReporter ] do
39+ describe "Tree" do
3640
3741 it "mkTree" do
38− let t = mkTree 10 Nil
39− shouldEqual (nodeValue t) 10
42+ let t = 10 :< []
43+ shouldEqual (head t) 10
4044
4145 it "Functor" do
42− let result =
43− 2 |>
44− (3 |> Nil)
45− : (4 |> Nil)
46− : (5 |>
47− (6 |> Nil)
48− : (7 |>
49− (8 |> Nil) : Nil)
50− : (9 |> Nil)
51− : Nil
52− )
53− : Nil
54− shouldEqual (((+)1) <$> sampleTree) result
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
5557
5658 it "scanTree" do
57− let result =
58− 1 |>
59− (3 |> Nil)
60− : (4 |> Nil)
61− : (5 |>
62− (10 |> Nil)
63− : (11 |>
64− (18 |> Nil) : Nil)
65− : (13 |> Nil)
66− : Nil
67− )
68− : Nil
69− shouldEqual (scanTree (\a b -> a + b) 0 sampleTree) result
70−
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
71+
7172 describe "Zipper" do
7273
7374 let root = fromTree sampleTree
7475
7576 it "Modify" do
7677
77− let root' = unsafePartial $ toTree $ modifyValue (\a -> 2 * a) (fromJust $ down root)
78− let root'' = unsafePartial $ toTree $ modifyValue (\a -> 2 * a) (fromJust $ down >=> next >=> next >=> down $ root)
79− let result =
80− 1 |>
81− (4 |> Nil)
82− : (3 |> Nil)
83− : (4 |>
84− (5 |> Nil)
85− : (6 |>
86− (7 |> Nil) : Nil)
87− : (8 |> Nil)
88− : Nil
89− )
90− : Nil
91−
92− let result' =
93− 1 |>
94− (2 |> Nil)
95− : (3 |> Nil)
96− : (4 |>
97− (10 |> Nil)
98− : (6 |>
99− (7 |> Nil) : Nil)
100− : (8 |> Nil)
101− : Nil
102− )
103− : Nil
104−
105− shouldEqual root' result
106− shouldEqual root'' result'
107−
108− it "Insert" do
109−
110− let root' = unsafePartial $ toTree $ insertAfter (mkTree 100 Nil) (fromJust $ down root)
111− let root'' = unsafePartial $ toTree $ insertAfter (mkTree 100 Nil) (fromJust $ (down root) >>= next >>= next >>= down >>= next >>= down)
112−
113− let result =
114− 1 |>
115− (2 |> Nil)
116− : (100 |> Nil)
117− : (3 |> Nil)
118− : (4 |>
119− (5 |> Nil)
120− : (6 |>
121− (7 |> Nil) : Nil)
122− : (8 |> Nil)
123− : Nil
124− )
125− : Nil
126−
127− let result' =
128− 1 |>
129− (2 |> Nil)
130− : (3 |> Nil)
131− : (4 |>
132− (5 |> Nil)
133− : (6 |>
134− (7 |> Nil)
135− : (100 |> Nil)
136− : Nil)
137− : (8 |> Nil)
138− : Nil
139− )
140− : Nil
141− shouldEqual root' result
142− shouldEqual root'' result'
78+ let root' = unsafePartial $ toTree $ modifyValue (\a -> 2 * a) (fromJust $ down root)
79+ let root'' = unsafePartial $ toTree $ modifyValue (\a -> 2 * a) (fromJust $ down >=> next >=> next >=> down $ root)
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]