From 9906f649d26adfed5126065082fb4a7d5e4696bb Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 1 May 2018 22:13:07 -0400 Subject: - Re-organized "lux/data/coll/tree/*" modules. --- stdlib/source/lux/data/coll/tree/parser.lux | 50 ----- stdlib/source/lux/data/coll/tree/rose/parser.lux | 50 +++++ stdlib/source/lux/data/coll/tree/rose/zipper.lux | 235 +++++++++++++++++++++ stdlib/source/lux/data/coll/tree/zipper.lux | 235 --------------------- .../test/test/lux/data/coll/tree/rose/zipper.lux | 124 +++++++++++ stdlib/test/test/lux/data/coll/tree/zipper.lux | 124 ----------- stdlib/test/tests.lux | 6 +- 7 files changed, 412 insertions(+), 412 deletions(-) delete mode 100644 stdlib/source/lux/data/coll/tree/parser.lux create mode 100644 stdlib/source/lux/data/coll/tree/rose/parser.lux create mode 100644 stdlib/source/lux/data/coll/tree/rose/zipper.lux delete mode 100644 stdlib/source/lux/data/coll/tree/zipper.lux create mode 100644 stdlib/test/test/lux/data/coll/tree/rose/zipper.lux delete mode 100644 stdlib/test/test/lux/data/coll/tree/zipper.lux (limited to 'stdlib') diff --git a/stdlib/source/lux/data/coll/tree/parser.lux b/stdlib/source/lux/data/coll/tree/parser.lux deleted file mode 100644 index e5881d097..000000000 --- a/stdlib/source/lux/data/coll/tree/parser.lux +++ /dev/null @@ -1,50 +0,0 @@ -(.module: - lux - (lux (control ["p" parser] - ["ex" exception #+ exception:]) - (data ["E" error])) - (// ["T" rose] - ["Z" zipper])) - -(type: #export (Parser t a) - (p.Parser (Z.Zipper t) a)) - -(def: #export (run-zipper zipper parser) - (All [t a] (-> (Z.Zipper t) (Parser t a) (E.Error a))) - (case (p.run zipper parser) - (#E.Success [zipper output]) - (#E.Success output) - - (#E.Error error) - (#E.Error error))) - -(def: #export (run tree parser) - (All [t a] (-> (T.Tree t) (Parser t a) (E.Error a))) - (run-zipper (Z.zip tree) parser)) - -(def: #export value - (All [t] (Parser t t)) - (function (_ zipper) - (#E.Success [zipper (Z.value zipper)]))) - -(exception: #export Cannot-Move-Further) - -(do-template [ ] - [(def: #export - (All [t] (Parser t [])) - (function (_ zipper) - (let [next ( zipper)] - (if (is? zipper next) - (ex.throw Cannot-Move-Further []) - (#E.Success [next []])))))] - - [up Z.up] - [down Z.down] - [left Z.left] - [right Z.right] - [root Z.root] - [rightmost Z.rightmost] - [leftmost Z.leftmost] - [next Z.next] - [prev Z.prev] - ) diff --git a/stdlib/source/lux/data/coll/tree/rose/parser.lux b/stdlib/source/lux/data/coll/tree/rose/parser.lux new file mode 100644 index 000000000..bee1e07f9 --- /dev/null +++ b/stdlib/source/lux/data/coll/tree/rose/parser.lux @@ -0,0 +1,50 @@ +(.module: + lux + (lux (control ["p" parser] + ["ex" exception #+ exception:]) + (data ["E" error])) + [// #+ Tree] + (// [zipper #+ Zipper])) + +(type: #export (Parser t a) + (p.Parser (Zipper t) a)) + +(def: #export (run-zipper zipper parser) + (All [t a] (-> (Zipper t) (Parser t a) (E.Error a))) + (case (p.run zipper parser) + (#E.Success [zipper output]) + (#E.Success output) + + (#E.Error error) + (#E.Error error))) + +(def: #export (run tree parser) + (All [t a] (-> (Tree t) (Parser t a) (E.Error a))) + (run-zipper (zipper.zip tree) parser)) + +(def: #export value + (All [t] (Parser t t)) + (function (_ zipper) + (#E.Success [zipper (zipper.value zipper)]))) + +(exception: #export Cannot-Move-Further) + +(do-template [ ] + [(def: #export + (All [t] (Parser t [])) + (function (_ zipper) + (let [next ( zipper)] + (if (is? zipper next) + (ex.throw Cannot-Move-Further []) + (#E.Success [next []])))))] + + [up zipper.up] + [down zipper.down] + [left zipper.left] + [right zipper.right] + [root zipper.root] + [rightmost zipper.rightmost] + [leftmost zipper.leftmost] + [next zipper.next] + [prev zipper.prev] + ) diff --git a/stdlib/source/lux/data/coll/tree/rose/zipper.lux b/stdlib/source/lux/data/coll/tree/rose/zipper.lux new file mode 100644 index 000000000..845dd4c4c --- /dev/null +++ b/stdlib/source/lux/data/coll/tree/rose/zipper.lux @@ -0,0 +1,235 @@ +(.module: + lux + (lux (control functor + comonad) + (data (coll [list "L/" Monad Fold Monoid] + (tree [rose #+ Tree "T/" Functor]) + [stack #+ Stack]) + [maybe "M/" Monad]) + [macro] + (macro [code] + ["s" syntax #+ syntax: Syntax]))) + +## Adapted from the clojure.zip namespace in the Clojure standard library. + +## [Types] +(type: #export (Zipper a) + {#.doc "Tree zippers, for easy navigation and editing over trees."} + {#parent (Maybe (Zipper a)) + #lefts (Stack (Tree a)) + #rights (Stack (Tree a)) + #node (Tree a)}) + +## [Values] +(def: #export (zip tree) + (All [a] (-> (Tree a) (Zipper a))) + {#parent #.None + #lefts stack.empty + #rights stack.empty + #node tree}) + +(def: #export (unzip zipper) + (All [a] (-> (Zipper a) (Tree a))) + (get@ #node zipper)) + +(def: #export (value zipper) + (All [a] (-> (Zipper a) a)) + (|> zipper (get@ [#node #rose.value]))) + +(def: #export (children zipper) + (All [a] (-> (Zipper a) (List (Tree a)))) + (|> zipper (get@ [#node #rose.children]))) + +(def: #export (branch? zipper) + (All [a] (-> (Zipper a) Bool)) + (|> zipper children list.empty? not)) + +(def: #export (leaf? zipper) + (All [a] (-> (Zipper a) Bool)) + (|> zipper branch? not)) + +(def: #export (end? zipper) + (All [a] (-> (Zipper a) Bool)) + (and (list.empty? (get@ #rights zipper)) + (list.empty? (children zipper)))) + +(def: #export (root? zipper) + (All [a] (-> (Zipper a) Bool)) + (case (get@ #parent zipper) + #.None + true + + _ + false)) + +(def: #export (down zipper) + (All [a] (-> (Zipper a) (Zipper a))) + (case (children zipper) + #.Nil + zipper + + (#.Cons chead ctail) + {#parent (#.Some zipper) + #lefts stack.empty + #rights ctail + #node chead})) + +(def: #export (up zipper) + (All [a] (-> (Zipper a) (Zipper a))) + (case (get@ #parent zipper) + #.None + zipper + + (#.Some parent) + (|> parent + ## TODO: Remove once new-luxc becomes the standard compiler. + (update@ #node (: (-> (Tree ($ +0)) (Tree ($ +0))) + (function (_ node) + (set@ #rose.children (L/compose (list.reverse (get@ #lefts zipper)) + (#.Cons (get@ #node zipper) + (get@ #rights zipper))) + node)))) + ## (update@ #node (function (_ node) + ## (set@ #rose.children (L/compose (list.reverse (get@ #lefts zipper)) + ## (#.Cons (get@ #node zipper) + ## (get@ #rights zipper))) + ## node))) + ))) + +(def: #export (root zipper) + (All [a] (-> (Zipper a) (Zipper a))) + (loop [zipper zipper] + (case (get@ #parent zipper) + #.None zipper + (#.Some _) (recur (up zipper))))) + +(do-template [ ] + [(def: #export ( zipper) + (All [a] (-> (Zipper a) (Zipper a))) + (case (get@ zipper) + #.Nil + zipper + + (#.Cons next side') + (|> zipper + (update@ (function (_ op-side) + (#.Cons (get@ #node zipper) op-side))) + (set@ side') + (set@ #node next)))) + + (def: #export ( zipper) + (All [a] (-> (Zipper a) (Zipper a))) + (L/fold (function (_ _) ) zipper (get@ zipper)))] + + [right rightmost #rights #lefts] + [left leftmost #lefts #rights] + ) + +(do-template [ ] + [(def: #export ( zipper) + (All [a] (-> (Zipper a) (Zipper a))) + (case (get@ zipper) + #.Nil + ( zipper) + + _ + ( zipper)))] + + [next #rights right down] + [prev #lefts left up] + ) + +(def: #export (set value zipper) + (All [a] (-> a (Zipper a) (Zipper a))) + (set@ [#node #rose.value] value zipper)) + +(def: #export (update f zipper) + (All [a] (-> (-> a a) (Zipper a) (Zipper a))) + (update@ [#node #rose.value] f zipper)) + +(def: #export (prepend-child value zipper) + (All [a] (-> a (Zipper a) (Zipper a))) + (update@ [#node #rose.children] + (function (_ children) + ## TODO: Remove once new-luxc becomes the standard compiler. + (list& (: (Tree ($ +0)) + (rose.tree [value {}])) + children) + ## (list& (rose.tree [value {}]) + ## children) + ) + zipper)) + +(def: #export (append-child value zipper) + (All [a] (-> a (Zipper a) (Zipper a))) + (update@ [#node #rose.children] + (function (_ children) + (L/compose children + ## TODO: Remove once new-luxc becomes the standard compiler. + (list (: (Tree ($ +0)) + (rose.tree [value {}]))) + ## (list (rose.tree [value {}])) + )) + zipper)) + +(def: #export (remove zipper) + (All [a] (-> (Zipper a) (Maybe (Zipper a)))) + (case (get@ #lefts zipper) + #.Nil + (case (get@ #parent zipper) + #.None + #.None + + (#.Some next) + (#.Some (|> next + (update@ [#node #rose.children] (|>> list.tail (maybe.default (list))))))) + + (#.Cons next side) + (#.Some (|> zipper + (set@ #lefts side) + (set@ #node next))))) + +(do-template [ ] + [(def: #export ( value zipper) + (All [a] (-> a (Zipper a) (Maybe (Zipper a)))) + (case (get@ #parent zipper) + #.None + #.None + + _ + (#.Some (|> zipper + (update@ (function (_ side) + ## TODO: Remove once new-luxc becomes the standard compiler. + (#.Cons (: (Tree ($ +0)) + (rose.tree [value {}])) + side) + ## (#.Cons (rose.tree [value {}]) + ## side) + ))))))] + + [insert-left #lefts] + [insert-right #rights] + ) + +(struct: #export _ (Functor Zipper) + (def: (map f fa) + {#parent (|> fa (get@ #parent) (M/map (map f))) + #lefts (|> fa (get@ #lefts) (L/map (T/map f))) + #rights (|> fa (get@ #rights) (L/map (T/map f))) + #node (T/map f (get@ #node fa))})) + +## TODO: Add again once new-luxc becomes the standard compiler. +## (struct: #export _ (CoMonad Zipper) +## (def: functor Functor) + +## (def: unwrap (get@ [#node #rose.value])) + +## (def: (split wa) +## (let [tree-splitter (function (tree-splitter tree) +## {#rose.value (zip tree) +## #rose.children (L/map tree-splitter +## (get@ #rose.children tree))})] +## {#parent (|> wa (get@ #parent) (M/map split)) +## #lefts (|> wa (get@ #lefts) (L/map tree-splitter)) +## #rights (|> wa (get@ #rights) (L/map tree-splitter)) +## #node (|> fa (get@ #node) tree-splitter)}))) diff --git a/stdlib/source/lux/data/coll/tree/zipper.lux b/stdlib/source/lux/data/coll/tree/zipper.lux deleted file mode 100644 index 845dd4c4c..000000000 --- a/stdlib/source/lux/data/coll/tree/zipper.lux +++ /dev/null @@ -1,235 +0,0 @@ -(.module: - lux - (lux (control functor - comonad) - (data (coll [list "L/" Monad Fold Monoid] - (tree [rose #+ Tree "T/" Functor]) - [stack #+ Stack]) - [maybe "M/" Monad]) - [macro] - (macro [code] - ["s" syntax #+ syntax: Syntax]))) - -## Adapted from the clojure.zip namespace in the Clojure standard library. - -## [Types] -(type: #export (Zipper a) - {#.doc "Tree zippers, for easy navigation and editing over trees."} - {#parent (Maybe (Zipper a)) - #lefts (Stack (Tree a)) - #rights (Stack (Tree a)) - #node (Tree a)}) - -## [Values] -(def: #export (zip tree) - (All [a] (-> (Tree a) (Zipper a))) - {#parent #.None - #lefts stack.empty - #rights stack.empty - #node tree}) - -(def: #export (unzip zipper) - (All [a] (-> (Zipper a) (Tree a))) - (get@ #node zipper)) - -(def: #export (value zipper) - (All [a] (-> (Zipper a) a)) - (|> zipper (get@ [#node #rose.value]))) - -(def: #export (children zipper) - (All [a] (-> (Zipper a) (List (Tree a)))) - (|> zipper (get@ [#node #rose.children]))) - -(def: #export (branch? zipper) - (All [a] (-> (Zipper a) Bool)) - (|> zipper children list.empty? not)) - -(def: #export (leaf? zipper) - (All [a] (-> (Zipper a) Bool)) - (|> zipper branch? not)) - -(def: #export (end? zipper) - (All [a] (-> (Zipper a) Bool)) - (and (list.empty? (get@ #rights zipper)) - (list.empty? (children zipper)))) - -(def: #export (root? zipper) - (All [a] (-> (Zipper a) Bool)) - (case (get@ #parent zipper) - #.None - true - - _ - false)) - -(def: #export (down zipper) - (All [a] (-> (Zipper a) (Zipper a))) - (case (children zipper) - #.Nil - zipper - - (#.Cons chead ctail) - {#parent (#.Some zipper) - #lefts stack.empty - #rights ctail - #node chead})) - -(def: #export (up zipper) - (All [a] (-> (Zipper a) (Zipper a))) - (case (get@ #parent zipper) - #.None - zipper - - (#.Some parent) - (|> parent - ## TODO: Remove once new-luxc becomes the standard compiler. - (update@ #node (: (-> (Tree ($ +0)) (Tree ($ +0))) - (function (_ node) - (set@ #rose.children (L/compose (list.reverse (get@ #lefts zipper)) - (#.Cons (get@ #node zipper) - (get@ #rights zipper))) - node)))) - ## (update@ #node (function (_ node) - ## (set@ #rose.children (L/compose (list.reverse (get@ #lefts zipper)) - ## (#.Cons (get@ #node zipper) - ## (get@ #rights zipper))) - ## node))) - ))) - -(def: #export (root zipper) - (All [a] (-> (Zipper a) (Zipper a))) - (loop [zipper zipper] - (case (get@ #parent zipper) - #.None zipper - (#.Some _) (recur (up zipper))))) - -(do-template [ ] - [(def: #export ( zipper) - (All [a] (-> (Zipper a) (Zipper a))) - (case (get@ zipper) - #.Nil - zipper - - (#.Cons next side') - (|> zipper - (update@ (function (_ op-side) - (#.Cons (get@ #node zipper) op-side))) - (set@ side') - (set@ #node next)))) - - (def: #export ( zipper) - (All [a] (-> (Zipper a) (Zipper a))) - (L/fold (function (_ _) ) zipper (get@ zipper)))] - - [right rightmost #rights #lefts] - [left leftmost #lefts #rights] - ) - -(do-template [ ] - [(def: #export ( zipper) - (All [a] (-> (Zipper a) (Zipper a))) - (case (get@ zipper) - #.Nil - ( zipper) - - _ - ( zipper)))] - - [next #rights right down] - [prev #lefts left up] - ) - -(def: #export (set value zipper) - (All [a] (-> a (Zipper a) (Zipper a))) - (set@ [#node #rose.value] value zipper)) - -(def: #export (update f zipper) - (All [a] (-> (-> a a) (Zipper a) (Zipper a))) - (update@ [#node #rose.value] f zipper)) - -(def: #export (prepend-child value zipper) - (All [a] (-> a (Zipper a) (Zipper a))) - (update@ [#node #rose.children] - (function (_ children) - ## TODO: Remove once new-luxc becomes the standard compiler. - (list& (: (Tree ($ +0)) - (rose.tree [value {}])) - children) - ## (list& (rose.tree [value {}]) - ## children) - ) - zipper)) - -(def: #export (append-child value zipper) - (All [a] (-> a (Zipper a) (Zipper a))) - (update@ [#node #rose.children] - (function (_ children) - (L/compose children - ## TODO: Remove once new-luxc becomes the standard compiler. - (list (: (Tree ($ +0)) - (rose.tree [value {}]))) - ## (list (rose.tree [value {}])) - )) - zipper)) - -(def: #export (remove zipper) - (All [a] (-> (Zipper a) (Maybe (Zipper a)))) - (case (get@ #lefts zipper) - #.Nil - (case (get@ #parent zipper) - #.None - #.None - - (#.Some next) - (#.Some (|> next - (update@ [#node #rose.children] (|>> list.tail (maybe.default (list))))))) - - (#.Cons next side) - (#.Some (|> zipper - (set@ #lefts side) - (set@ #node next))))) - -(do-template [ ] - [(def: #export ( value zipper) - (All [a] (-> a (Zipper a) (Maybe (Zipper a)))) - (case (get@ #parent zipper) - #.None - #.None - - _ - (#.Some (|> zipper - (update@ (function (_ side) - ## TODO: Remove once new-luxc becomes the standard compiler. - (#.Cons (: (Tree ($ +0)) - (rose.tree [value {}])) - side) - ## (#.Cons (rose.tree [value {}]) - ## side) - ))))))] - - [insert-left #lefts] - [insert-right #rights] - ) - -(struct: #export _ (Functor Zipper) - (def: (map f fa) - {#parent (|> fa (get@ #parent) (M/map (map f))) - #lefts (|> fa (get@ #lefts) (L/map (T/map f))) - #rights (|> fa (get@ #rights) (L/map (T/map f))) - #node (T/map f (get@ #node fa))})) - -## TODO: Add again once new-luxc becomes the standard compiler. -## (struct: #export _ (CoMonad Zipper) -## (def: functor Functor) - -## (def: unwrap (get@ [#node #rose.value])) - -## (def: (split wa) -## (let [tree-splitter (function (tree-splitter tree) -## {#rose.value (zip tree) -## #rose.children (L/map tree-splitter -## (get@ #rose.children tree))})] -## {#parent (|> wa (get@ #parent) (M/map split)) -## #lefts (|> wa (get@ #lefts) (L/map tree-splitter)) -## #rights (|> wa (get@ #rights) (L/map tree-splitter)) -## #node (|> fa (get@ #node) tree-splitter)}))) diff --git a/stdlib/test/test/lux/data/coll/tree/rose/zipper.lux b/stdlib/test/test/lux/data/coll/tree/rose/zipper.lux new file mode 100644 index 000000000..ff52e706d --- /dev/null +++ b/stdlib/test/test/lux/data/coll/tree/rose/zipper.lux @@ -0,0 +1,124 @@ +(.module: + lux + (lux [io] + (control [monad #+ do Monad] + pipe) + (data (coll [list "list/" Fold Functor] + (tree [rose] + (rose ["&" zipper]))) + [text] + text/format + [number] + [maybe]) + ["r" math/random]) + lux/test) + +(def: gen-tree + (r.Random (rose.Tree Nat)) + (r.rec (function (_ gen-tree) + (do r.Monad + ## Each branch can have, at most, 1 child. + [size (|> r.nat (:: @ map (n/% +2)))] + (r.seq r.nat + (r.list size gen-tree)))))) + +(def: (to-end zipper) + (All [a] (-> (&.Zipper a) (&.Zipper a))) + (loop [zipper zipper] + (if (&.end? zipper) + zipper + (recur (&.next zipper))))) + +(context: "Zippers." + (<| (times +100) + (do @ + [sample gen-tree + new-val r.nat + pre-val r.nat + post-val r.nat + #let [(^open "tree/") (rose.Eq number.Eq) + (^open "list/") (list.Eq number.Eq)]] + ($_ seq + (test "Trees can be converted to/from zippers." + (|> sample + &.zip &.unzip + (tree/= sample))) + + (test "Creating a zipper gives you a root node." + (|> sample &.zip &.root?)) + + (test "Can move down inside branches. Can move up from lower nodes." + (let [zipper (&.zip sample)] + (if (&.branch? zipper) + (let [child (|> zipper &.down)] + (and (not (tree/= sample (&.unzip child))) + (|> child &.up (is? zipper) not) + (|> child &.root (is? zipper) not))) + (and (&.leaf? zipper) + (|> zipper (&.prepend-child new-val) &.branch?))))) + + (test "Can prepend and append children." + (let [zipper (&.zip sample)] + (if (&.branch? zipper) + (let [mid-val (|> zipper &.down &.value) + zipper (|> zipper + (&.prepend-child pre-val) + (&.append-child post-val))] + (and (|> zipper &.down &.value (is? pre-val)) + (|> zipper &.down &.right &.value (is? mid-val)) + (|> zipper &.down &.right &.right &.value (is? post-val)) + (|> zipper &.down &.rightmost &.leftmost &.value (is? pre-val)) + (|> zipper &.down &.right &.left &.value (is? pre-val)) + (|> zipper &.down &.rightmost &.value (is? post-val)))) + true))) + + (test "Can insert children around a node (unless it's root)." + (let [zipper (&.zip sample)] + (if (&.branch? zipper) + (let [mid-val (|> zipper &.down &.value) + zipper (|> zipper + &.down + (&.insert-left pre-val) + maybe.assume + (&.insert-right post-val) + maybe.assume + &.up)] + (and (|> zipper &.down &.value (is? pre-val)) + (|> zipper &.down &.right &.value (is? mid-val)) + (|> zipper &.down &.right &.right &.value (is? post-val)) + (|> zipper &.down &.rightmost &.leftmost &.value (is? pre-val)) + (|> zipper &.down &.right &.left &.value (is? pre-val)) + (|> zipper &.down &.rightmost &.value (is? post-val)))) + (and (|> zipper (&.insert-left pre-val) (case> (#.Some _) false + #.None true)) + (|> zipper (&.insert-right post-val) (case> (#.Some _) false + #.None true)))))) + + (test "Can set and update the value of a node." + (|> sample &.zip (&.set new-val) &.value (n/= new-val))) + + (test "Zipper traversal follows the outline of the tree depth-first." + (list/= (rose.flatten sample) + (loop [zipper (&.zip sample)] + (if (&.end? zipper) + (list (&.value zipper)) + (#.Cons (&.value zipper) + (recur (&.next zipper))))))) + + (test "Backwards zipper traversal yield reverse tree flatten." + (list/= (list.reverse (rose.flatten sample)) + (loop [zipper (to-end (&.zip sample))] + (if (&.root? zipper) + (list (&.value zipper)) + (#.Cons (&.value zipper) + (recur (&.prev zipper))))))) + + (test "Can remove nodes (except root nodes)." + (let [zipper (&.zip sample)] + (if (&.branch? zipper) + (and (|> zipper &.down &.root? not) + (|> zipper &.down &.remove (case> #.None false + (#.Some node) (&.root? node)))) + (|> zipper &.remove (case> #.None true + (#.Some _) false))))) + )))) diff --git a/stdlib/test/test/lux/data/coll/tree/zipper.lux b/stdlib/test/test/lux/data/coll/tree/zipper.lux deleted file mode 100644 index 7b182a918..000000000 --- a/stdlib/test/test/lux/data/coll/tree/zipper.lux +++ /dev/null @@ -1,124 +0,0 @@ -(.module: - lux - (lux [io] - (control [monad #+ do Monad] - pipe) - (data (coll [list "L/" Fold Functor] - (tree ["&" zipper] - [rose])) - [text] - text/format - [number] - [maybe]) - ["r" math/random]) - lux/test) - -(def: gen-tree - (r.Random (rose.Tree Nat)) - (r.rec (function (_ gen-tree) - (do r.Monad - ## Each branch can have, at most, 1 child. - [size (|> r.nat (:: @ map (n/% +2)))] - (r.seq r.nat - (r.list size gen-tree)))))) - -(def: (to-end zipper) - (All [a] (-> (&.Zipper a) (&.Zipper a))) - (loop [zipper zipper] - (if (&.end? zipper) - zipper - (recur (&.next zipper))))) - -(context: "Zippers." - (<| (times +100) - (do @ - [sample gen-tree - new-val r.nat - pre-val r.nat - post-val r.nat - #let [(^open "tree/") (rose.Eq number.Eq) - (^open "L/") (list.Eq number.Eq)]] - ($_ seq - (test "Trees can be converted to/from zippers." - (|> sample - &.zip &.unzip - (tree/= sample))) - - (test "Creating a zipper gives you a root node." - (|> sample &.zip &.root?)) - - (test "Can move down inside branches. Can move up from lower nodes." - (let [zipper (&.zip sample)] - (if (&.branch? zipper) - (let [child (|> zipper &.down)] - (and (not (tree/= sample (&.unzip child))) - (|> child &.up (is? zipper) not) - (|> child &.root (is? zipper) not))) - (and (&.leaf? zipper) - (|> zipper (&.prepend-child new-val) &.branch?))))) - - (test "Can prepend and append children." - (let [zipper (&.zip sample)] - (if (&.branch? zipper) - (let [mid-val (|> zipper &.down &.value) - zipper (|> zipper - (&.prepend-child pre-val) - (&.append-child post-val))] - (and (|> zipper &.down &.value (is? pre-val)) - (|> zipper &.down &.right &.value (is? mid-val)) - (|> zipper &.down &.right &.right &.value (is? post-val)) - (|> zipper &.down &.rightmost &.leftmost &.value (is? pre-val)) - (|> zipper &.down &.right &.left &.value (is? pre-val)) - (|> zipper &.down &.rightmost &.value (is? post-val)))) - true))) - - (test "Can insert children around a node (unless it's root)." - (let [zipper (&.zip sample)] - (if (&.branch? zipper) - (let [mid-val (|> zipper &.down &.value) - zipper (|> zipper - &.down - (&.insert-left pre-val) - maybe.assume - (&.insert-right post-val) - maybe.assume - &.up)] - (and (|> zipper &.down &.value (is? pre-val)) - (|> zipper &.down &.right &.value (is? mid-val)) - (|> zipper &.down &.right &.right &.value (is? post-val)) - (|> zipper &.down &.rightmost &.leftmost &.value (is? pre-val)) - (|> zipper &.down &.right &.left &.value (is? pre-val)) - (|> zipper &.down &.rightmost &.value (is? post-val)))) - (and (|> zipper (&.insert-left pre-val) (case> (#.Some _) false - #.None true)) - (|> zipper (&.insert-right post-val) (case> (#.Some _) false - #.None true)))))) - - (test "Can set and update the value of a node." - (|> sample &.zip (&.set new-val) &.value (n/= new-val))) - - (test "Zipper traversal follows the outline of the tree depth-first." - (L/= (rose.flatten sample) - (loop [zipper (&.zip sample)] - (if (&.end? zipper) - (list (&.value zipper)) - (#.Cons (&.value zipper) - (recur (&.next zipper))))))) - - (test "Backwards zipper traversal yield reverse tree flatten." - (L/= (list.reverse (rose.flatten sample)) - (loop [zipper (to-end (&.zip sample))] - (if (&.root? zipper) - (list (&.value zipper)) - (#.Cons (&.value zipper) - (recur (&.prev zipper))))))) - - (test "Can remove nodes (except root nodes)." - (let [zipper (&.zip sample)] - (if (&.branch? zipper) - (and (|> zipper &.down &.root? not) - (|> zipper &.down &.remove (case> #.None false - (#.Some node) (&.root? node)))) - (|> zipper &.remove (case> #.None true - (#.Some _) false))))) - )))) diff --git a/stdlib/test/tests.lux b/stdlib/test/tests.lux index a25d419bc..71317af18 100644 --- a/stdlib/test/tests.lux +++ b/stdlib/test/tests.lux @@ -53,8 +53,8 @@ ["_." set/ordered] ["_." queue] (queue ["_." priority]) - (tree ["tree_." rose] - ["tree_." zipper])) + (tree ["_." rose] + (rose ["_." zipper]))) (text ["_." format] ["_." lexer] ["_." regex])) @@ -90,7 +90,7 @@ (format [context] [html] [css]) - (coll (tree ["tree_." parser]))) + (coll (tree ["_." rose/parser]))) [macro] (macro (poly [json])) (type [unit] -- cgit v1.2.3