git.iko.soy/rowtype-yoga/purescript-yoga-tree
on master help sign in
swap
148d00661 ahead, 0 behind
15 files changed+842−135
since splitsnapshots
unifiedsplit
.gitignore+1 .travis.yml+3−3 LICENSE+8 README.md+29−1 bower.json+23−15 package.json+3−3 packages.dhall+5 spago.dhall+15 src/Data/Tree.purs−107 src/Data/Tree/Zipper.purs−1 src/Yoga/Tree.purs+92 src/Yoga/Tree/Zipper.purs+333 test.dhall+20 test/Example.purs+93 test/Main.purs+217−5
.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+29−1
@@ -1 +1,29 @@
1−# purescript-tree
1+# purescript-yoga-tree
2+
3+Multi-way trees (Rose Trees) with Zippers.
4+
5+This is a fork of `purescript-tree-rose` that uses `Array`s instead of `List`s.
6+
7+## Installation
8+
9+```
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+
25+```
26+
27+## Documentation
28+
29+Module documentation is [published on Pursuit](http://pursuit.purescript.org/packages/purescript-yoga-tree).
bower.json+23−15
@@ -1,17 +1,25 @@
11{
2− "name": "purescript-tree",
3− "ignore": [
4− "**/.*",
5− "node_modules",
6− "bower_components",
7− "output"
8− ],
9− "dependencies": {
10− "purescript-prelude": "^3.1.0",
11− "purescript-console": "^3.0.0",
12− "purescript-lists": "^4.9.1"
13− },
14− "devDependencies": {
15− "purescript-psci-support": "^3.0.0"
16− }
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+ }
1725}
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−107
@@ -1,107 +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.List (List(..), head, snoc, tail, (:))
9−import Data.Monoid (power)
10−import Data.Traversable (class Traversable, sequenceDefault, traverse)
11−
12−-- | A Rose, or multi-way tree, with values of type `a`.
13−newtype Tree a = Node { value :: a
14− , children :: Forest a
15− }
16−
17−-- | A `Forest` is a list of `Tree`s.
18−type Forest a = List (Tree a)
19−
20−-- | Create a `Tree` from a `Node` value of type `a` and a `Forest` of children.
21−mkTree :: forall a. a -> Forest a -> Tree a
22−mkTree a cs = Node { value: a, children: cs }
23−
24−infix 5 mkTree as |>
25−
26−-- Instances
27−
28−instance functorTree :: Functor Tree where
29− map f (Node {value:v, children: c}) = mkTree (f v) (tailRec go {current: c, result: Nil})
30− where
31− go {current: Nil, result: r} = Done r
32− go {current: c:cs, result: r} =
33− Loop {current: cs, result: snoc r (mkTree (f (nodeValue c)) (tailRec go {current: (nodeChildren c), result: Nil })) }
34−
35−instance applyTree :: Apply Tree where
36− apply (Node {value: f, children: fs}) tx@(Node {value: x, children: xs})
37− = Node {value: (f x), children: ((map <<< map) f xs) <> (map ((flip apply) tx) fs)}
38−
39−instance applicativeTree :: Applicative Tree where
40− pure = (flip $ mkTree) Nil
41−
42−instance bindTree :: Bind Tree where
43− bind tx@(Node {value: x, children: xs}) f =
44− let (Node {value: b, children: bs}) = f x in
45− Node {value: b, children: bs <> (map ((flip bind) f) xs)}
46−
47−instance monadTree :: Monad Tree
48−
49−instance foldableTree :: Foldable Tree where
50− foldMap f (Node {value: x, children: xs}) = (f x) <> (foldMap (foldMap f) xs)
51− foldl f = foldlDefault f
52− foldr f = foldrDefault f
53−
54−instance traversableTree :: Traversable Tree where
55− traverse f (Node {value: x, children: xs}) =
56− lift2 (\a b -> Node {value: a, children: b}) (f x) (traverse (traverse f) xs)
57−
58− sequence x = sequenceDefault x
59−
60−-- Other functions
61−
62−-- | Draw a 2D `String` representation of a `Tree String`.
63−drawTree :: Tree String -> String
64−drawTree t = tailRec go {level: 0, drawn: (nodeValue t) <> "\n", current: (nodeChildren t)}
65− where
66− go :: _ -> Step _ String
67− go {level: l, drawn: s, current: Nil} = Done s
68− go {level: l, drawn: s, current: c:cs } =
69− let drawn = (power " " l) <> "|----> " <> (nodeValue c) <> "\n" in
70− Loop {level: l, drawn: s <> drawn <> (tailRec go {level: l + 1, drawn: "", current: (nodeChildren c)}) , current: cs}
71−
72−-- | Draw a 2D `String` representation of a `Tree` composed of `Show`able
73−-- | elements.
74−showTree :: forall a. Show a => Tree a -> String
75−showTree = drawTree <<< (map show)
76−
77−-- | Scan a `Tree`, accumulating values of `b` there are constant across `Node`s
78−-- | that have the same parent.
79−scanTree :: forall a b. (a -> b -> b) -> b -> Tree a -> Tree b
80−scanTree f b n@(Node {value: x, children: xs}) =
81− let fb = f x b
82− in fb |> (tailRec go {b: fb, current: xs, final: Nil})
83− where
84− go :: _ -> Step _ (Forest b)
85− go {b: b', current: Nil, final: final} = Done final
86− go {b: b', current: c:cs, final: final} =
87− let fb' = f (nodeValue c) b'
88− in Loop {b: b', current: cs, final: snoc final (fb' |> tailRec go {b: fb', current: (nodeChildren c), final: Nil})}
89−
90−-- Setters and getters
91−nodeValue :: forall a. Tree a -> a
92−nodeValue (Node r) = r.value
93−
94−nodeChildren :: forall a. Tree a -> Forest a
95−nodeChildren (Node r) = r.children
96−
97−setNodeValue :: forall a. a -> Tree a -> Tree a
98−setNodeValue a (Node r) = Node r { value = a }
99−
100−modifyNodeValue :: forall a. (a -> a) -> Tree a -> Tree a
101−modifyNodeValue f (Node r) = Node r { value = f r.value }
102−
103−appendChild :: forall a. Tree a -> Tree a -> Tree a
104−appendChild n (Node r) = Node r { children = snoc r.children n }
105−
106−setChildren :: forall a. Forest a -> Tree a -> Tree a
107−setChildren cs (Node r) = Node r { children = cs }
src/Data/Tree/Zipper.pursdeleted−1
@@ -1 +0,0 @@
1−module Data.Tree.Zipper where
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+217−5
@@ -1,9 +1,221 @@
11module Test.Main where
22
33import Prelude
4−import Control.Monad.Eff (Eff)
5−import Control.Monad.Eff.Console (CONSOLE, log)
64
7−main :: forall e. Eff (console :: CONSOLE | e) Unit
8−main = do
9− log "You should add some tests."
5+import Control.Comonad.Cofree (head, (:<))
6+import Data.Maybe (Maybe(..), fromJust)
7+import Effect (Effect)
8+import Effect.Aff (launchAff_)
9+import Partial.Unsafe (unsafePartial)
10+import Test.Spec (describe, it)
11+import Test.Spec.Assertions (shouldEqual)
12+import Test.Spec.Reporter (consoleReporter)
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)
23+
24+sampleTree :: Tree Int
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
40+
41+ it "mkTree" do
42+ let t = 10 :< []
43+ shouldEqual (head t) 10
44+
45+ it "Functor" do
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
57+
58+ it "scanTree" do
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+
72+ describe "Zipper" do
73+
74+ let root = fromTree sampleTree
75+
76+ it "Modify" do
77+
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]