From 9465270e1f800199ef98f878b6f457331bf7dcab Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Fri, 19 Apr 2019 19:09:56 -0400 Subject: Re-named "lux/data/collection/tree/rose" to "lux/data/collection/tree". --- stdlib/source/lux/control/parser/tree.lux | 9 +- stdlib/source/lux/data/collection/tree.lux | 73 ++++++ stdlib/source/lux/data/collection/tree/rose.lux | 73 ------ .../lux/data/collection/tree/rose/zipper.lux | 285 --------------------- stdlib/source/lux/data/collection/tree/zipper.lux | 285 +++++++++++++++++++++ stdlib/source/lux/macro/poly/equivalence.lux | 5 +- stdlib/source/test/lux/data/collection.lux | 9 +- stdlib/source/test/lux/data/collection/tree.lux | 63 +++++ .../source/test/lux/data/collection/tree/rose.lux | 63 ----- .../test/lux/data/collection/tree/rose/zipper.lux | 116 --------- .../test/lux/data/collection/tree/zipper.lux | 115 +++++++++ 11 files changed, 546 insertions(+), 550 deletions(-) create mode 100644 stdlib/source/lux/data/collection/tree.lux delete mode 100644 stdlib/source/lux/data/collection/tree/rose.lux delete mode 100644 stdlib/source/lux/data/collection/tree/rose/zipper.lux create mode 100644 stdlib/source/lux/data/collection/tree/zipper.lux create mode 100644 stdlib/source/test/lux/data/collection/tree.lux delete mode 100644 stdlib/source/test/lux/data/collection/tree/rose.lux delete mode 100644 stdlib/source/test/lux/data/collection/tree/rose/zipper.lux create mode 100644 stdlib/source/test/lux/data/collection/tree/zipper.lux diff --git a/stdlib/source/lux/control/parser/tree.lux b/stdlib/source/lux/control/parser/tree.lux index 1c6e21f43..50c8c8a0e 100644 --- a/stdlib/source/lux/control/parser/tree.lux +++ b/stdlib/source/lux/control/parser/tree.lux @@ -1,12 +1,11 @@ (.module: [lux #* [control - ["ex" exception (#+ exception:)]] + ["." exception (#+ exception:)]] [data ["." error (#+ Error)] - [tree - [rose (#+ Tree) - ["." zipper (#+ Zipper)]]]]] + [tree (#+ Tree) + ["." zipper (#+ Zipper)]]]] ["." //]) (type: #export (Parser t a) @@ -38,7 +37,7 @@ (function (_ zipper) (let [next ( zipper)] (if (is? zipper next) - (ex.throw cannot-move-further []) + (exception.throw cannot-move-further []) (#error.Success [next []])))))] [up zipper.up] diff --git a/stdlib/source/lux/data/collection/tree.lux b/stdlib/source/lux/data/collection/tree.lux new file mode 100644 index 000000000..ad64b72ed --- /dev/null +++ b/stdlib/source/lux/data/collection/tree.lux @@ -0,0 +1,73 @@ +(.module: + [lux #* + [abstract + functor + [monad (#+ do Monad)] + equivalence + fold] + [control + ["p" parser]] + [data + [collection + ["." list ("#@." monad fold)]]] + ["." macro + ["." code] + ["s" syntax (#+ syntax: Syntax)]]]) + +(type: #export (Tree a) + {#value a + #children (List (Tree a))}) + +(def: #export (flatten tree) + (All [a] (-> (Tree a) (List a))) + (#.Cons (get@ #value tree) + (list@join (list@map flatten (get@ #children tree))))) + +(def: #export (leaf value) + (All [a] (-> a (Tree a))) + {#value value + #children (list)}) + +(def: #export (branch value children) + (All [a] (-> a (List (Tree a)) (Tree a))) + {#value value + #children children}) + +(type: #rec Tree-Code + [Code (List Tree-Code)]) + +(def: tree^ + (Syntax Tree-Code) + (|> (|>> p.some s.record (p.and s.any)) + p.rec + p.some + s.record + (p.and s.any) + s.tuple)) + +(syntax: #export (tree {root tree^}) + {#.doc (doc "Tree literals." + (tree Int [+10 {+20 {} + +30 {} + +40 {}}]))} + (wrap (list (` (~ (loop [[value children] root] + (` {#value (~ value) + #children (list (~+ (list@map recur children)))}))))))) + +(structure: #export (equivalence Equivalence) (All [a] (-> (Equivalence a) (Equivalence (Tree a)))) + (def: (= tx ty) + (and (:: Equivalence = (get@ #value tx) (get@ #value ty)) + (:: (list.equivalence (equivalence Equivalence)) = (get@ #children tx) (get@ #children ty))))) + +(structure: #export functor (Functor Tree) + (def: (map f fa) + {#value (f (get@ #value fa)) + #children (list@map (map f) + (get@ #children fa))})) + +(structure: #export fold (Fold Tree) + (def: (fold f init tree) + (list@fold (function (_ tree' init') (fold f init' tree')) + (f (get@ #value tree) + init) + (get@ #children tree)))) diff --git a/stdlib/source/lux/data/collection/tree/rose.lux b/stdlib/source/lux/data/collection/tree/rose.lux deleted file mode 100644 index ad64b72ed..000000000 --- a/stdlib/source/lux/data/collection/tree/rose.lux +++ /dev/null @@ -1,73 +0,0 @@ -(.module: - [lux #* - [abstract - functor - [monad (#+ do Monad)] - equivalence - fold] - [control - ["p" parser]] - [data - [collection - ["." list ("#@." monad fold)]]] - ["." macro - ["." code] - ["s" syntax (#+ syntax: Syntax)]]]) - -(type: #export (Tree a) - {#value a - #children (List (Tree a))}) - -(def: #export (flatten tree) - (All [a] (-> (Tree a) (List a))) - (#.Cons (get@ #value tree) - (list@join (list@map flatten (get@ #children tree))))) - -(def: #export (leaf value) - (All [a] (-> a (Tree a))) - {#value value - #children (list)}) - -(def: #export (branch value children) - (All [a] (-> a (List (Tree a)) (Tree a))) - {#value value - #children children}) - -(type: #rec Tree-Code - [Code (List Tree-Code)]) - -(def: tree^ - (Syntax Tree-Code) - (|> (|>> p.some s.record (p.and s.any)) - p.rec - p.some - s.record - (p.and s.any) - s.tuple)) - -(syntax: #export (tree {root tree^}) - {#.doc (doc "Tree literals." - (tree Int [+10 {+20 {} - +30 {} - +40 {}}]))} - (wrap (list (` (~ (loop [[value children] root] - (` {#value (~ value) - #children (list (~+ (list@map recur children)))}))))))) - -(structure: #export (equivalence Equivalence) (All [a] (-> (Equivalence a) (Equivalence (Tree a)))) - (def: (= tx ty) - (and (:: Equivalence = (get@ #value tx) (get@ #value ty)) - (:: (list.equivalence (equivalence Equivalence)) = (get@ #children tx) (get@ #children ty))))) - -(structure: #export functor (Functor Tree) - (def: (map f fa) - {#value (f (get@ #value fa)) - #children (list@map (map f) - (get@ #children fa))})) - -(structure: #export fold (Fold Tree) - (def: (fold f init tree) - (list@fold (function (_ tree' init') (fold f init' tree')) - (f (get@ #value tree) - init) - (get@ #children tree)))) diff --git a/stdlib/source/lux/data/collection/tree/rose/zipper.lux b/stdlib/source/lux/data/collection/tree/rose/zipper.lux deleted file mode 100644 index bac8961e3..000000000 --- a/stdlib/source/lux/data/collection/tree/rose/zipper.lux +++ /dev/null @@ -1,285 +0,0 @@ -(.module: - [lux #* - [abstract - functor - comonad - [equivalence (#+ Equivalence)]] - [data - ["." maybe ("#@." monad)] - [collection - ["." list ("#@." functor fold monoid)] - ["." stack (#+ Stack)]]] - ["." macro - ["." code] - ["s" syntax (#+ Syntax syntax:)]]] - ["." // (#+ Tree) ("#@." functor)]) - -(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)}) - -(structure: #export (equivalence ,equivalence) - (All [a] - (-> (Equivalence a) - (Equivalence (Zipper a)))) - (def: (= reference sample) - (and (:: (//.equivalence ,equivalence) = - (get@ #node reference) - (get@ #node sample)) - (:: (stack.equivalence (//.equivalence ,equivalence)) = - (get@ #lefts reference) - (get@ #lefts sample)) - (:: (stack.equivalence (//.equivalence ,equivalence)) = - (get@ #rights reference) - (get@ #rights sample)) - (:: (maybe.equivalence (equivalence ,equivalence)) = - (get@ #parent reference) - (get@ #parent sample)) - ))) - -(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 #//.value]))) - -(def: #export (children zipper) - (All [a] (-> (Zipper a) (List (Tree a)))) - (|> zipper (get@ [#node #//.children]))) - -(def: #export (branch? zipper) - (All [a] (-> (Zipper a) Bit)) - (|> zipper children list.empty? not)) - -(def: #export (leaf? zipper) - (All [a] (-> (Zipper a) Bit)) - (|> zipper branch? not)) - -(def: #export (start? zipper) - (All [a] (-> (Zipper a) Bit)) - (case (get@ #parent zipper) - #.None - #1 - - _ - #0)) - -(def: #export (down zipper) - (All [a] (-> (Zipper a) (Zipper a))) - (case (children zipper) - #.Nil - zipper - - (#.Cons head tail) - {#parent (#.Some zipper) - #lefts stack.empty - #rights tail - #node head})) - -(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@ #//.children (list@compose (list.reverse (get@ #lefts zipper)) - (#.Cons (get@ #node zipper) - (get@ #rights zipper))) - node)))) - ## (update@ #node (function (_ node) - ## (set@ #//.children (list@compose (list.reverse (get@ #lefts zipper)) - ## (#.Cons (get@ #node zipper) - ## (get@ #rights zipper))) - ## node))) - ))) - -(def: #export (start zipper) - (All [a] (-> (Zipper a) (Zipper a))) - (let [ancestor (..up zipper)] - (if (is? zipper ancestor) - zipper - (start ancestor)))) - -(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))) - (case (list.reverse (get@ zipper)) - #.Nil - zipper - - (#.Cons last prevs) - (|> zipper - (set@ #.Nil) - (set@ (|> (get@ zipper) - (#.Cons (get@ #node zipper)) - (list@compose prevs))) - (set@ #node last))))] - - [right rightmost #rights #lefts] - [left leftmost #lefts #rights] - ) - -(def: #export (next zipper) - (All [a] (-> (Zipper a) (Zipper a))) - (let [forward (..down zipper)] - (if (is? zipper forward) - (loop [zipper zipper] - (let [jump (..right zipper)] - (if (is? zipper jump) - (let [backward (..up zipper)] - (if (is? zipper backward) - zipper - (recur backward))) - jump))) - forward))) - -(def: #export (end zipper) - (All [a] (-> (Zipper a) (Zipper a))) - (case (get@ #rights zipper) - #.Nil - (case (get@ [#node #//.children] zipper) - #.Nil - zipper - - (#.Cons _) - (end (..down zipper))) - - (#.Cons _) - (end (..rightmost zipper)))) - -(def: #export (prev zipper) - (All [a] (-> (Zipper a) (Zipper a))) - (let [forward (..left zipper)] - (if (is? zipper forward) - (..up zipper) - (case (get@ [#node #//.children] forward) - #.Nil - forward - - (#.Cons _) - (..end (..down forward)))))) - -(def: #export (set value zipper) - (All [a] (-> a (Zipper a) (Zipper a))) - (set@ [#node #//.value] value zipper)) - -(def: #export (update f zipper) - (All [a] (-> (-> a a) (Zipper a) (Zipper a))) - (update@ [#node #//.value] f zipper)) - -(def: #export (prepend-child value zipper) - (All [a] (-> a (Zipper a) (Zipper a))) - (update@ [#node #//.children] - (function (_ children) - ## TODO: Remove once new-luxc becomes the standard compiler. - (list& (: (Tree ($ 0)) - (//.tree [value {}])) - children) - ## (list& (//.tree [value {}]) - ## children) - ) - zipper)) - -(def: #export (append-child value zipper) - (All [a] (-> a (Zipper a) (Zipper a))) - (update@ [#node #//.children] - (function (_ children) - (list@compose children - ## TODO: Remove once new-luxc becomes the standard compiler. - (list (: (Tree ($ 0)) - (//.tree [value {}]))) - ## (list (//.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 #//.children] (|>> list.tail (maybe.default (list))))))) - - (#.Cons next side) - (#.Some (|> zipper - (set@ #lefts side) - (set@ #node next))))) - -(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)) - (//.tree [value {}])) - side) - ## (#.Cons (//.tree [value {}]) - ## side) - ))))))] - - [insert-left #lefts] - [insert-right #rights] - ) - -(structure: #export functor (Functor Zipper) - (def: (map f fa) - {#parent (|> fa (get@ #parent) (maybe@map (map f))) - #lefts (|> fa (get@ #lefts) (list@map (//@map f))) - #rights (|> fa (get@ #rights) (list@map (//@map f))) - #node (//@map f (get@ #node fa))})) - -## TODO: Add again once new-luxc becomes the standard compiler. -## (structure: #export comonad (CoMonad Zipper) -## (def: &functor ..functor) - -## (def: unwrap (get@ [#node #//.value])) - -## (def: (split wa) -## (let [tree-splitter (function (tree-splitter tree) -## {#//.value (zip tree) -## #//.children (list@map tree-splitter -## (get@ #//.children tree))})] -## {#parent (|> wa (get@ #parent) (maybe@map split)) -## #lefts (|> wa (get@ #lefts) (list@map tree-splitter)) -## #rights (|> wa (get@ #rights) (list@map tree-splitter)) -## #node (|> fa (get@ #node) tree-splitter)}))) diff --git a/stdlib/source/lux/data/collection/tree/zipper.lux b/stdlib/source/lux/data/collection/tree/zipper.lux new file mode 100644 index 000000000..bac8961e3 --- /dev/null +++ b/stdlib/source/lux/data/collection/tree/zipper.lux @@ -0,0 +1,285 @@ +(.module: + [lux #* + [abstract + functor + comonad + [equivalence (#+ Equivalence)]] + [data + ["." maybe ("#@." monad)] + [collection + ["." list ("#@." functor fold monoid)] + ["." stack (#+ Stack)]]] + ["." macro + ["." code] + ["s" syntax (#+ Syntax syntax:)]]] + ["." // (#+ Tree) ("#@." functor)]) + +(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)}) + +(structure: #export (equivalence ,equivalence) + (All [a] + (-> (Equivalence a) + (Equivalence (Zipper a)))) + (def: (= reference sample) + (and (:: (//.equivalence ,equivalence) = + (get@ #node reference) + (get@ #node sample)) + (:: (stack.equivalence (//.equivalence ,equivalence)) = + (get@ #lefts reference) + (get@ #lefts sample)) + (:: (stack.equivalence (//.equivalence ,equivalence)) = + (get@ #rights reference) + (get@ #rights sample)) + (:: (maybe.equivalence (equivalence ,equivalence)) = + (get@ #parent reference) + (get@ #parent sample)) + ))) + +(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 #//.value]))) + +(def: #export (children zipper) + (All [a] (-> (Zipper a) (List (Tree a)))) + (|> zipper (get@ [#node #//.children]))) + +(def: #export (branch? zipper) + (All [a] (-> (Zipper a) Bit)) + (|> zipper children list.empty? not)) + +(def: #export (leaf? zipper) + (All [a] (-> (Zipper a) Bit)) + (|> zipper branch? not)) + +(def: #export (start? zipper) + (All [a] (-> (Zipper a) Bit)) + (case (get@ #parent zipper) + #.None + #1 + + _ + #0)) + +(def: #export (down zipper) + (All [a] (-> (Zipper a) (Zipper a))) + (case (children zipper) + #.Nil + zipper + + (#.Cons head tail) + {#parent (#.Some zipper) + #lefts stack.empty + #rights tail + #node head})) + +(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@ #//.children (list@compose (list.reverse (get@ #lefts zipper)) + (#.Cons (get@ #node zipper) + (get@ #rights zipper))) + node)))) + ## (update@ #node (function (_ node) + ## (set@ #//.children (list@compose (list.reverse (get@ #lefts zipper)) + ## (#.Cons (get@ #node zipper) + ## (get@ #rights zipper))) + ## node))) + ))) + +(def: #export (start zipper) + (All [a] (-> (Zipper a) (Zipper a))) + (let [ancestor (..up zipper)] + (if (is? zipper ancestor) + zipper + (start ancestor)))) + +(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))) + (case (list.reverse (get@ zipper)) + #.Nil + zipper + + (#.Cons last prevs) + (|> zipper + (set@ #.Nil) + (set@ (|> (get@ zipper) + (#.Cons (get@ #node zipper)) + (list@compose prevs))) + (set@ #node last))))] + + [right rightmost #rights #lefts] + [left leftmost #lefts #rights] + ) + +(def: #export (next zipper) + (All [a] (-> (Zipper a) (Zipper a))) + (let [forward (..down zipper)] + (if (is? zipper forward) + (loop [zipper zipper] + (let [jump (..right zipper)] + (if (is? zipper jump) + (let [backward (..up zipper)] + (if (is? zipper backward) + zipper + (recur backward))) + jump))) + forward))) + +(def: #export (end zipper) + (All [a] (-> (Zipper a) (Zipper a))) + (case (get@ #rights zipper) + #.Nil + (case (get@ [#node #//.children] zipper) + #.Nil + zipper + + (#.Cons _) + (end (..down zipper))) + + (#.Cons _) + (end (..rightmost zipper)))) + +(def: #export (prev zipper) + (All [a] (-> (Zipper a) (Zipper a))) + (let [forward (..left zipper)] + (if (is? zipper forward) + (..up zipper) + (case (get@ [#node #//.children] forward) + #.Nil + forward + + (#.Cons _) + (..end (..down forward)))))) + +(def: #export (set value zipper) + (All [a] (-> a (Zipper a) (Zipper a))) + (set@ [#node #//.value] value zipper)) + +(def: #export (update f zipper) + (All [a] (-> (-> a a) (Zipper a) (Zipper a))) + (update@ [#node #//.value] f zipper)) + +(def: #export (prepend-child value zipper) + (All [a] (-> a (Zipper a) (Zipper a))) + (update@ [#node #//.children] + (function (_ children) + ## TODO: Remove once new-luxc becomes the standard compiler. + (list& (: (Tree ($ 0)) + (//.tree [value {}])) + children) + ## (list& (//.tree [value {}]) + ## children) + ) + zipper)) + +(def: #export (append-child value zipper) + (All [a] (-> a (Zipper a) (Zipper a))) + (update@ [#node #//.children] + (function (_ children) + (list@compose children + ## TODO: Remove once new-luxc becomes the standard compiler. + (list (: (Tree ($ 0)) + (//.tree [value {}]))) + ## (list (//.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 #//.children] (|>> list.tail (maybe.default (list))))))) + + (#.Cons next side) + (#.Some (|> zipper + (set@ #lefts side) + (set@ #node next))))) + +(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)) + (//.tree [value {}])) + side) + ## (#.Cons (//.tree [value {}]) + ## side) + ))))))] + + [insert-left #lefts] + [insert-right #rights] + ) + +(structure: #export functor (Functor Zipper) + (def: (map f fa) + {#parent (|> fa (get@ #parent) (maybe@map (map f))) + #lefts (|> fa (get@ #lefts) (list@map (//@map f))) + #rights (|> fa (get@ #rights) (list@map (//@map f))) + #node (//@map f (get@ #node fa))})) + +## TODO: Add again once new-luxc becomes the standard compiler. +## (structure: #export comonad (CoMonad Zipper) +## (def: &functor ..functor) + +## (def: unwrap (get@ [#node #//.value])) + +## (def: (split wa) +## (let [tree-splitter (function (tree-splitter tree) +## {#//.value (zip tree) +## #//.children (list@map tree-splitter +## (get@ #//.children tree))})] +## {#parent (|> wa (get@ #parent) (maybe@map split)) +## #lefts (|> wa (get@ #lefts) (list@map tree-splitter)) +## #rights (|> wa (get@ #rights) (list@map tree-splitter)) +## #node (|> fa (get@ #node) tree-splitter)}))) diff --git a/stdlib/source/lux/macro/poly/equivalence.lux b/stdlib/source/lux/macro/poly/equivalence.lux index 50dabcd16..b9bb1f335 100644 --- a/stdlib/source/lux/macro/poly/equivalence.lux +++ b/stdlib/source/lux/macro/poly/equivalence.lux @@ -24,8 +24,7 @@ ["." queue] ["." set] ["." dictionary (#+ Dictionary)] - [tree - ["." rose]]]] + ["." tree]]] [time ["." duration] ["." date] @@ -77,7 +76,7 @@ [array.Array (~! array.equivalence)] [queue.Queue (~! queue.equivalence)] [set.Set (~! set.equivalence)] - [rose.Tree (~! rose.equivalence)] + [tree.Tree (~! tree.equivalence)] )) (do @ [[_ _ valC] (.apply ($_ p.and diff --git a/stdlib/source/test/lux/data/collection.lux b/stdlib/source/test/lux/data/collection.lux index ad86d3225..0d6cb1e64 100644 --- a/stdlib/source/test/lux/data/collection.lux +++ b/stdlib/source/test/lux/data/collection.lux @@ -14,9 +14,8 @@ ["#/." priority]] ["#." set ["#/." ordered]] - ["#." tree #_ - ["#/." rose - ["#/." zipper]]]]) + ["#." tree + ["#/." zipper]]]) (def: dictionary Test @@ -42,8 +41,8 @@ (def: tree Test ($_ _.and - /tree/rose.test - /tree/rose/zipper.test + /tree.test + /tree/zipper.test )) (def: #export test diff --git a/stdlib/source/test/lux/data/collection/tree.lux b/stdlib/source/test/lux/data/collection/tree.lux new file mode 100644 index 000000000..65b46e382 --- /dev/null +++ b/stdlib/source/test/lux/data/collection/tree.lux @@ -0,0 +1,63 @@ +(.module: + [lux #* + data/text/format + ["_" test (#+ Test)] + [abstract + [monad (#+ do)] + {[0 #test] + [/ + ["$." equivalence] + ["$." fold] + ["$." functor]]}] + [data + [number + ["." nat]] + [collection + ["." list ("#@." functor fold)]]] + [math + ["r" random (#+ Random)]]] + {1 + ["." / (#+ Tree)]}) + +(def: #export (tree size gen-value) + (All [a] (-> Nat (Random a) (Random (Tree a)))) + (let [singleton (:: r.monad map /.leaf gen-value)] + (case size + 0 + singleton + + 1 + singleton + + 2 + (do r.monad + [value gen-value + single (tree 1 gen-value)] + (wrap (/.branch value (list single)))) + + _ + (do r.monad + [value gen-value + #let [size (dec size)] + left (tree (n// 2 size) gen-value) + right (tree (n/+ (n/% 2 size) (n// 2 size)) + gen-value)] + (wrap (/.branch value (list left right)))) + ))) + +(def: #export test + Test + (<| (_.context (%name (name-of /.Tree))) + (do r.monad + [size (:: @ map (|>> (n/% 100) (n/+ 1)) r.nat)] + ($_ _.and + ($equivalence.spec (/.equivalence nat.equivalence) (..tree size r.nat)) + ($fold.spec /.leaf /.equivalence /.fold) + ($functor.spec /.leaf /.equivalence /.functor) + + (do @ + [sample (..tree size r.nat)] + (_.test "Can flatten a tree to get all the nodes as a flat tree." + (n/= size + (list.size (/.flatten sample))))) + )))) diff --git a/stdlib/source/test/lux/data/collection/tree/rose.lux b/stdlib/source/test/lux/data/collection/tree/rose.lux deleted file mode 100644 index 65b46e382..000000000 --- a/stdlib/source/test/lux/data/collection/tree/rose.lux +++ /dev/null @@ -1,63 +0,0 @@ -(.module: - [lux #* - data/text/format - ["_" test (#+ Test)] - [abstract - [monad (#+ do)] - {[0 #test] - [/ - ["$." equivalence] - ["$." fold] - ["$." functor]]}] - [data - [number - ["." nat]] - [collection - ["." list ("#@." functor fold)]]] - [math - ["r" random (#+ Random)]]] - {1 - ["." / (#+ Tree)]}) - -(def: #export (tree size gen-value) - (All [a] (-> Nat (Random a) (Random (Tree a)))) - (let [singleton (:: r.monad map /.leaf gen-value)] - (case size - 0 - singleton - - 1 - singleton - - 2 - (do r.monad - [value gen-value - single (tree 1 gen-value)] - (wrap (/.branch value (list single)))) - - _ - (do r.monad - [value gen-value - #let [size (dec size)] - left (tree (n// 2 size) gen-value) - right (tree (n/+ (n/% 2 size) (n// 2 size)) - gen-value)] - (wrap (/.branch value (list left right)))) - ))) - -(def: #export test - Test - (<| (_.context (%name (name-of /.Tree))) - (do r.monad - [size (:: @ map (|>> (n/% 100) (n/+ 1)) r.nat)] - ($_ _.and - ($equivalence.spec (/.equivalence nat.equivalence) (..tree size r.nat)) - ($fold.spec /.leaf /.equivalence /.fold) - ($functor.spec /.leaf /.equivalence /.functor) - - (do @ - [sample (..tree size r.nat)] - (_.test "Can flatten a tree to get all the nodes as a flat tree." - (n/= size - (list.size (/.flatten sample))))) - )))) diff --git a/stdlib/source/test/lux/data/collection/tree/rose/zipper.lux b/stdlib/source/test/lux/data/collection/tree/rose/zipper.lux deleted file mode 100644 index e8f59a43a..000000000 --- a/stdlib/source/test/lux/data/collection/tree/rose/zipper.lux +++ /dev/null @@ -1,116 +0,0 @@ -(.module: - [lux #* - data/text/format - ["_" test (#+ Test)] - [abstract/monad (#+ do Monad)] - [control - pipe] - [data - ["." maybe] - ["." text] - [number - ["." nat]] - [collection - ["." list] - [tree - ["." rose]]]] - [math - ["r" random]]] - ["." //] - {1 - ["." / (#+ Zipper)]} - ) - -(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@.") (rose.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 (rose.branch branch-value (list (rose.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 (rose.branch branch-value (list (rose.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@= (rose.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 (rose.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))))) - )))) 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))))) + )))) -- cgit v1.2.3