git.iko.soy/rowtype-yoga/purescript-yoga-tree
on master help sign in
swap
148d00621 ahead, 0 behind
.travis.yml+3−3
since splitsnapshots
unifiedsplit
@@ -2,7 +2,7 @@ node_js:
2 - "node"
2 - "node"
3language: node_js
3language: node_js
4install:
4install:
5− - npm install -g purescript pulp bower
5+ - npm install -g purescript spago
6− - bower install
6+ - spago install
7script:
7script:
8− - pulp test
8+ - spago -x test.dhall test
README.md+14−8
@@ -1,18 +1,24 @@
1−# purescript-tree-rose
1+# purescript-yoga-tree
2−
3−[![Build status](https://img.shields.io/travis/jordanmartinez/purescript-tree-rose.svg)](https://travis-ci.com/jordanmartinez/purescript-tree-rose)
4
2
5Multi-way trees (Rose Trees) with Zippers.
3Multi-way trees (Rose Trees) with Zippers.
6
4
7−This is a maintained fork of `purescript-tree`.
5+This is a fork of `purescript-tree-rose` that uses `Array`s instead of `List`s.
8
6
9## Installation
7## Installation
10
8
11```
9```
12−{ tree-rose =
10+{ yoga-tree =
13− { dependencies = [ "prelude", "lists", "free" ]
11+ { dependencies =
12+ [ "arrays"
13+ , "control"
14+ , "foldable-traversable"
15+ , "free"
16+ , "maybe"
17+ , "prelude"
18+ , "tailrec"
19+ ]
14 , version = "master"
20 , version = "master"
15− , repo = "https://github.com/JordanMartinez/purescript-tree-rose.git"
21+ , repo = "https://github.com/rowtype-yoga/purescript-yoga-tree.git"
16 }
22 }
17}
23}
18
24
@@ -20,4 +26,4 @@ This is a maintained fork of `purescript-tree`.
20
26
21## Documentation
27## Documentation
22
28
23−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 @@
1{
1{
2− "name": "purescript-tree-rose",
2+ "name": "purescript-yoga-tree",
3− "license": "MIT",
3+ "license": [
4+ "MIT"
5+ ],
6+ "repository": {
7+ "type": "git",
8+ "url": "https://github.com/jordanmartinez/purescript-tree-rose"
9+ },
4− "ignore": [
10+ "ignore": [
5− "**/.*",
11+ "**/.*",
6− "node_modules",
12+ "node_modules",
7− "bower_components",
13+ "bower_components",
8− "output"
14+ "output"
9− ],
15+ ],
10− "repository": {
11− "type": "git",
12− "url": "git://github.com/jordamartinez/purescript-tree-rose.git"
13− },
14− "dependencies": {
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",
15− "purescript-prelude": "^4.1.1",
22+ "purescript-prelude": "^v6.0.1",
16− "purescript-lists": "^5.4.1",
23+ "purescript-tailrec": "^v6.0.0"
17− "purescript-free": "^5.2.0"
18− },
19− "devDependencies": {
20− "purescript-psci-support": "^4.0.0",
21− "purescript-console": "^4.4.0",
22− "purescript-spec": "^4.0.1",
23− }
24+ }
24}
25}
package.json+3−3
@@ -1,7 +1,7 @@
1{
1{
2− "name": "purescript-tree",
2+ "name": "purescript-yoga-tree",
3− "version": "1.0.0",
3+ "version": "4.0.0",
4− "description": "A Tree data structure inspired by haskell's Data.Tree",
4+ "description": "A Tree data structure inspired by Haskell's Data.Tree",
5 "main": "index.js",
5 "main": "index.js",
6 "author": "Daniel Fortes",
6 "author": "Daniel Fortes",
7 "license": "MIT"
7 "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−
114let upstream =
1let upstream =
115− https://github.com/purescript/package-sets/releases/download/psc-0.13.6-20200507/packages.dhall sha256:9c1e8951e721b79de1de551f31ecb5a339e82bbd43300eb5ccfb1bf8cf7bbd62
2+ https://github.com/purescript/package-sets/releases/download/psc-0.15.4-20220822/packages.dhall
116−
3+ sha256:908b4ffbfba37a0a4edf806513a555d0dbcdd0cde7abd621f8d018d2e8ecf828
117−let overrides = {=}
118−
119−let additions = {=}
120
4
121−in upstream // overrides // additions
5+in upstream
spago.dhall+12−6
@@ -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" ]
1{ sources = [ "src/**/*.purs" ]
6−, name = "my-project"
2+, license = "MIT"
3+, repository = "https://github.com/jordanmartinez/purescript-tree-rose"
4+, name = "yoga-tree"
7−, dependencies = [ "prelude", "lists", "free" ]
5+, dependencies =
6+ [ "arrays"
7+ , "control"
8+ , "foldable-traversable"
9+ , "free"
10+ , "maybe"
11+ , "prelude"
12+ , "tailrec"
13+ ]
8, packages = ./packages.dhall
14, packages = ./packages.dhall
9}
15}
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.dhall+19−3
@@ -1,4 +1,20 @@
1let config = ./spago.dhall
1let config = ./spago.dhall
2+
3+in config
2−in config // { sources = config.sources # [ "test/**/*.purs" ]
4+ // { sources = config.sources # [ "test/**/*.purs" ]
3− , dependencies = [ "console", "spec" ]
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+ ]
4− }
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+185−259
@@ -3,10 +3,7 @@ module Test.Main where
3import Prelude
3import Prelude
4
4
5import Control.Comonad.Cofree (head, (:<))
5import Control.Comonad.Cofree (head, (:<))
6−import Data.List (List(Nil), (:))
7import Data.Maybe (Maybe(..), fromJust)
6import 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)
10import Effect (Effect)
7import Effect (Effect)
11import Effect.Aff (launchAff_)
8import Effect.Aff (launchAff_)
12import Partial.Unsafe (unsafePartial)
9import Partial.Unsafe (unsafePartial)
@@ -14,58 +11,63 @@ import Test.Spec (describe, it)
14import Test.Spec.Assertions (shouldEqual)
11import Test.Spec.Assertions (shouldEqual)
15import Test.Spec.Reporter (consoleReporter)
12import Test.Spec.Reporter (consoleReporter)
16import Test.Spec.Runner (runSpec)
13import 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)
17
23
18sampleTree :: Tree Int
24sampleTree :: Tree Int
19sampleTree =
25sampleTree =
20 1 :<
26 1 :<
21− (2 :< Nil)
27+ [ leaf 2
22− : (3 :< Nil)
28+ , leaf 3
23− : (4 :<
29+ , 4 :<
24− (5 :< Nil)
30+ [ leaf 5
25− : (6 :<
31+ , 6 :< [ leaf 7 ]
26− (7 :< Nil) : Nil)
32+ , leaf 8
27− : (8 :< Nil)
33+ ]
28− : Nil
34+
29− )
35+ ]
30− : Nil
31
36
32main :: Effect Unit
37main :: Effect Unit
33−main = launchAff_ $ runSpec [consoleReporter] do
38+main = launchAff_ $ runSpec [ consoleReporter ] do
34 describe "Tree" do
39 describe "Tree" do
35
40
36 it "mkTree" do
41 it "mkTree" do
37− let t = mkTree 10 Nil
42+ let t = 10 :< []
38 shouldEqual (head t) 10
43 shouldEqual (head t) 10
39
44
40 it "Functor" do
45 it "Functor" do
46+ let
41− let result =
47+ result = 2 :<
42− 2 :<
48+ [ leaf 3
43− (3 :< Nil)
49+ , leaf 4
44− : (4 :< Nil)
45− : (5 :<
50+ , 5 :<
46− (6 :< Nil)
51+ [ leaf 6
47− : (7 :<
52+ , 7 :< [ leaf 8 ]
48− (8 :< Nil) : Nil)
53+ , leaf 9
49− : (9 :< Nil)
54+ ]
50− : Nil
55+ ]
51− )
56+ SpecTree (((+) 1) <$> sampleTree) `shouldEqual` SpecTree result
52− : Nil
53− shouldEqual (eq (((+)1) <$> sampleTree) result) true
54
57
55 it "scanTree" do
58 it "scanTree" do
59+ let
56− let result =
60+ result =
57− 1 :<
61+ 1 :<
58− (3 :< Nil)
62+ [ leaf 3
59− : (4 :< Nil)
63+ , leaf 4
60− : (5 :<
64+ , 5 :<
61− (10 :< Nil)
65+ [ leaf 10
62− : (11 :<
66+ , 11 :< [ leaf 18 ]
63− (18 :< Nil) : Nil)
67+ , leaf 13
64− : (13 :< Nil)
68+ ]
65− : Nil
69+ ]
66− )
67− : Nil
68− shouldEqual (eq (scanTree (\a b -> a + b) 0 sampleTree) result) true
70+ SpecTree (scanTree (\a b -> a + b) 0 sampleTree) `shouldEqual` SpecTree result
69
71
70 describe "Zipper" do
72 describe "Zipper" do
71
73
@@ -75,221 +77,145 @@ main = launchAff_ $ runSpec [consoleReporter] do
75
77
76 let root' = unsafePartial $ toTree $ modifyValue (\a -> 2 * a) (fromJust $ down root)
78 let root' = unsafePartial $ toTree $ modifyValue (\a -> 2 * a) (fromJust $ down root)
77 let root'' = unsafePartial $ toTree $ modifyValue (\a -> 2 * a) (fromJust $ down >=> next >=> next >=> down $ root)
79 let root'' = unsafePartial $ toTree $ modifyValue (\a -> 2 * a) (fromJust $ down >=> next >=> next >=> down $ root)
80+
81+ let
78− let result =
82+ result =
79− 1 :<
83+ 1 :<
80− (4 :< Nil)
84+ [ leaf 4
81− : (3 :< Nil)
85+ , leaf 3
82− : (4 :<
86+ , 4 :<
83− (5 :< Nil)
87+ [ leaf 5
84− : (6 :<
88+ , 6 :< [ leaf 7 ]
85− (7 :< Nil) : Nil)
89+ , leaf 8
86− : (8 :< Nil)
90+ ]
87− : Nil
91+
88− )
92+ ]
89− : Nil
93+
90−
94+ let
91− let result' =
95+ result' =
92− 1 :<
96+ 1 :<
93− (2 :< Nil)
97+ [ 2 :< []
94− : (3 :< Nil)
98+ , 3 :< []
95− : (4 :<
99+ , 4 :<
96− (10 :< Nil)
100+ [ 10 :< []
97− : (6 :<
101+ , 6 :< [ 7 :< [] ]
98− (7 :< Nil) : Nil)
99− : (8 :< Nil)
102+ , 8 :< []
100− : Nil
103+ ]
101− )
104+ ]
102− : Nil
105+
103−
106+ SpecTree root' `shouldEqual` SpecTree result
104− shouldEqual (eq root' result) true
107+ SpecTree root'' `shouldEqual` SpecTree result'
105− shouldEqual (eq root'' result') true
108+
106−
107− it "Insert" do
109+ -- it "Insert" do
108−
110+
109− let root1 = unsafePartial $ toTree $ insertAfter (mkTree 100 Nil) (fromJust $ down root)
111+ -- let root1 = unsafePartial $ toTree $ insertAfter (mkLeaf 100) (fromJust $ down root)
110− let root2 = unsafePartial $ toTree $ insertAfter (mkTree 100 Nil) (fromJust $ (down root) >>= next >>= next >>= down >>= next >>= down)
112+ -- let root2 = unsafePartial $ toTree $ insertAfter (mkLeaf 100) (fromJust $ (down root) >>= next >>= next >>= down >>= next >>= down)
111− let root3 = unsafePartial $ toTree $ insertAfter (mkTree 100 Nil) (fromJust $ (firstChild root))
113+ -- let root3 = unsafePartial $ toTree $ insertAfter (mkLeaf 100) (fromJust $ (firstChild root))
112− let root4 = unsafePartial $ toTree $ insertAfter (mkTree 100 Nil) (fromJust $ (lastChild root))
114+ -- let root4 = unsafePartial $ toTree $ insertAfter (mkLeaf 100) (fromJust $ (lastChild root))
113−
115+
114− let result1 =
116+ -- let result1 = 1 :< []
115− 1 :<
116− (2 :< Nil)
117− : (100 :< Nil)
118− : (3 :< Nil)
119− : (4 :<
120− (5 :< Nil)
121− : (6 :<
122− (7 :< Nil) : Nil)
123− : (8 :< Nil)
124− : Nil
125− )
126− : Nil
127−
128− let result2 =
117+ -- let result2 = 1 :< []
129− 1 :<
130− (2 :< Nil)
131− : (3 :< Nil)
132− : (4 :<
133− (5 :< Nil)
134− : (6 :<
135− (7 :< Nil)
136− : (100 :< Nil)
137− : Nil)
138− : (8 :< Nil)
139− : Nil
140− )
141− : Nil
142− let result3 =
118+ -- let result3 = 1 :< []
143− 1 :<
144− (2 :< Nil)
145− : (100 :< Nil)
146− : (3 :< Nil)
147− : (4 :<
148− (5 :< Nil)
149− : (6 :<
150− (7 :< Nil)
151− : Nil
152− )
153− : (8 :< Nil)
154− : Nil
155− )
156− : Nil
157− let result4 =
119+ -- let result4 = 1 :< []
158− 1 :<
159− (2 :< Nil)
160− : (3 :< Nil)
161− : (4 :<
162− (5 :< Nil)
163− : (6 :<
164− (7 :< Nil) : Nil)
165− : (8 :< Nil)
166− : Nil
167− )
168− : (100 :< Nil)
169− : Nil
170− shouldEqual (eq root1 result1) true
120+ -- shouldEqual (eq root1 result1) true
171− shouldEqual (eq root2 result2) true
121+ -- shouldEqual (eq root2 result2) true
172− shouldEqual (eq root3 result3) true
122+ -- shouldEqual (eq root3 result3) true
173− shouldEqual (eq root4 result4) true
123+ -- shouldEqual (eq root4 result4) true
174−
124+
175− it "Should findDownWhere with single node" do
125+ it "Should findDownWhere with single node" do
176− let tree = 1 :< Nil
126+ let tree = 1 :< []
177− let loc = fromTree tree
127+ let loc = fromTree tree
178− shouldEqual (Just 1) ((findDownWhere (_ == 1) loc) <#> value)
128+ shouldEqual (Just 1) ((findDownWhere (_ == 1) loc) <#> value)
179−
129+
180− it "Should findDownWhere with 2 nodes and 2 levels" do
130+ it "Should findDownWhere with 2 nodes and 2 levels" do
181− let tree = 1 :<
131+ let tree = 1 :< [ leaf 2 ]
182− (2 :< Nil)
183− : Nil
184− -- log $ showTree tree
185− let loc = fromTree tree
132+ let loc = fromTree tree
186− shouldEqual (Just 2) ((findDownWhere (_ == 2) loc) <#> value)
133+ shouldEqual (Just 2) ((findDownWhere (_ == 2) loc) <#> value)
187−
134+
188− it "Should findDownWhere with 3 nodes and 2 levels" do
135+ it "Should findDownWhere with 3 nodes and 2 levels" do
189− let tree = 1 :<
136+ let tree = 1 :< [ leaf 2, leaf 3 ]
190− (2 :< Nil)
191− : (3 :< Nil)
192− : Nil
193− -- log $ showTree tree
194− let loc = fromTree tree
137+ let loc = fromTree tree
195− shouldEqual (Just 3) ((findDownWhere (_ == 3) loc) <#> value)
138+ shouldEqual (Just 3) ((findDownWhere (_ == 3) loc) <#> value)
196−
139+
197− it "Should findDownWhere with 4 nodes and 2 levels" do
140+ it "Should findDownWhere with 4 nodes and 2 levels" do
198− let tree = 1 :<
141+ let tree = 1 :< (leaf <$> [ 2, 3, 4 ])
199− (2 :< Nil)
200− : (3 :< Nil)
201− : (4 :< Nil)
202− : Nil
203− -- log $ showTree tree
204− let loc = fromTree tree
142+ let loc = fromTree tree
205− shouldEqual (Just 4) ((findDownWhere (_ == 4) loc) <#> value)
143+ shouldEqual (Just 4) ((findDownWhere (_ == 4) loc) <#> value)
206−
144+
207− it "Should findDownWhere with 5 nodes and 3 levels" do
145+ it "Should findDownWhere with 5 nodes and 3 levels" do
146+ let
208− let tree = 1 :<
147+ tree = 1 :<
209− (2 :< Nil)
148+ [ leaf 2
210− : (3 :< Nil)
149+ , leaf 3
211− : (4 :<
150+ , 4 :< [ leaf 5 ]
212− (5 :< Nil)
151+ ]
213− : Nil)
214− : Nil
215− -- log $ showTree tree
152+ -- log $ showTree tree
216− let loc = fromTree tree
153+ let loc = fromTree tree
217− shouldEqual (Just 5) ((findDownWhere (_ == 5) loc) <#> value)
154+ shouldEqual (Just 5) ((findDownWhere (_ == 5) loc) <#> value)
218−
155+
219− it "Should findDownWhere with 6 nodes and 3 levels" do
156+ it "Should findDownWhere with 6 nodes and 3 levels" do
157+ let
220− let tree = 1 :<
158+ tree = 1 :<
221− (2 :< Nil)
159+ [ leaf 2
222− : (3 :< Nil)
160+ , leaf 3
223− : (4 :<
161+ , 4 :< [ leaf 5, leaf 6 ]
224− (5 :< Nil)
162+ ]
225− : (6 :< Nil)
226− : Nil)
227− : Nil
228− -- log $ showTree tree
163+ -- log $ showTree tree
229− let loc = fromTree tree
164+ let loc = fromTree tree
230− shouldEqual (Just 6) ((findDownWhere (_ == 6) loc) <#> value)
165+ shouldEqual (Just 6) ((findDownWhere (_ == 6) loc) <#> value)
231−
166+
232− it "Should findDownWhere with 7 nodes and 4 levels" do
167+ it "Should findDownWhere with 7 nodes and 4 levels" do
168+ let
233− let tree = 1 :<
169+ tree = 1 :<
234− (2 :< Nil)
170+ [ leaf 2
235− : (3 :< Nil)
171+ , leaf 3
236− : (4 :<
172+ , 4 :< [ leaf 5, 6 :< [ leaf 7 ] ]
237− (5 :< Nil)
173+ ]
238− : (6 :<
239− (7 :< Nil) : Nil)
240− : Nil)
241− : Nil
242− -- log $ showTree tree
174+ -- log $ showTree tree
243− let loc = fromTree tree
175+ let loc = fromTree tree
244− shouldEqual (Just 7) ((findDownWhere (_ == 7) loc) <#> value)
176+ shouldEqual (Just 7) ((findDownWhere (_ == 7) loc) <#> value)
245−
177+
246− it "Should findDownWhere with 8 nodes and 4 levels" do
178+ it "Should findDownWhere with 8 nodes and 4 levels" do
179+ let
247− let tree = 1 :<
180+ tree = 1 :<
248− (2 :< Nil)
181+ [ leaf 2
249− : (3 :< Nil)
182+ , leaf 3
250− : (4 :<
183+ , 4 :< [ leaf 5, 6 :< [ leaf 7 ] ]
251− (5 :< Nil)
184+ , leaf 8
252− : (6 :<
185+ ]
253− (7 :< Nil) : Nil)
254− : (8 :< Nil)
255− : Nil)
256− : Nil
257− -- log $ showTree tree
186+ -- log $ showTree tree
258− let loc = fromTree tree
187+ let loc = fromTree tree
259− shouldEqual (Just 8) ((findDownWhere (_ == 8) loc) <#> value)
188+ shouldEqual (Just 8) ((findDownWhere (_ == 8) loc) <#> value)
260−
189+
261− it "Should findDownWhere with 8 nodes and 4 levels with a step back" do
190+ it "Should findDownWhere with 8 nodes and 4 levels with a step back" do
191+ let
262− let tree = 1 :<
192+ tree = 1 :<
263− (2 :< Nil)
193+ [ leaf 2
264− : (3 :< Nil)
194+ , leaf 3
265− : (4 :<
195+ , 4 :< [ leaf 5, 6 :< [ leaf 7 ] ]
266− (5 :< Nil)
196+ , leaf 8
267− : (6 :<
197+ ]
268− (7 :< Nil) : Nil)
269− : (8 :< Nil)
270− : Nil)
271− : Nil
272− -- log $ showTree tree
198+ -- log $ showTree tree
273− let loc = fromTree tree
199+ let loc = fromTree tree
274− shouldEqual (Just 7) ((findDownWhere (_ == 7) loc) <#> value)
200+ shouldEqual (Just 7) ((findDownWhere (_ == 7) loc) <#> value)
275−
201+
276− it "Should find 7 from the sampleTree" do
202+ it "Should find 7 from the sampleTree" do
277− shouldEqual (Just 7) (findDownWhere (_ == 7) (fromTree sampleTree) <#> value)
203+ shouldEqual (Just 7) (findDownWhere (_ == 7) (fromTree sampleTree) <#> value)
278−
204+
279− it "Should find 8 from the sampleTree (the bottom) and then find 1 (the top) with findUp" do
205+ it "Should find 8 from the sampleTree (the bottom) and then find 1 (the top) with findUp" do
280− let eight = unsafePartial $ fromJust $ findDownWhere (_ == 8) $ fromTree sampleTree
206+ let eight = unsafePartial $ fromJust $ findDownWhere (_ == 8) $ fromTree sampleTree
281− shouldEqual (Just 1) (findUp 1 eight <#> value)
207+ shouldEqual (Just 1) (findUp 1 eight <#> value)
282−
208+
283− it "Should find 8 from the sampleTree (the bottom) but then not find 7 because it would require a downward traversal" do
209+ it "Should find 8 from the sampleTree (the bottom) but then not find 7 because it would require a downward traversal" do
284− let eight = unsafePartial $ fromJust $ findDownWhere (_ == 8) $ fromTree sampleTree
210+ let eight = unsafePartial $ fromJust $ findDownWhere (_ == 8) $ fromTree sampleTree
285− shouldEqual Nothing (findUp 7 eight <#> value)
211+ shouldEqual Nothing (findUp 7 eight <#> value)
286−
212+
287− it "Should find 8 from the sampleTree (the bottom) and then find 7 using findFromRoot" do
213+ it "Should find 8 from the sampleTree (the bottom) and then find 7 using findFromRoot" do
288− let eight = unsafePartial $ fromJust $ findDownWhere (_ == 8) $ fromTree sampleTree
214+ let eight = unsafePartial $ fromJust $ findDownWhere (_ == 8) $ fromTree sampleTree
289− shouldEqual (Just 7) (findFromRoot 7 eight <#> value)
215+ shouldEqual (Just 7) (findFromRoot 7 eight <#> value)
290−
216+
291− it "Should flatten the Tree into a list of locations following a depth first pattern" do
217+ it "Should flatten the Tree into a list of locations following a depth first pattern" do
292− let flat = map value $ flattenLocDepthFirst $ fromTree sampleTree
218+ let flat = map value $ flattenLocDepthFirst $ fromTree sampleTree
293− --log $ showTree sampleTree
219+ --log $ showTree sampleTree
294− --log $ show flat
220+ --log $ show flat
295− shouldEqual flat (1 : 2 : 3 : 4 : 5 : 6 : 7 : 8 : Nil)
221+ shouldEqual flat [1,2,3,4,5,6,7,8]