git.iko.soy/rowtype-yoga/purescript-yoga-tree
on f5f7c7f help sign in
148d006
swap
0 ahead, 26 behind
13 files changed+803−787
since splitsnapshots
unifiedsplit
.travis.yml+3−3 README.md+5−19 bower.json+22−23 package.json+3−3 packages.dhall+119−3 spago.dhall+6−12 src/Data/Tree.purs+98 src/Data/Tree/Zipper.purs+284 src/Yoga/Tree.purs−92 src/Yoga/Tree/Zipper.purs−333 test.dhall+3−19 test/Example.purs−93 test/Main.purs+260−187
.travis.yml+3−3
@@ -2,7 +2,7 @@ node_js:
22 - "node"
33language: node_js
44install:
5− - npm install -g purescript spago
6− - spago install
5+ - npm install -g purescript pulp bower
6+ - bower install
77script:
8− - spago -x test.dhall test
8+ - pulp test
README.md+5−19
@@ -1,29 +1,15 @@
1−# purescript-yoga-tree
1+# purescript-tree
22
3−Multi-way trees (Rose Trees) with Zippers.
3+[![Build status](https://img.shields.io/travis/dmbfm/purescript-tree.svg)](https://travis-ci.org/dmbfm/purescript-tree)
44
5−This is a fork of `purescript-tree-rose` that uses `Array`s instead of `List`s.
5+Multi-way trees with Zippers.
66
77## Installation
88
99```
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−
10+bower install purescript-tree
2511```
2612
2713## Documentation
2814
29−Module documentation is [published on Pursuit](http://pursuit.purescript.org/packages/purescript-yoga-tree).
15+Module documentation is [published on Pursuit](http://pursuit.purescript.org/packages/purescript-tree).
bower.json+22−23
@@ -1,25 +1,24 @@
11{
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− }
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+ }
2524}
package.json+3−3
@@ -1,7 +1,7 @@
11{
2− "name": "purescript-yoga-tree",
3− "version": "4.0.0",
4− "description": "A Tree data structure inspired by Haskell's Data.Tree",
2+ "name": "purescript-tree",
3+ "version": "1.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+119−3
@@ -1,5 +1,121 @@
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+
1114let upstream =
2− https://github.com/purescript/package-sets/releases/download/psc-0.15.4-20220822/packages.dhall
3− sha256:908b4ffbfba37a0a4edf806513a555d0dbcdd0cde7abd621f8d018d2e8ecf828
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 = {=}
4120
5−in upstream
121+in upstream // overrides // additions
spago.dhall+6−12
@@ -1,15 +1,9 @@
1+{-
2+Welcome to a Spago project!
3+You can edit this file as you like.
4+-}
15{ 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− ]
6+, name = "my-project"
7+, dependencies = [ "prelude", "lists", "free" ]
148, packages = ./packages.dhall
159}
src/Data/Tree.pursnew file+98
@@ -0,0 +1,98 @@
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.pursnew file+284
@@ -0,0 +1,284 @@
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.pursdeleted−92
@@ -1,92 +0,0 @@
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.pursdeleted−333
@@ -1,333 +0,0 @@
1−module Yoga.Tree.Zipper where
2−
3−import Prelude
4−import Control.Alt ((<|>))
5−import Control.Comonad.Cofree (head, tail, (:<))
6−import Data.Array (drop, reverse, take, uncons, (!!), (:))
7−import Data.Maybe (Maybe(Just, Nothing))
8−import Yoga.Tree (Forest, Tree, mkTree, modifyNodeValue, setNodeValue)
9−
10−-- | The `Loc` type describes the location of a `Node` inside a `Tree`. For this
11−-- | we store the current `Node`, the sibling nodes that appear before the current
12−-- | node, the sibling nodes that appear after the current node, and a `Array` of
13−-- | `Loc`ations that store the parent node locations up to the root of the three.
14−-- |
15−-- | So, effectively, the `parents` field records the path travelled in the
16−-- | tree to reach the level of the current `Node` starting from the tree's root,
17−-- | and the `before` and `after` fields describe its location in the current
18−-- | level.
19−newtype Loc a = Loc
20− { node ∷ Tree a
21− , before ∷ Forest a
22− , after ∷ Forest a
23− , parents ∷ Array (Loc a)
24− }
25−
26−instance eqLoc ∷ Eq a => Eq (Loc a) where
27− eq (Loc r1) (Loc r2) =
28− (r1.node == r2.node)
29− && (r1.before == r2.before)
30− && (r1.after == r2.after)
31− && (r1.parents == r2.parents)
32−
33−-- -- Cursor movement
34−-- | Move the cursor to the next sibling.
35−next ∷ ∀ a. Loc a -> Maybe (Loc a)
36−next (Loc r) = case uncons r.after of
37− Nothing -> Nothing
38− Just { head: c, tail: cs } ->
39− Just
40− $ Loc
41− { node: c
42− , before: r.node : r.before
43− , after: cs
44− , parents: r.parents
45− }
46−
47−-- -- | Move the cursor to the previous sibling.
48−prev ∷ ∀ a. Loc a -> Maybe (Loc a)
49−prev (Loc r) = case uncons r.before of
50− Nothing -> Nothing
51− Just { head: c, tail: cs } ->
52− Just
53− $ Loc
54− { node: c
55− , before: cs
56− , after: r.node : r.after
57− , parents: r.parents
58− }
59−
60−-- -- | Move the cursor to the first sibling.
61−first ∷ ∀ a. Loc a -> Loc a
62−first l@(Loc r) = case uncons r.before of
63− Nothing -> l
64− Just { head: c, tail: cs } ->
65− Loc
66− $
67− { node: c
68− , before: []
69− , after: (reverse cs) <> r.after
70− , parents: r.parents
71− }
72−
73−-- -- | Move the cursor to the last sibling.
74−last ∷ ∀ a. Loc a -> Loc a
75−last l@(Loc r) = case uncons (reverse r.after) of
76− Nothing -> l
77− Just { head: c, tail: cs } ->
78− Loc
79− $
80− { node: c
81− , before: cs <> r.before
82− , after: []
83− , parents: r.parents
84− }
85−
86−-- -- | Move the cursor to the parent `Node`.
87−up ∷ ∀ a. Loc a -> Maybe (Loc a)
88−up l@(Loc r) = case uncons r.parents of
89− Nothing -> Nothing
90− Just { head: p, tail: ps } ->
91− Just
92− $ Loc
93− { node: (value p) :< (siblings l)
94− , before: before p
95− , after: after p
96− , parents: ps
97− }
98−
99−-- | Move the cursor to the root of the tree.
100−root ∷ ∀ a. Loc a -> Loc a
101−root l = case up l of
102− Nothing -> l
103− Just p -> root p
104−
105−-- | Move the cursor to the first child of the current `Node`.
106−firstChild ∷ ∀ a. Loc a -> Maybe (Loc a)
107−firstChild n = case uncons (children n) of
108− Nothing -> Nothing
109− Just { head: c, tail: cs } ->
110− Just
111− $ Loc
112− { node: c
113− , before: []
114− , after: cs
115− , parents: n : (parents n)
116− }
117−
118−-- | Move the cursor to the first child of the current `Node`.
119−down ∷ ∀ a. Loc a -> Maybe (Loc a)
120−down = firstChild
121−
122−-- | Move the cursor to the last child of the current `Node`.
123−lastChild ∷ ∀ a. Loc a -> Maybe (Loc a)
124−lastChild p = last <$> down p
125−
126−-- | Move the cursor to a specific sibling by it's index.
127−siblingAt ∷ ∀ a. Int -> Loc a -> Maybe (Loc a)
128−siblingAt i l@(Loc r) = case up l of
129− Nothing -> Nothing
130− Just p -> case (children p) !! i of
131− Nothing -> Nothing
132− Just c ->
133− let
134− before' = reverse $ take i (children p)
135− after' = drop (i + 1) (children p)
136− in
137− Just
138− $ Loc
139− { node: c
140− , before: before'
141− , after: after'
142− , parents: r.parents
143− }
144−
145−-- | Move the cursor to a specific child of the current `Node` by it's index.
146−childAt ∷ ∀ a. Int -> Loc a -> Maybe (Loc a)
147−childAt i p = (firstChild p) >>= (siblingAt i)
148−
149−-- | Retrieve the `Tree` representation, i.e., returns the root `Node` of the
150−-- | current tree.
151−toTree ∷ ∀ a. Loc a -> Tree a
152−toTree = node <<< root
153−
154−-- | Get a `Loc`ation representation from a given `Tree`.
155−fromTree ∷ ∀ a. Tree a -> Loc a
156−fromTree n =
157− Loc
158− { node: n
159− , before: []
160− , after: []
161− , parents: []
162− }
163−
164−-- | Set the `Node` at the current position.
165−setNode ∷ ∀ a. Tree a -> Loc a -> Loc a
166−setNode a (Loc r) =
167− Loc
168− { node: a
169− , before: r.before
170− , after: r.after
171− , parents: r.parents
172− }
173−
174−-- | Set the `Node` at the current position.
175−modifyNode ∷ ∀ a. (Tree a -> Tree a) -> Loc a -> Loc a
176−modifyNode f (Loc r) =
177− Loc
178− { node: f r.node
179− , before: r.before
180− , after: r.after
181− , parents: r.parents
182− }
183−
184−-- | Set the value of the current `Node`.
185−setValue ∷ ∀ a. a -> Loc a -> Loc a
186−setValue a l = setNode (setNodeValue a (node l)) l
187−
188−-- | Modify the value of the current `Node`.
189−modifyValue ∷ ∀ a. (a -> a) -> Loc a -> Loc a
190−modifyValue f l = setNode (modifyNodeValue f (node l)) l
191−
192−-- -- insert and delete nodes
193−-- | Insert a node after the current position, and move cursor to the new node.
194−insertAfter ∷ ∀ a. Tree a -> Loc a -> Loc a
195−insertAfter n l =
196− Loc
197− { node: n
198− , after: after l
199− , before: (node l) : (before l)
200− , parents: parents l
201− }
202−
203−-- | Insert a node before the current position, and move cursor to the new node.
204−insertBefore ∷ ∀ a. Tree a -> Loc a -> Loc a
205−insertBefore n l =
206− Loc
207− { node: n
208− , after: (node l) : (after l)
209− , before: before l
210− , parents: parents l
211− }
212−
213−-- | Insert a node as a child to the current node, and move cursor to the new node.
214−insertChild ∷ ∀ a. Tree a -> Loc a -> Loc a
215−insertChild n l = case down l of
216− Just c -> insertAfter n c
217− Nothing ->
218− Loc
219− { node: n
220− , after: []
221− , before: []
222− , parents: l : (parents l)
223− }
224−
225−-- | Delete the node in the current position.
226−delete ∷ ∀ a. Loc a -> Loc a
227−delete l@(Loc r) = case uncons r.after of
228− Just { head: c, tail: cs } ->
229− Loc
230− { node: c
231− , before: r.before
232− , after: cs
233− , parents: r.parents
234− }
235− Nothing -> case uncons r.before of
236− Just { head: c, tail: cs } ->
237− Loc
238− { node: c
239− , before: cs
240− , after: r.after
241− , parents: r.parents
242− }
243− Nothing -> case uncons r.parents of
244− Nothing -> l
245− Just { head: c } ->
246− Loc
247− { node: mkTree (value c) []
248− , before: before c
249− , after: after c
250− , parents: parents c
251− }
252−
253−-- Searches
254−-- | Search down and to the right for the first occurence where the given predicate is true and return the Loc
255−findDownWhere ∷ ∀ a. (a -> Boolean) -> Loc a -> Maybe (Loc a)
256−findDownWhere predicate loc
257− | predicate $ value loc = Just loc
258−
259−findDownWhere predicate loc = lookNext <|> lookDown
260− where
261− lookNext = next loc >>= findDownWhere predicate
262−
263− lookDown = down loc >>= findDownWhere predicate
264−
265−-- | Search for the first occurence of the value `a` downwards and to the right.
266−findDown ∷ ∀ a. Eq a => a -> Loc a -> Maybe (Loc a)
267−findDown a = findDownWhere (_ == a)
268−
269−-- | Search to the left and up for the first occurence where the given predicate is true and return the Loc
270−findUpWhere ∷ ∀ a. (a -> Boolean) -> Loc a -> Maybe (Loc a)
271−findUpWhere predicate loc
272− | predicate $ value loc = Just loc
273−
274−findUpWhere predicate loc = lookPrev <|> lookUp
275− where
276− lookPrev = prev loc >>= findUpWhere predicate
277−
278− lookUp = up loc >>= findUpWhere predicate
279−
280−-- | Search for the first occurence of the value `a` upwards and to the left,
281−findUp ∷ ∀ a. Eq a => a -> Loc a -> Maybe (Loc a)
282−findUp a = findUpWhere (_ == a)
283−
284−-- | Search from the root of the mkTree for the first occurrence where the given predicate is truen and return the Loc
285−findFromRootWhere ∷ ∀ a. (a -> Boolean) -> Loc a -> Maybe (Loc a)
286−findFromRootWhere predicate loc
287− | predicate $ value loc = Just loc
288−
289−findFromRootWhere predicate loc = findDownWhere predicate $ root loc
290−
291−-- | Search for the first occurence of the value `a` starting from the root of
292−-- | the tree.
293−findFromRoot ∷ ∀ a. Eq a => a -> Loc a -> Maybe (Loc a)
294−findFromRoot a = findFromRootWhere (_ == a)
295−
296−-- | flattens the Tree into a Array depth first.
297−flattenLocDepthFirst ∷ ∀ a. Loc a -> Array (Loc a)
298−flattenLocDepthFirst loc = loc : (go loc)
299− where
300− go ∷ Loc a -> Array (Loc a)
301− go loc' =
302− let
303− downs = goDir loc' down
304− nexts = goDir loc' next
305− in
306− downs <> nexts
307−
308− goDir ∷ Loc a -> (Loc a -> Maybe (Loc a)) -> Array (Loc a)
309− goDir loc' dirFn = case (dirFn loc') of
310− Just l -> l : go l
311− Nothing -> []
312−
313−-- Setters and Getters
314−node ∷ ∀ a. Loc a -> Tree a
315−node (Loc r) = r.node
316−
317−value ∷ ∀ a. Loc a -> a
318−value = head <<< node
319−
320−before ∷ ∀ a. Loc a -> Forest a
321−before (Loc r) = r.before
322−
323−after ∷ ∀ a. Loc a -> Forest a
324−after (Loc r) = r.after
325−
326−parents ∷ ∀ a. Loc a -> Array (Loc a)
327−parents (Loc r) = r.parents
328−
329−children ∷ ∀ a. Loc a -> Forest a
330−children = tail <<< node
331−
332−siblings ∷ ∀ a. Loc a -> Forest a
333−siblings (Loc r) = (reverse r.before) <> (r.node : r.after)
test.dhall+3−19
@@ -1,20 +1,4 @@
11let 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− }
2+in config // { sources = config.sources # [ "test/**/*.purs" ]
3+ , dependencies = [ "console", "spec" ]
4+ }
test/Example.pursdeleted−93
@@ -1,93 +0,0 @@
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+260−187
@@ -3,71 +3,68 @@ module Test.Main where
33import Prelude
44
55import Control.Comonad.Cofree (head, (:<))
6+import Data.List (List(Nil), (:))
67import 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)
710import Effect (Effect)
8−import Effect.Aff (launchAff_)
911import Partial.Unsafe (unsafePartial)
1012import Test.Spec (describe, it)
1113import Test.Spec.Assertions (shouldEqual)
1214import Test.Spec.Reporter (consoleReporter)
13−import Test.Spec.Runner (runSpec)
14−import Yoga.Tree (Tree, leaf, scanTree, showTree)
15−import Yoga.Tree.Zipper (down, findDownWhere, findFromRoot, findUp, flattenLocDepthFirst, fromTree, modifyValue, next, toTree, value)
16−
17−newtype SpecTree a = SpecTree (Tree a)
18−
19−instance Show a => Show (SpecTree a) where
20− show (SpecTree t) = showTree t
21−
22−derive instance (Eq a) => Eq (SpecTree a)
15+import Test.Spec.Runner (run)
2316
2417sampleTree :: Tree Int
2518sampleTree =
2619 1 :<
27− [ leaf 2
28− , leaf 3
29− , 4 :<
30− [ leaf 5
31− , 6 :< [ leaf 7 ]
32− , leaf 8
33− ]
34−
35− ]
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
3630
3731main :: Effect Unit
38−main = launchAff_ $ runSpec [ consoleReporter ] do
32+main = run [consoleReporter] do
3933 describe "Tree" do
4034
4135 it "mkTree" do
42− let t = 10 :< []
36+ let t = mkTree 10 Nil
4337 shouldEqual (head t) 10
4438
4539 it "Functor" do
46− let
47− result = 2 :<
48− [ leaf 3
49− , leaf 4
50− , 5 :<
51− [ leaf 6
52− , 7 :< [ leaf 8 ]
53− , leaf 9
54− ]
55− ]
56− SpecTree (((+) 1) <$> sampleTree) `shouldEqual` SpecTree result
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
5753
5854 it "scanTree" do
59− let
60− result =
61− 1 :<
62− [ leaf 3
63− , leaf 4
64− , 5 :<
65− [ leaf 10
66− , 11 :< [ leaf 18 ]
67− , leaf 13
68− ]
69− ]
70− SpecTree (scanTree (\a b -> a + b) 0 sampleTree) `shouldEqual` SpecTree result
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
7168
7269 describe "Zipper" do
7370
@@ -77,145 +74,221 @@ main = launchAff_ $ runSpec [ consoleReporter ] do
7774
7875 let root' = unsafePartial $ toTree $ modifyValue (\a -> 2 * a) (fromJust $ down root)
7976 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]
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)