diff options
Diffstat (limited to 'stdlib/source/test/lux/data/collection/tree/zipper.lux')
| -rw-r--r-- | stdlib/source/test/lux/data/collection/tree/zipper.lux | 115 |
1 files changed, 115 insertions, 0 deletions
diff --git a/stdlib/source/test/lux/data/collection/tree/zipper.lux b/stdlib/source/test/lux/data/collection/tree/zipper.lux new file mode 100644 index 000000000..f4b812420 --- /dev/null +++ b/stdlib/source/test/lux/data/collection/tree/zipper.lux @@ -0,0 +1,115 @@ +(.module: + [lux #* + data/text/format + ["_" test (#+ Test)] + [abstract/monad (#+ do Monad)] + [control + pipe] + [data + ["." maybe] + ["." text] + [number + ["." nat]] + [collection + ["." list]]] + [math + ["r" random]]] + ["." //] + {1 + ["." / (#+ Zipper) + ["tree" //]]} + ) + +(def: #export test + Test + (<| (_.context (%name (name-of /.Zipper))) + (do r.monad + [size (:: @ map (|>> (n/% 90) (n/+ 10)) r.nat) + sample (//.tree size r.nat) + mid-val r.nat + new-val r.nat + pre-val r.nat + post-val r.nat + #let [(^open "tree@.") (tree.equivalence nat.equivalence) + (^open "list@.") (list.equivalence nat.equivalence)]] + ($_ _.and + (_.test "Trees can be converted to/from zippers." + (|> sample + /.zip /.unzip + (tree@= sample))) + (_.test "Creating a zipper gives you a start node." + (|> sample /.zip /.start?)) + (_.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 /.start (is? zipper) not))) + (and (/.leaf? zipper) + (|> zipper (/.prepend-child new-val) /.branch?))))) + (do @ + [branch-value r.nat + #let [zipper (|> (/.zip (tree.branch branch-value (list (tree.leaf mid-val)))) + (/.prepend-child pre-val) + (/.append-child post-val))]] + (_.test "Can prepend and append children." + (and (and (|> zipper /.down /.value (is? pre-val)) + (|> zipper /.down /.right /.left /.value (is? pre-val)) + (|> zipper /.down /.rightmost /.leftmost /.value (is? pre-val))) + (|> zipper /.down /.right /.value (is? mid-val)) + (and (|> zipper /.down /.right /.right /.value (is? post-val)) + (|> zipper /.down /.rightmost /.value (is? post-val)))))) + (do @ + [branch-value r.nat + #let [zipper (/.zip (tree.branch branch-value (list (tree.leaf mid-val))))]] + (_.test "Can insert children around a node (unless it's start)." + (and (let [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." + (let [root (/.zip sample)] + (list@= (tree.flatten sample) + (loop [zipper (/.start root)] + (let [zipper' (/.next zipper)] + (#.Cons (/.value zipper) + (if (:: (/.equivalence nat.equivalence) = root zipper') + (list) + (recur zipper')))))))) + (_.test "Backwards zipper traversal yield reverse tree flatten." + (let [root (/.zip sample)] + (list@= (list.reverse (tree.flatten sample)) + (loop [zipper (/.end root)] + (#.Cons (/.value zipper) + (if (:: (/.equivalence nat.equivalence) = root zipper) + (list) + (recur (/.prev zipper)))))))) + (_.test "Can remove nodes (except start nodes)." + (let [zipper (/.zip sample)] + (if (/.branch? zipper) + (and (|> zipper /.down /.start? not) + (|> zipper /.down /.remove (case> #.None false + (#.Some node) (/.start? node)))) + (|> zipper /.remove (case> #.None true + (#.Some _) false))))) + )))) |