git.iko.soy/rowtype-yoga/purescript-yoga-tree
on master help sign in
swap
148d00627 ahead, 0 behind
13 files changed+789−801
since splitsnapshots
unifiedsplit
.travis.yml+3−3 README.md+19−5 bower.json+23−22 package.json+3−3 packages.dhall+3−119 spago.dhall+13−7 src/Data/Tree.purs−98 src/Data/Tree/Zipper.purs−284 src/Yoga/Tree.purs+92 src/Yoga/Tree/Zipper.purs+333 test.dhall+20 test/Example.purs+93 test/Main.purs+187−260
.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
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://github.com/purescript/package-sets/releases/download/psc-0.13.6-20200507/packages.dhall sha256:9c1e8951e721b79de1de551f31ecb5a339e82bbd43300eb5ccfb1bf8cf7bbd62
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−7
@@ -1,9 +1,15 @@
1−{-
2−Welcome to a Spago project!
3−You can edit this file as you like.
4−-}
5−{ sources = [ "src/**/*.purs", "test/**/*.purs" ]
6−, name = "my-project"
7−, dependencies = [ "prelude", "console", "lists", "free", "spec" ]
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+ ]
814, packages = ./packages.dhall
915}
src/Data/Tree.pursdeleted−98
@@ -1,98 +0,0 @@
1−module Data.Tree where
2−
3−import Prelude
4−
5−import Control.Comonad.Cofree (Cofree, head, mkCofree, tail, (:<))
6−import Control.Monad.Rec.Class (Step(..), tailRec)
7−import Data.List (List(..), snoc, (:))
8−import Data.Monoid (power)
9−import Data.Traversable (Accum)
10−
11−-- | A Rose, or multi-way tree, with values of type `a`. To access the
12−-- | root of the Tree's value, use `Control.Comonad.Cofree (head)`. To
13−-- | access the root's children, use `Control.Comonad.Cofree (tail)`
14−type Tree a = Cofree List a
15−
16−-- | A type alias for the children of a Tree's root value.
17−type Forest a = List (Tree a)
18−
19−-- | Create a `Tree` from a `Node` value of type `a` and a `Forest` of children.
20−mkTree :: forall a. a -> Forest a -> Tree a
21−mkTree = mkCofree
22−
23−-- | Draw a 2D `String` representation of a `Tree String`.
24−drawTree :: Tree String -> String
25−drawTree = drawTree' 0
26−
27−-- | Draw a 2D `String` representation of a `Tree String`,
28−-- | starting the indent at the given level
29−drawTree' :: Int -> Tree String -> String
30−drawTree' level t =
31− let
32− treeRoot = (power " " level) <> "|----> " <> (head t) <> "\n"
33− treeChildren = drawForest' (level + 1) (tail t)
34− in treeRoot <> treeChildren
35−
36−-- | Draw a 2D `String` representation of a `Forest String`,
37−drawForest :: Forest String -> String
38−drawForest = drawForest' 0
39−
40−-- | Draw a 2D `String` representation of a `Forest String`,
41−-- | starting the indent at the given level
42−drawForest' :: Int -> Forest String -> String
43−drawForest' level forest = tailRec goForest { level: level, drawn: "", current: forest }
44− where
45− goForest :: { current :: Forest String , drawn :: String , level :: Int }
46− -> Step { current :: Forest String , drawn :: String , level :: Int } String
47− goForest {level: l, drawn: s, current: Nil} = Done s
48− goForest {level: l, drawn: s, current: c:cs } =
49− let drawnTree = drawTree' l c in
50− Loop {level: l, drawn: s <> drawnTree, current: cs}
51−
52−-- | Draw a 2D `String` representation of a `Tree` composed of `Show`able
53−-- | elements.
54−showTree :: forall a. Show a => Tree a -> String
55−showTree tree = drawTree (show <$> tree)
56−
57−-- | Draw a 2D `String` representation of a `Forest` composed of `Show`able
58−-- | elements.
59−showForest :: forall a. Show a => Forest a -> String
60−showForest forest = drawForest ((\tree -> show <$> tree) <$> forest)
61−
62−-- | Scan a `Tree`, accumulating values of `b` there are constant across `Node`s
63−-- | that have the same parent.
64−scanTree :: forall a b. (a -> b -> b) -> b -> Tree a -> Tree b
65−scanTree f b n =
66− let fb = f (head n) b
67− in fb :< (tailRec go {b: fb, current: (tail n), final: Nil})
68− where
69− go :: { final :: Forest b , current :: Forest a , b :: b } -> Step { final :: Forest b , current :: Forest a , b :: b } (Forest b)
70− go {b: b', current: Nil, final: final} = Done final
71− go {b: b', current: c:cs, final: final} =
72− let fb' = f (head c) b'
73− in Loop {b: b', current: cs, final: snoc final (fb' :< tailRec go {b: fb', current: (tail c), final: Nil})}
74−
75−-- | Scan a `Tree`, accumulating values of `b` there are constant across `Node`s
76−-- | that have the same parent, and returning a `Tree` of type `c`.
77−scanTreeAccum :: forall a b c. (a -> b -> Accum b c) -> b -> Tree a -> Tree c
78−scanTreeAccum f b n =
79− let fb = f (head n) b
80− in fb.value :< (tailRec go {b: fb.accum , current: (tail n), final: Nil})
81− where
82− go :: { final :: Forest c , current :: Forest a , b :: b } -> Step { final :: Forest c , current :: Forest a , b :: b } (Forest c)
83− go {b: b', current: Nil, final: final} = Done final
84− go {b: b', current: c:cs, final: final} =
85− let fb' = f (head c) b'
86− in Loop {b: b', current: cs, final: snoc final (fb'.value :< tailRec go {b: fb'.accum, current: (tail c), final: Nil})}
87−
88−-- | Set the value of a node.
89−setNodeValue :: forall a. a -> Tree a -> Tree a
90−setNodeValue a n = a :< (tail n)
91−
92−-- | Modify the value of a node.
93−modifyNodeValue :: forall a. (a -> a) -> Tree a -> Tree a
94−modifyNodeValue f n = f (head n) :< tail n
95−
96−-- | Append a child to a node.
97−appendChild :: forall a. Tree a -> Tree a -> Tree a
98−appendChild c n = head n :< snoc (tail n) c
src/Data/Tree/Zipper.pursdeleted−284
@@ -1,284 +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−derive newtype instance eqLoc :: Eq a => Eq (Loc a)
27−
28−-- -- Cursor movement
29−
30−-- | Move the cursor to the next sibling.
31−next :: forall a. Loc a -> Maybe (Loc a)
32−next (Loc r) =
33− case r.after of
34− Nil -> Nothing
35− (c:cs) -> Just $ Loc r { node = c
36− , before = r.node : r.before
37− , after = cs
38− }
39−
40−-- -- | Move the cursor to the previous sibling.
41−prev :: forall a. Loc a -> Maybe (Loc a)
42−prev (Loc r) =
43− case r.before of
44− Nil -> Nothing
45− (c:cs) -> Just $ Loc r { node = c
46− , before = cs
47− , after = r.node : r.after
48− }
49−
50−-- -- | Move the cursor to the first sibling.
51−first :: forall a. Loc a -> Loc a
52−first l@(Loc r) =
53− case reverse r.before of
54− Nil -> l
55− c:cs -> Loc r { node = c
56− , before = Nil
57− , after = cs <> r.after
58− }
59−
60−-- -- | Move the cursor to the last sibling.
61−last :: forall a. Loc a -> Loc a
62−last l@(Loc r) =
63− case reverse r.after of
64− Nil -> l
65− c:cs -> Loc r { node = c
66− , before = cs <> (r.node : r.before)
67− , after = Nil
68− }
69−
70−-- -- | Move the cursor to the parent `Node`.
71−up :: forall a. Loc a -> Maybe (Loc a)
72−up l@(Loc r) =
73− case r.parents of
74− Nil -> Nothing
75− (p:ps) -> Just $ Loc { node: (value p) :< (siblings l)
76− , before: before p
77− , after: after p
78− , parents: ps
79− }
80−
81−-- | Move the cursor to the root of the tree.
82−root :: forall a. Loc a -> Loc a
83−root l =
84− case up l of
85− Nothing -> l
86− Just p -> root p
87−
88−-- | Move the cursor to the first child of the current `Node`.
89−firstChild :: forall a. Loc a -> Maybe (Loc a)
90−firstChild n =
91− case children n of
92− Nil -> Nothing
93− c:cs ->
94− Just $ Loc { node: c
95− , before: Nil
96− , after: cs
97− , parents: n : (parents n)
98− }
99−
100−-- | Move the cursor to the first child of the current `Node`.
101−down :: forall a. Loc a -> Maybe (Loc a)
102−down = firstChild
103−
104−-- | Move the cursor to the last child of the current `Node`.
105−lastChild :: forall a. Loc a -> Maybe (Loc a)
106−lastChild n =
107− case reverse (children n) of
108− Nil -> Nothing
109− c:cs ->
110− Just $ Loc { node: c
111− , before: cs
112− , after: Nil
113− , parents: n : (parents n)
114− }
115−
116−-- | Move the cursor to a specific sibling by it's index.
117−siblingAt :: forall a. Int -> Loc a -> Maybe (Loc a)
118−siblingAt i l@(Loc r) = do
119− p@(Loc r') <- up l
120− c <- (children p) !! i
121− let before' = reverse $ take i (children p)
122− let after' = drop (i+1) (children p)
123− pure $ Loc { node: c
124− , before: before'
125− , after: after'
126− , parents: r.parents
127− }
128−
129−-- | Move the cursor to a specific child of the current `Node` by it's index.
130−childAt :: forall a. Int -> Loc a -> Maybe (Loc a)
131−childAt i p = (firstChild p) >>= (siblingAt i)
132−
133−
134−-- | Retrieve the `Tree` representation, i.e., returns the root `Node` of the
135−-- | current tree.
136−toTree :: forall a. Loc a -> Tree a
137−toTree = node <<< root
138−
139−-- | Get a `Loc`ation representation from a given `Tree`.
140−fromTree :: forall a. Tree a -> Loc a
141−fromTree n = Loc { node: n
142− , before: Nil
143− , after: Nil
144− , parents: Nil
145− }
146−
147−-- | Set the `Node` at the current position.
148−setNode :: forall a. Tree a -> Loc a -> Loc a
149−setNode a (Loc r) = Loc r { node = a }
150−
151−-- | Set the `Node` at the current position.
152−modifyNode :: forall a. (Tree a -> Tree a) -> Loc a -> Loc a
153−modifyNode f (Loc r) = Loc r { node = f r.node }
154−
155−-- | Set the value of the current `Node`.
156−setValue :: forall a. a -> Loc a -> Loc a
157−setValue a l = setNode (setNodeValue a (node l)) l
158−
159−-- | Modify the value of the current `Node`.
160−modifyValue :: forall a. (a -> a) -> Loc a -> Loc a
161−modifyValue f l = setNode (modifyNodeValue f (node l)) l
162−
163−-- -- insert and delete nodes
164−
165−-- | Insert a node after the current position, and move cursor to the new node.
166−insertAfter :: forall a. Tree a -> Loc a -> Loc a
167−insertAfter n (Loc r) = Loc r { node = n
168− , before = r.node : r.before
169− }
170−
171−-- | Insert a node before the current position, and move cursor to the new node.
172−insertBefore :: forall a. Tree a -> Loc a -> Loc a
173−insertBefore n (Loc r) = Loc r { node = n
174− , after = r.node : r.after
175− }
176−
177−-- | Insert a node as a child to the current node, and move cursor to the new node.
178−insertChild :: forall a. Tree a -> Loc a -> Loc a
179−insertChild n l =
180− case down l of
181− Just c -> insertAfter n c
182− Nothing -> Loc { node: n
183− , after: Nil
184− , before: Nil
185− , parents: l : (parents l)
186− }
187−
188−-- | Delete the node in the current position.
189−delete :: forall a. Loc a -> Loc a
190−delete l@(Loc r) =
191− case r.after of
192− c:cs -> Loc r { node = c
193− , after = cs
194− }
195− Nil ->
196− case r.before of
197− c:cs -> Loc r { node = c
198− , before = cs
199− }
200− Nil ->
201− case r.parents of
202− Nil -> l
203− c:cs -> Loc { node: mkTree (value c) Nil
204− , before: before c
205− , after: after c
206− , parents: parents c
207− }
208−
209−-- Searches
210−
211− -- | Search down and to the right for the first occurence where the given predicate is true and return the Loc
212−findDownWhere :: ∀ a. (a -> Boolean) -> Loc a -> Maybe (Loc a)
213−findDownWhere predicate loc | predicate $ value loc = Just loc
214−findDownWhere predicate loc = lookNext <|> lookDown
215− where
216− lookNext = next loc >>= findDownWhere predicate
217− lookDown = down loc >>= findDownWhere predicate
218−
219−-- | Search for the first occurence of the value `a` downwards and to the right.
220−findDown :: forall a. Eq a => a -> Loc a -> Maybe (Loc a)
221−findDown a = findDownWhere ( _ == a)
222−
223−-- | Search to the left and up for the first occurence where the given predicate is true and return the Loc
224−findUpWhere :: ∀ a. (a -> Boolean) -> Loc a -> Maybe (Loc a)
225−findUpWhere predicate loc | predicate $ value loc = Just loc
226−findUpWhere predicate loc = lookPrev <|> lookUp
227− where
228− lookPrev = prev loc >>= findUpWhere predicate
229− lookUp = up loc >>= findUpWhere predicate
230−
231−-- | Search for the first occurence of the value `a` upwards and to the left,
232−findUp :: forall a. Eq a => a -> Loc a -> Maybe (Loc a)
233−findUp a = findUpWhere (_ == a)
234−
235−-- | Search from the root of the tree for the first occurrence where the given predicate is truen and return the Loc
236−findFromRootWhere :: ∀ a. (a -> Boolean) -> Loc a -> Maybe (Loc a)
237−findFromRootWhere predicate loc | predicate $ value loc = Just loc
238−findFromRootWhere predicate loc = findDownWhere predicate $ root loc
239−
240−-- | Search for the first occurence of the value `a` starting from the root of
241−-- | the tree.
242−findFromRoot :: forall a. Eq a => a -> Loc a -> Maybe (Loc a)
243−findFromRoot a = findFromRootWhere (_ == a)
244−
245−-- | flattens the Tree into a List depth first.
246−flattenLocDepthFirst :: ∀ a. Loc a -> List (Loc a)
247−flattenLocDepthFirst loc = loc : (go loc)
248− where
249− go :: Loc a -> List (Loc a)
250− go loc' =
251− let
252− downs = goDir loc' down
253− nexts = goDir loc' next
254− in
255− downs <> nexts
256−
257− goDir :: Loc a -> (Loc a -> Maybe (Loc a)) -> List (Loc a)
258− goDir loc' dirFn = case (dirFn loc') of
259− Just l -> l : go l
260− Nothing -> Nil
261−
262−
263−
264−-- Setters and Getters
265−node :: forall a. Loc a -> Tree a
266−node (Loc r) = r.node
267−
268−value :: forall a. Loc a -> a
269−value = head <<< node
270−
271−before :: forall a. Loc a -> Forest a
272−before (Loc r) = r.before
273−
274−after :: forall a. Loc a -> Forest a
275−after (Loc r) = r.after
276−
277−parents :: forall a. Loc a -> List (Loc a)
278−parents (Loc r) = r.parents
279−
280−children :: forall a. Loc a -> Forest a
281−children = tail <<< node
282−
283−siblings :: forall a. Loc a -> Forest a
284−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+187−260
@@ -3,68 +3,71 @@ module Test.Main where
33import Prelude
44
55import Control.Comonad.Cofree (head, (:<))
6−import Data.List (List(Nil), (:))
76import Data.Maybe (Maybe(..), fromJust)
8−import Data.Tree (Tree, mkTree, scanTree)
9−import Data.Tree.Zipper (down, findDownWhere, findFromRoot, findUp, flattenLocDepthFirst, fromTree, insertAfter, modifyValue, next, toTree, value, firstChild, lastChild)
107import Effect (Effect)
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
1825sampleTree =
1926 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
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
38+main = launchAff_ $ runSpec [ consoleReporter ] do
3339 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
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
6871
6972 describe "Zipper" do
7073
@@ -74,221 +77,145 @@ main = run [consoleReporter] do
7477
7578 let root' = unsafePartial $ toTree $ modifyValue (\a -> 2 * a) (fromJust $ down root)
7679 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 root1 = unsafePartial $ toTree $ insertAfter (mkTree 100 Nil) (fromJust $ down root)
109− let root2 = unsafePartial $ toTree $ insertAfter (mkTree 100 Nil) (fromJust $ (down root) >>= next >>= next >>= down >>= next >>= down)
110− let root3 = unsafePartial $ toTree $ insertAfter (mkTree 100 Nil) (fromJust $ (firstChild root))
111− let root4 = unsafePartial $ toTree $ insertAfter (mkTree 100 Nil) (fromJust $ (lastChild root))
112−
113− let result1 =
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 result2 =
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− let result3 =
142− 1 :<
143− (2 :< Nil)
144− : (100 :< Nil)
145− : (3 :< Nil)
146− : (4 :<
147− (5 :< Nil)
148− : (6 :<
149− (7 :< Nil)
150− : Nil
151− )
152− : (8 :< Nil)
153− : Nil
154− )
155− : Nil
156− let result4 =
157− 1 :<
158− (2 :< Nil)
159− : (3 :< Nil)
160− : (4 :<
161− (5 :< Nil)
162− : (6 :<
163− (7 :< Nil) : Nil)
164− : (8 :< Nil)
165− : Nil
166− )
167− : (100 :< Nil)
168− : Nil
169− shouldEqual (eq root1 result1) true
170− shouldEqual (eq root2 result2) true
171− shouldEqual (eq root3 result3) true
172− shouldEqual (eq root4 result4) true
173−
174− it "Should findDownWhere with single node" do
175− let tree = 1 :< Nil
176− let loc = fromTree tree
177− shouldEqual (Just 1) ((findDownWhere (_ == 1) loc) <#> value)
178−
179− it "Should findDownWhere with 2 nodes and 2 levels" do
180− let tree = 1 :<
181− (2 :< Nil)
182− : Nil
183− -- log $ showTree tree
184− let loc = fromTree tree
185− shouldEqual (Just 2) ((findDownWhere (_ == 2) loc) <#> value)
186−
187− it "Should findDownWhere with 3 nodes and 2 levels" do
188− let tree = 1 :<
189− (2 :< Nil)
190− : (3 :< Nil)
191− : Nil
192− -- log $ showTree tree
193− let loc = fromTree tree
194− shouldEqual (Just 3) ((findDownWhere (_ == 3) loc) <#> value)
195−
196− it "Should findDownWhere with 4 nodes and 2 levels" do
197− let tree = 1 :<
198− (2 :< Nil)
199− : (3 :< Nil)
200− : (4 :< Nil)
201− : Nil
202− -- log $ showTree tree
203− let loc = fromTree tree
204− shouldEqual (Just 4) ((findDownWhere (_ == 4) loc) <#> value)
205−
206− it "Should findDownWhere with 5 nodes and 3 levels" do
207− let tree = 1 :<
208− (2 :< Nil)
209− : (3 :< Nil)
210− : (4 :<
211− (5 :< Nil)
212− : Nil)
213− : Nil
214− -- log $ showTree tree
215− let loc = fromTree tree
216− shouldEqual (Just 5) ((findDownWhere (_ == 5) loc) <#> value)
217−
218− it "Should findDownWhere with 6 nodes and 3 levels" do
219− let tree = 1 :<
220− (2 :< Nil)
221− : (3 :< Nil)
222− : (4 :<
223− (5 :< Nil)
224− : (6 :< Nil)
225− : Nil)
226− : Nil
227− -- log $ showTree tree
228− let loc = fromTree tree
229− shouldEqual (Just 6) ((findDownWhere (_ == 6) loc) <#> value)
230−
231− it "Should findDownWhere with 7 nodes and 4 levels" do
232− let tree = 1 :<
233− (2 :< Nil)
234− : (3 :< Nil)
235− : (4 :<
236− (5 :< Nil)
237− : (6 :<
238− (7 :< Nil) : Nil)
239− : Nil)
240− : Nil
241− -- log $ showTree tree
242− let loc = fromTree tree
243− shouldEqual (Just 7) ((findDownWhere (_ == 7) loc) <#> value)
244−
245− it "Should findDownWhere with 8 nodes and 4 levels" do
246− let tree = 1 :<
247− (2 :< Nil)
248− : (3 :< Nil)
249− : (4 :<
250− (5 :< Nil)
251− : (6 :<
252− (7 :< Nil) : Nil)
253− : (8 :< Nil)
254− : Nil)
255− : Nil
256− -- log $ showTree tree
257− let loc = fromTree tree
258− shouldEqual (Just 8) ((findDownWhere (_ == 8) loc) <#> value)
259−
260− it "Should findDownWhere with 8 nodes and 4 levels with a step back" do
261− let tree = 1 :<
262− (2 :< Nil)
263− : (3 :< Nil)
264− : (4 :<
265− (5 :< Nil)
266− : (6 :<
267− (7 :< Nil) : Nil)
268− : (8 :< Nil)
269− : Nil)
270− : Nil
271− -- log $ showTree tree
272− let loc = fromTree tree
273− shouldEqual (Just 7) ((findDownWhere (_ == 7) loc) <#> value)
274−
275− it "Should find 7 from the sampleTree" do
276− shouldEqual (Just 7) (findDownWhere (_ == 7) (fromTree sampleTree) <#> value)
277−
278− it "Should find 8 from the sampleTree (the bottom) and then find 1 (the top) with findUp" do
279− let eight = unsafePartial $ fromJust $ findDownWhere (_ == 8) $ fromTree sampleTree
280− shouldEqual (Just 1) (findUp 1 eight <#> value)
281−
282− it "Should find 8 from the sampleTree (the bottom) but then not find 7 because it would require a downward traversal" do
283− let eight = unsafePartial $ fromJust $ findDownWhere (_ == 8) $ fromTree sampleTree
284− shouldEqual Nothing (findUp 7 eight <#> value)
285−
286− it "Should find 8 from the sampleTree (the bottom) and then find 7 using findFromRoot" do
287− let eight = unsafePartial $ fromJust $ findDownWhere (_ == 8) $ fromTree sampleTree
288− shouldEqual (Just 7) (findFromRoot 7 eight <#> value)
289−
290− it "Should flatten the Tree into a list of locations following a depth first pattern" do
291− let flat = map value $ flattenLocDepthFirst $ fromTree sampleTree
292− --log $ showTree sampleTree
293− --log $ show flat
294− shouldEqual flat (1 : 2 : 3 : 4 : 5 : 6 : 7 : 8 : Nil)
80+
81+ let
82+ result =
83+ 1 :<
84+ [ leaf 4
85+ , leaf 3
86+ , 4 :<
87+ [ leaf 5
88+ , 6 :< [ leaf 7 ]
89+ , leaf 8
90+ ]
91+
92+ ]
93+
94+ let
95+ result' =
96+ 1 :<
97+ [ 2 :< []
98+ , 3 :< []
99+ , 4 :<
100+ [ 10 :< []
101+ , 6 :< [ 7 :< [] ]
102+ , 8 :< []
103+ ]
104+ ]
105+
106+ SpecTree root' `shouldEqual` SpecTree result
107+ SpecTree root'' `shouldEqual` SpecTree result'
108+
109+ -- it "Insert" do
110+
111+ -- let root1 = unsafePartial $ toTree $ insertAfter (mkLeaf 100) (fromJust $ down root)
112+ -- let root2 = unsafePartial $ toTree $ insertAfter (mkLeaf 100) (fromJust $ (down root) >>= next >>= next >>= down >>= next >>= down)
113+ -- let root3 = unsafePartial $ toTree $ insertAfter (mkLeaf 100) (fromJust $ (firstChild root))
114+ -- let root4 = unsafePartial $ toTree $ insertAfter (mkLeaf 100) (fromJust $ (lastChild root))
115+
116+ -- let result1 = 1 :< []
117+ -- let result2 = 1 :< []
118+ -- let result3 = 1 :< []
119+ -- let result4 = 1 :< []
120+ -- shouldEqual (eq root1 result1) true
121+ -- shouldEqual (eq root2 result2) true
122+ -- shouldEqual (eq root3 result3) true
123+ -- shouldEqual (eq root4 result4) true
124+
125+ it "Should findDownWhere with single node" do
126+ let tree = 1 :< []
127+ let loc = fromTree tree
128+ shouldEqual (Just 1) ((findDownWhere (_ == 1) loc) <#> value)
129+
130+ it "Should findDownWhere with 2 nodes and 2 levels" do
131+ let tree = 1 :< [ leaf 2 ]
132+ let loc = fromTree tree
133+ shouldEqual (Just 2) ((findDownWhere (_ == 2) loc) <#> value)
134+
135+ it "Should findDownWhere with 3 nodes and 2 levels" do
136+ let tree = 1 :< [ leaf 2, leaf 3 ]
137+ let loc = fromTree tree
138+ shouldEqual (Just 3) ((findDownWhere (_ == 3) loc) <#> value)
139+
140+ it "Should findDownWhere with 4 nodes and 2 levels" do
141+ let tree = 1 :< (leaf <$> [ 2, 3, 4 ])
142+ let loc = fromTree tree
143+ shouldEqual (Just 4) ((findDownWhere (_ == 4) loc) <#> value)
144+
145+ it "Should findDownWhere with 5 nodes and 3 levels" do
146+ let
147+ tree = 1 :<
148+ [ leaf 2
149+ , leaf 3
150+ , 4 :< [ leaf 5 ]
151+ ]
152+ -- log $ showTree tree
153+ let loc = fromTree tree
154+ shouldEqual (Just 5) ((findDownWhere (_ == 5) loc) <#> value)
155+
156+ it "Should findDownWhere with 6 nodes and 3 levels" do
157+ let
158+ tree = 1 :<
159+ [ leaf 2
160+ , leaf 3
161+ , 4 :< [ leaf 5, leaf 6 ]
162+ ]
163+ -- log $ showTree tree
164+ let loc = fromTree tree
165+ shouldEqual (Just 6) ((findDownWhere (_ == 6) loc) <#> value)
166+
167+ it "Should findDownWhere with 7 nodes and 4 levels" do
168+ let
169+ tree = 1 :<
170+ [ leaf 2
171+ , leaf 3
172+ , 4 :< [ leaf 5, 6 :< [ leaf 7 ] ]
173+ ]
174+ -- log $ showTree tree
175+ let loc = fromTree tree
176+ shouldEqual (Just 7) ((findDownWhere (_ == 7) loc) <#> value)
177+
178+ it "Should findDownWhere with 8 nodes and 4 levels" do
179+ let
180+ tree = 1 :<
181+ [ leaf 2
182+ , leaf 3
183+ , 4 :< [ leaf 5, 6 :< [ leaf 7 ] ]
184+ , leaf 8
185+ ]
186+ -- log $ showTree tree
187+ let loc = fromTree tree
188+ shouldEqual (Just 8) ((findDownWhere (_ == 8) loc) <#> value)
189+
190+ it "Should findDownWhere with 8 nodes and 4 levels with a step back" do
191+ let
192+ tree = 1 :<
193+ [ leaf 2
194+ , leaf 3
195+ , 4 :< [ leaf 5, 6 :< [ leaf 7 ] ]
196+ , leaf 8
197+ ]
198+ -- log $ showTree tree
199+ let loc = fromTree tree
200+ shouldEqual (Just 7) ((findDownWhere (_ == 7) loc) <#> value)
201+
202+ it "Should find 7 from the sampleTree" do
203+ shouldEqual (Just 7) (findDownWhere (_ == 7) (fromTree sampleTree) <#> value)
204+
205+ it "Should find 8 from the sampleTree (the bottom) and then find 1 (the top) with findUp" do
206+ let eight = unsafePartial $ fromJust $ findDownWhere (_ == 8) $ fromTree sampleTree
207+ shouldEqual (Just 1) (findUp 1 eight <#> value)
208+
209+ it "Should find 8 from the sampleTree (the bottom) but then not find 7 because it would require a downward traversal" do
210+ let eight = unsafePartial $ fromJust $ findDownWhere (_ == 8) $ fromTree sampleTree
211+ shouldEqual Nothing (findUp 7 eight <#> value)
212+
213+ it "Should find 8 from the sampleTree (the bottom) and then find 7 using findFromRoot" do
214+ let eight = unsafePartial $ fromJust $ findDownWhere (_ == 8) $ fromTree sampleTree
215+ shouldEqual (Just 7) (findFromRoot 7 eight <#> value)
216+
217+ it "Should flatten the Tree into a list of locations following a depth first pattern" do
218+ let flat = map value $ flattenLocDepthFirst $ fromTree sampleTree
219+ --log $ showTree sampleTree
220+ --log $ show flat
221+ shouldEqual flat [1,2,3,4,5,6,7,8]