git.iko.soy/rowtype-yoga/purescript-yoga-tree
on master help sign in
swap
148d00637 ahead, 0 behind
14 files changed+803−780
since splitsnapshots
unifiedsplit
.travis.yml+3−3 LICENSE+8 README.md+19−5 bower.json+23−22 package.json+3−3 packages.dhall+3−119 spago.dhall+13−14 src/Data/Tree.purs−71 src/Data/Tree/Zipper.purs−306 src/Yoga/Tree.purs+92 src/Yoga/Tree/Zipper.purs+333 test.dhall+20 test/Example.purs+93 test/Main.purs+193−237
.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−22
@@ -1,24 +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": "^4.0.1",
16− "purescript-console": "^4.1.0",
17− "purescript-lists": "^5.0.0",
18− "purescript-free": "^5.1.0"
19− },
20− "devDependencies": {
21− "purescript-psci-support": "^4.0.0",
22− "purescript-spec": "^3.0.0"
23− }
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+ }
2425}
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.dhall+3−119
@@ -1,121 +1,5 @@
1−{-
2−Welcome to your new Dhall package-set!
3−
4−Below are instructions for how to edit this file for most use
5−cases, so that you don't need to know Dhall to use it.
6−
7−## Warning: Don't Move This Top-Level Comment!
8−
9−Due to how `dhall format` currently works, this comment's
10−instructions cannot appear near corresponding sections below
11−because `dhall format` will delete the comment. However,
12−it will not delete a top-level comment like this one.
13−
14−## Use Cases
15−
16−Most will want to do one or both of these options:
17−1. Override/Patch a package's dependency
18−2. Add a package not already in the default package set
19−
20−This file will continue to work whether you use one or both options.
21−Instructions for each option are explained below.
22−
23−### Overriding/Patching a package
24−
25−Purpose:
26−- Change a package's dependency to a newer/older release than the
27− default package set's release
28−- Use your own modified version of some dependency that may
29− include new API, changed API, removed API by
30− using your custom git repo of the library rather than
31− the package set's repo
32−
33−Syntax:
34−Replace the overrides' "{=}" (an empty record) with the following idea
35−The "//" or "⫽" means "merge these two records and
36− when they have the same value, use the one on the right:"
37−-------------------------------
38−let override =
39− { packageName =
40− upstream.packageName // { updateEntity1 = "new value", updateEntity2 = "new value" }
41− , packageName =
42− upstream.packageName // { version = "v4.0.0" }
43− , packageName =
44− upstream.packageName // { repo = "https://www.example.com/path/to/new/repo.git" }
45− }
46−-------------------------------
47−
48−Example:
49−-------------------------------
50−let overrides =
51− { halogen =
52− upstream.halogen // { version = "master" }
53− , halogen-vdom =
54− upstream.halogen-vdom // { version = "v4.0.0" }
55− }
56−-------------------------------
57−
58−### Additions
59−
60−Purpose:
61−- Add packages that aren't already included in the default package set
62−
63−Syntax:
64−Replace the additions' "{=}" (an empty record) with the following idea:
65−-------------------------------
66−let additions =
67− { "package-name" =
68− mkPackage
69− [ "dependency1"
70− , "dependency2"
71− ]
72− "https://example.com/path/to/git/repo.git"
73− "tag ('v4.0.0') or branch ('master')"
74− , "package-name" =
75− mkPackage
76− [ "dependency1"
77− , "dependency2"
78− ]
79− "https://example.com/path/to/git/repo.git"
80− "tag ('v4.0.0') or branch ('master')"
81− , etc.
82− }
83−-------------------------------
84−
85−Example:
86−-------------------------------
87−let additions =
88− { benchotron =
89− mkPackage
90− [ "arrays"
91− , "exists"
92− , "profunctor"
93− , "strings"
94− , "quickcheck"
95− , "lcg"
96− , "transformers"
97− , "foldable-traversable"
98− , "exceptions"
99− , "node-fs"
100− , "node-buffer"
101− , "node-readline"
102− , "datetime"
103− , "now"
104− ]
105− "https://github.com/hdgarrood/purescript-benchotron.git"
106− "v7.0.0"
107− }
108−-------------------------------
109−-}
110−
111−let mkPackage =
112− https://raw.githubusercontent.com/purescript/package-sets/psc-0.12.3-20190315/src/mkPackage.dhall sha256:0b197efa1d397ace6eb46b243ff2d73a3da5638d8d0ac8473e8e4a8fc528cf57
113−
1141let upstream =
115− https://raw.githubusercontent.com/purescript/package-sets/psc-0.12.3-20190315/src/packages.dhall sha256:08714bc666b16834f0f4cf86d408745ce005c43e3343821e4c3864ef28709177
116−
117−let overrides = {=}
118−
119−let additions = {=}
2+ https://github.com/purescript/package-sets/releases/download/psc-0.15.4-20220822/packages.dhall
3+ sha256:908b4ffbfba37a0a4edf806513a555d0dbcdd0cde7abd621f8d018d2e8ecf828
1204
121−in upstream // overrides // additions
5+in upstream
spago.dhall+13−14
@@ -1,16 +1,15 @@
1−{-
2−Welcome to a Spago project!
3−You can edit this file as you like.
4−-}
5−{ name =
6− "my-project"
1+{ sources = [ "src/**/*.purs" ]
2+, license = "MIT"
3+, repository = "https://github.com/jordanmartinez/purescript-tree-rose"
4+, name = "yoga-tree"
75, dependencies =
8− [ "prelude"
9− , "console"
10− , "lists"
11− , "free"
12− , "spec"
13− ]
14−, packages =
15− ./packages.dhall
6+ [ "arrays"
7+ , "control"
8+ , "foldable-traversable"
9+ , "free"
10+ , "maybe"
11+ , "prelude"
12+ , "tailrec"
13+ ]
14+, packages = ./packages.dhall
1615}
src/Data/Tree.pursdeleted−71
@@ -1,71 +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`.
12−type Tree a = Cofree List a
13−
14−type Forest a = List (Tree a)
15−
16−-- | Create a `Tree` from a `Node` value of type `a` and a `Forest` of children.
17−mkTree :: forall a. a -> Forest a -> Tree a
18−mkTree = mkCofree
19−
20−-- | Draw a 2D `String` representation of a `Tree String`.
21−drawTree :: Tree String -> String
22−drawTree t = tailRec go {level: 0, drawn: (head t) <> "\n", current: (tail t)}
23− where
24− go :: { current :: Forest String , drawn :: String , level :: Int } -> Step { current :: Forest String , drawn :: String , level :: Int } String
25− go {level: l, drawn: s, current: Nil} = Done s
26− go {level: l, drawn: s, current: c:cs } =
27− let drawn = (power " " l) <> "|----> " <> (head c) <> "\n" in
28− Loop {level: l, drawn: s <> drawn <> (tailRec go {level: l + 1, drawn: "", current: (tail c)}) , current: cs}
29−
30−-- | Draw a 2D `String` representation of a `Tree` composed of `Show`able
31−-- | elements.
32−showTree :: forall a. Show a => Tree a -> String
33−showTree = drawTree <<< (map show)
34−
35−-- | Scan a `Tree`, accumulating values of `b` there are constant across `Node`s
36−-- | that have the same parent.
37−scanTree :: forall a b. (a -> b -> b) -> b -> Tree a -> Tree b
38−scanTree f b n =
39− let fb = f (head n) b
40− in fb :< (tailRec go {b: fb, current: (tail n), final: Nil})
41− where
42− go :: { final :: Forest b , current :: Forest a , b :: b } -> Step { final :: Forest b , current :: Forest a , b :: b } (Forest b)
43− go {b: b', current: Nil, final: final} = Done final
44− go {b: b', current: c:cs, final: final} =
45− let fb' = f (head c) b'
46− in Loop {b: b', current: cs, final: snoc final (fb' :< tailRec go {b: fb', current: (tail c), final: Nil})}
47−
48−-- | Scan a `Tree`, accumulating values of `b` there are constant across `Node`s
49−-- | that have the same parent, and returning a `Tree` of type `c`.
50−scanTreeAccum :: forall a b c. (a -> b -> Accum b c) -> b -> Tree a -> Tree c
51−scanTreeAccum f b n =
52− let fb = f (head n) b
53− in fb.value :< (tailRec go {b: fb.accum , current: (tail n), final: Nil})
54− where
55− go :: { final :: Forest c , current :: Forest a , b :: b } -> Step { final :: Forest c , current :: Forest a , b :: b } (Forest c)
56− go {b: b', current: Nil, final: final} = Done final
57− go {b: b', current: c:cs, final: final} =
58− let fb' = f (head c) b'
59− in Loop {b: b', current: cs, final: snoc final (fb'.value :< tailRec go {b: fb'.accum, current: (tail c), final: Nil})}
60−
61−-- | Set the value of a node.
62−setNodeValue :: forall a. a -> Tree a -> Tree a
63−setNodeValue a n = a :< (tail n)
64−
65−-- | Modify the value of a node.
66−modifyNodeValue :: forall a. (a -> a) -> Tree a -> Tree a
67−modifyNodeValue f n = f (head n) :< tail n
68−
69−-- | Append a child to a node.
70−appendChild :: forall a. Tree a -> Tree a -> Tree a
71−appendChild c n = head n :< snoc (tail n) c
src/Data/Tree/Zipper.pursdeleted−306
@@ -1,306 +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 { node :: Tree a
21− , before :: Forest a
22− , after :: Forest a
23− , parents :: List (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−
35−-- | Move the cursor to the next sibling.
36−next :: forall a. Loc a -> Maybe (Loc a)
37−next (Loc r) =
38− case r.after of
39− Nil -> Nothing
40− (c:cs) -> Just $ Loc { node: c
41− , before: r.node : r.before
42− , after: cs
43− , parents: r.parents
44− }
45−
46−-- -- | Move the cursor to the previous sibling.
47−prev :: forall a. Loc a -> Maybe (Loc a)
48−prev (Loc r) =
49− case r.before of
50− Nil -> Nothing
51− (c:cs) -> Just $ Loc { node: c
52− , before: cs
53− , after: r.node : r.after
54− , parents: r.parents
55− }
56−
57−-- -- | Move the cursor to the first sibling.
58−first :: forall a. Loc a -> Loc a
59−first l@(Loc r) =
60− case r.before of
61− Nil -> l
62− c:cs -> Loc $ { node: c
63− , before: Nil
64− , after: (reverse cs) <> r.after
65− , parents: r.parents
66− }
67−
68−-- -- | Move the cursor to the last sibling.
69−last :: forall a. Loc a -> Loc a
70−last l@(Loc r) =
71− case reverse r.after of
72− Nil -> l
73− c:cs -> Loc $ { node: c
74− , before: cs <> r.before
75− , after: Nil
76− , parents: r.parents
77− }
78−
79−-- -- | Move the cursor to the parent `Node`.
80−up :: forall a. Loc a -> Maybe (Loc a)
81−up l@(Loc r) =
82− case r.parents of
83− Nil -> Nothing
84− (p:ps) -> Just $ Loc { node: (value p) :< (siblings l)
85− , before: before p
86− , after: after p
87− , parents: ps
88− }
89−
90−-- | Move the cursor to the root of the tree.
91−root :: forall a. Loc a -> Loc a
92−root l =
93− case up l of
94− Nothing -> l
95− Just p -> root p
96−
97−-- | Move the cursor to the first child of the current `Node`.
98−firstChild :: forall a. Loc a -> Maybe (Loc a)
99−firstChild n =
100− case children n of
101− Nil -> Nothing
102− c:cs ->
103− Just $ Loc { node: c
104− , before: Nil
105− , after: cs
106− , parents: n : (parents n)
107− }
108−
109−-- | Move the cursor to the first child of the current `Node`.
110−down :: forall a. Loc a -> Maybe (Loc a)
111−down = firstChild
112−
113−-- | Move the cursor to the last child of the current `Node`.
114−lastChild :: forall a. Loc a -> Maybe (Loc a)
115−lastChild p@(Loc r) = last <$> down p
116−
117−-- | Move the cursor to a specific sibling by it's index.
118−siblingAt :: forall a. Int -> Loc a -> Maybe (Loc a)
119−siblingAt i l@(Loc r) =
120− case up l of
121− Nothing -> Nothing
122− Just p@(Loc r') ->
123− case (children p) !! i of
124− Nothing -> Nothing
125− Just c ->
126− let before' = reverse $ take i (children p)
127− after' = drop (i+1) (children p)
128− in Just $ Loc { node: c
129− , before: before'
130− , after: after'
131− , parents: r.parents
132− }
133−
134−-- | Move the cursor to a specific child of the current `Node` by it's index.
135−childAt :: forall a. Int -> Loc a -> Maybe (Loc a)
136−childAt i p = (firstChild p) >>= (siblingAt i)
137−
138−
139−-- | Retrieve the `Tree` representation, i.e., returns the root `Node` of the
140−-- | current tree.
141−toTree :: forall a. Loc a -> Tree a
142−toTree = node <<< root
143−
144−-- | Get a `Loc`ation representation from a given `Tree`.
145−fromTree :: forall a. Tree a -> Loc a
146−fromTree n = Loc { node: n
147− , before: Nil
148− , after: Nil
149− , parents: Nil
150− }
151−
152−-- | Set the `Node` at the current position.
153−setNode :: forall a. Tree a -> Loc a -> Loc a
154−setNode a (Loc r) = Loc { node: a
155− , before: r.before
156− , after: r.after
157− , parents: r.parents
158− }
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 { node: f r.node
163− , before: r.before
164− , after: r.after
165− , parents: r.parents
166− }
167−
168−-- | Set the value of the current `Node`.
169−setValue :: forall a. a -> Loc a -> Loc a
170−setValue a l = setNode (setNodeValue a (node l)) l
171−
172−-- | Modify the value of the current `Node`.
173−modifyValue :: forall a. (a -> a) -> Loc a -> Loc a
174−modifyValue f l = setNode (modifyNodeValue f (node l)) l
175−
176−-- -- insert and delete nodes
177−
178−-- | Insert a node after the current position, and move cursor to the new node.
179−insertAfter :: forall a. Tree a -> Loc a -> Loc a
180−insertAfter n l = Loc { node: n
181− , after: after l
182− , before: (node l) : (before l)
183− , parents: parents l
184− }
185−
186−-- | Insert a node before the current position, and move cursor to the new node.
187−insertBefore :: forall a. Tree a -> Loc a -> Loc a
188−insertBefore n l = Loc { node: n
189− , after: (node l) : (after l)
190− , before: before l
191− , parents: parents l
192− }
193−
194−-- | Insert a node as a child to the current node, and move cursor to the new node.
195−insertChild :: forall a. Tree a -> Loc a -> Loc a
196−insertChild n l =
197− case down l of
198− Just c -> insertAfter n c
199− Nothing -> Loc { node: n
200− , after: Nil
201− , before: Nil
202− , parents: l : (parents l)
203− }
204−
205−-- | Delete the node in the current position.
206−delete :: forall a. Loc a -> Loc a
207−delete l@(Loc r) =
208− case r.after of
209− c:cs -> Loc { node: c
210− , before: r.before
211− , after: cs
212− , parents: r.parents
213− }
214− Nil ->
215− case r.before of
216− c:cs -> Loc { node: c
217− , before: cs
218− , after: r.after
219− , parents: r.parents
220− }
221−
222− Nil ->
223− case r.parents of
224− Nil -> l
225− c:cs -> Loc { node: mkTree (value c) Nil
226− , before: before c
227− , after: after c
228− , parents: parents c
229− }
230−
231−-- Searches
232−
233− -- | Search down and to the right for the first occurence where the given predicate is true and return the Loc
234−findDownWhere :: ∀ a. (a -> Boolean) -> Loc a -> Maybe (Loc a)
235−findDownWhere predicate loc | predicate $ value loc = Just loc
236−findDownWhere predicate loc = lookNext <|> lookDown
237− where
238− lookNext = next loc >>= findDownWhere predicate
239− lookDown = down loc >>= findDownWhere predicate
240−
241−-- | Search for the first occurence of the value `a` downwards and to the right.
242−findDown :: forall a. Eq a => a -> Loc a -> Maybe (Loc a)
243−findDown a = findDownWhere ( _ == a)
244−
245−-- | Search to the left and up for the first occurence where the given predicate is true and return the Loc
246−findUpWhere :: ∀ a. (a -> Boolean) -> Loc a -> Maybe (Loc a)
247−findUpWhere predicate loc | predicate $ value loc = Just loc
248−findUpWhere predicate loc = lookPrev <|> lookUp
249− where
250− lookPrev = prev loc >>= findUpWhere predicate
251− lookUp = up loc >>= findUpWhere predicate
252−
253−-- | Search for the first occurence of the value `a` upwards and to the left,
254−findUp :: forall a. Eq a => a -> Loc a -> Maybe (Loc a)
255−findUp a = findUpWhere (_ == a)
256−
257−-- | Search from the root of the tree for the first occurrence where the given predicate is truen and return the Loc
258−findFromRootWhere :: ∀ a. (a -> Boolean) -> Loc a -> Maybe (Loc a)
259−findFromRootWhere predicate loc | predicate $ value loc = Just loc
260−findFromRootWhere predicate loc = findDownWhere predicate $ root loc
261−
262−-- | Search for the first occurence of the value `a` starting from the root of
263−-- | the tree.
264−findFromRoot :: forall a. Eq a => a -> Loc a -> Maybe (Loc a)
265−findFromRoot a = findFromRootWhere (_ == a)
266−
267−-- | flattens the Tree into a List depth first.
268−flattenLocDepthFirst :: ∀ a. Loc a -> List (Loc a)
269−flattenLocDepthFirst loc = loc : (go loc)
270− where
271− go :: Loc a -> List (Loc a)
272− go loc' =
273− let
274− downs = goDir loc' down
275− nexts = goDir loc' next
276− in
277− downs <> nexts
278−
279− goDir :: Loc a -> (Loc a -> Maybe (Loc a)) -> List (Loc a)
280− goDir loc' dirFn = case (dirFn loc') of
281− Just l -> l : go l
282− Nothing -> Nil
283−
284−
285−
286−-- Setters and Getters
287−node :: forall a. Loc a -> Tree a
288−node (Loc r) = r.node
289−
290−value :: forall a. Loc a -> a
291−value = head <<< node
292−
293−before :: forall a. Loc a -> Forest a
294−before (Loc r) = r.before
295−
296−after :: forall a. Loc a -> Forest a
297−after (Loc r) = r.after
298−
299−parents :: forall a. Loc a -> List (Loc a)
300−parents (Loc r) = r.parents
301−
302−children :: forall a. Loc a -> Forest a
303−children = tail <<< node
304−
305−siblings :: forall a. Loc a -> Forest a
306−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+193−237
@@ -3,263 +3,219 @@ 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)
107import Effect (Effect)
8+import Effect.Aff (launchAff_)
119import Partial.Unsafe (unsafePartial)
1210import Test.Spec (describe, it)
1311import Test.Spec.Assertions (shouldEqual)
1412import Test.Spec.Reporter (consoleReporter)
15−import Test.Spec.Runner (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)
1623
1724sampleTree :: Tree Int
18−sampleTree =
19− 1 :<
20− (2 :< Nil)
21− : (3 :< Nil)
22− : (4 :<
23− (5 :< Nil)
24− : (6 :<
25− (7 :< Nil) : Nil)
26− : (8 :< Nil)
27− : Nil
28− )
29− : Nil
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+ ]
3036
3137main :: Effect Unit
32−main = run [consoleReporter] do
33− describe "Tree" do
38+main = launchAff_ $ runSpec [ consoleReporter ] do
39+ describe "Tree" do
3440
3541 it "mkTree" do
36− let t = mkTree 10 Nil
42+ let t = 10 :< []
3743 shouldEqual (head t) 10
3844
3945 it "Functor" do
40− let result =
41− 2 :<
42− (3 :< Nil)
43− : (4 :< Nil)
44− : (5 :<
45− (6 :< Nil)
46− : (7 :<
47− (8 :< Nil) : Nil)
48− : (9 :< Nil)
49− : Nil
50− )
51− : Nil
52− 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
5357
5458 it "scanTree" do
55− let result =
56− 1 :<
57− (3 :< Nil)
58− : (4 :< Nil)
59− : (5 :<
60− (10 :< Nil)
61− : (11 :<
62− (18 :< Nil) : Nil)
63− : (13 :< Nil)
64− : Nil
65− )
66− : Nil
67− shouldEqual (eq (scanTree (\a b -> a + b) 0 sampleTree) result) true
68−
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+
6972 describe "Zipper" do
7073
7174 let root = fromTree sampleTree
7275
7376 it "Modify" do
7477
75− let root' = unsafePartial $ toTree $ modifyValue (\a -> 2 * a) (fromJust $ down root)
76− let root'' = unsafePartial $ toTree $ modifyValue (\a -> 2 * a) (fromJust $ down >=> next >=> next >=> down $ root)
77− let result =
78− 1 :<
79− (4 :< Nil)
80− : (3 :< Nil)
81− : (4 :<
82− (5 :< Nil)
83− : (6 :<
84− (7 :< Nil) : Nil)
85− : (8 :< Nil)
86− : Nil
87− )
88− : Nil
89−
90− let result' =
91− 1 :<
92− (2 :< Nil)
93− : (3 :< Nil)
94− : (4 :<
95− (10 :< Nil)
96− : (6 :<
97− (7 :< Nil) : Nil)
98− : (8 :< Nil)
99− : Nil
100− )
101− : Nil
102−
103− shouldEqual (eq root' result) true
104− shouldEqual (eq root'' result') true
105−
106− it "Insert" do
107−
108− let root' = unsafePartial $ toTree $ insertAfter (mkTree 100 Nil) (fromJust $ down root)
109− let root'' = unsafePartial $ toTree $ insertAfter (mkTree 100 Nil) (fromJust $ (down root) >>= next >>= next >>= down >>= next >>= down)
110−
111− let result =
112− 1 :<
113− (2 :< Nil)
114− : (100 :< Nil)
115− : (3 :< Nil)
116− : (4 :<
117− (5 :< Nil)
118− : (6 :<
119− (7 :< Nil) : Nil)
120− : (8 :< Nil)
121− : Nil
122− )
123− : Nil
124−
125− let result' =
126− 1 :<
127− (2 :< Nil)
128− : (3 :< Nil)
129− : (4 :<
130− (5 :< Nil)
131− : (6 :<
132− (7 :< Nil)
133− : (100 :< Nil)
134− : Nil)
135− : (8 :< Nil)
136− : Nil
137− )
138− : Nil
139− shouldEqual (eq root' result) true
140− shouldEqual (eq root'' result') true
141−
142− it "Should findDownWhere with single node" do
143− let tree = 1 :< Nil
144− let loc = fromTree tree
145− shouldEqual (Just 1) ((findDownWhere (_ == 1) loc) <#> value)
146−
147− it "Should findDownWhere with 2 nodes and 2 levels" do
148− let tree = 1 :<
149− (2 :< Nil)
150− : Nil
151− -- log $ showTree tree
152− let loc = fromTree tree
153− shouldEqual (Just 2) ((findDownWhere (_ == 2) loc) <#> value)
154−
155− it "Should findDownWhere with 3 nodes and 2 levels" do
156− let tree = 1 :<
157− (2 :< Nil)
158− : (3 :< Nil)
159− : Nil
160− -- log $ showTree tree
161− let loc = fromTree tree
162− shouldEqual (Just 3) ((findDownWhere (_ == 3) loc) <#> value)
163−
164− it "Should findDownWhere with 4 nodes and 2 levels" do
165− let tree = 1 :<
166− (2 :< Nil)
167− : (3 :< Nil)
168− : (4 :< Nil)
169− : Nil
170− -- log $ showTree tree
171− let loc = fromTree tree
172− shouldEqual (Just 4) ((findDownWhere (_ == 4) loc) <#> value)
173−
174− it "Should findDownWhere with 5 nodes and 3 levels" do
175− let tree = 1 :<
176− (2 :< Nil)
177− : (3 :< Nil)
178− : (4 :<
179− (5 :< Nil)
180− : Nil)
181− : Nil
182− -- log $ showTree tree
183− let loc = fromTree tree
184− shouldEqual (Just 5) ((findDownWhere (_ == 5) loc) <#> value)
185−
186− it "Should findDownWhere with 6 nodes and 3 levels" do
187− let tree = 1 :<
188− (2 :< Nil)
189− : (3 :< Nil)
190− : (4 :<
191− (5 :< Nil)
192− : (6 :< Nil)
193− : Nil)
194− : Nil
195− -- log $ showTree tree
196− let loc = fromTree tree
197− shouldEqual (Just 6) ((findDownWhere (_ == 6) loc) <#> value)
198−
199− it "Should findDownWhere with 7 nodes and 4 levels" do
200− let tree = 1 :<
201− (2 :< Nil)
202− : (3 :< Nil)
203− : (4 :<
204− (5 :< Nil)
205− : (6 :<
206− (7 :< Nil) : Nil)
207− : Nil)
208− : Nil
209− -- log $ showTree tree
210− let loc = fromTree tree
211− shouldEqual (Just 7) ((findDownWhere (_ == 7) loc) <#> value)
212−
213− it "Should findDownWhere with 8 nodes and 4 levels" do
214− let tree = 1 :<
215− (2 :< Nil)
216− : (3 :< Nil)
217− : (4 :<
218− (5 :< Nil)
219− : (6 :<
220− (7 :< Nil) : Nil)
221− : (8 :< Nil)
222− : Nil)
223− : Nil
224− -- log $ showTree tree
225− let loc = fromTree tree
226− shouldEqual (Just 8) ((findDownWhere (_ == 8) loc) <#> value)
227−
228− it "Should findDownWhere with 8 nodes and 4 levels with a step back" do
229− let tree = 1 :<
230− (2 :< Nil)
231− : (3 :< Nil)
232− : (4 :<
233− (5 :< Nil)
234− : (6 :<
235− (7 :< Nil) : Nil)
236− : (8 :< Nil)
237− : Nil)
238− : Nil
239− -- log $ showTree tree
240− let loc = fromTree tree
241− shouldEqual (Just 7) ((findDownWhere (_ == 7) loc) <#> value)
242−
243− it "Should find 7 from the sampleTree" do
244− shouldEqual (Just 7) (findDownWhere (_ == 7) (fromTree sampleTree) <#> value)
245−
246− it "Should find 8 from the sampleTree (the bottom) and then find 1 (the top) with findUp" do
247− let eight = unsafePartial $ fromJust $ findDownWhere (_ == 8) $ fromTree sampleTree
248− shouldEqual (Just 1) (findUp 1 eight <#> value)
249−
250− it "Should find 8 from the sampleTree (the bottom) but then not find 7 because it would require a downward traversal" do
251− let eight = unsafePartial $ fromJust $ findDownWhere (_ == 8) $ fromTree sampleTree
252− shouldEqual Nothing (findUp 7 eight <#> value)
253−
254− it "Should find 8 from the sampleTree (the bottom) and then find 7 using findFromRoot" do
255− let eight = unsafePartial $ fromJust $ findDownWhere (_ == 8) $ fromTree sampleTree
256− shouldEqual (Just 7) (findFromRoot 7 eight <#> value)
257−
258− it "Should flatten the Tree into a list of locations following a depth first pattern" do
259− let flat = map value $ flattenLocDepthFirst $ fromTree sampleTree
260− --log $ showTree sampleTree
261− --log $ show flat
262− shouldEqual flat (1 : 2 : 3 : 4 : 5 : 6 : 7 : 8 : Nil)
263−
264−
265−
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]