From 024d9990d005971e5c9a238bda8de620cd3b2fc1 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Fri, 23 Jun 2017 19:48:16 -0400 Subject: - Renamed lux/data/coll/ordered to lux/data/coll/ordered/set. - Created ordered dictionary implementation, and based the set implementation upon it. --- stdlib/source/lux/data/coll/ordered.lux | 493 --------------------- stdlib/source/lux/data/coll/ordered/dict.lux | 562 ++++++++++++++++++++++++ stdlib/source/lux/data/coll/ordered/set.lux | 86 ++++ stdlib/test/test/lux/data/coll/ordered.lux | 67 --- stdlib/test/test/lux/data/coll/ordered/dict.lux | 86 ++++ stdlib/test/test/lux/data/coll/ordered/set.lux | 92 ++++ 6 files changed, 826 insertions(+), 560 deletions(-) delete mode 100644 stdlib/source/lux/data/coll/ordered.lux create mode 100644 stdlib/source/lux/data/coll/ordered/dict.lux create mode 100644 stdlib/source/lux/data/coll/ordered/set.lux delete mode 100644 stdlib/test/test/lux/data/coll/ordered.lux create mode 100644 stdlib/test/test/lux/data/coll/ordered/dict.lux create mode 100644 stdlib/test/test/lux/data/coll/ordered/set.lux diff --git a/stdlib/source/lux/data/coll/ordered.lux b/stdlib/source/lux/data/coll/ordered.lux deleted file mode 100644 index 5a9794f85..000000000 --- a/stdlib/source/lux/data/coll/ordered.lux +++ /dev/null @@ -1,493 +0,0 @@ -(;module: - lux - (lux (control monad - eq - [order #+ Order]) - (data (coll [list "" Monad "L/" Monoid Fold]) - ["p" product] - ["M" maybe #+ Functor]) - [macro] - (macro [code] - ["s" syntax #+ syntax: Syntax]))) - -(def: error-message Text "Invariant violation") - -(type: Color #Red #Black) - -(type: (Node a) - {#color Color - #value a - #left (Maybe (Node a)) - #right (Maybe (Node a))}) - -(do-template [ ] - [(def: ( value left right) - (All [a] (-> a (Maybe (Node a)) (Maybe (Node a)) (Node a))) - {#color - #value value - #left left - #right right})] - - [red #Red] - [black #Black] - ) - -(type: #export (Set a) - {#order (Order a) - #root (Maybe (Node a))}) - -(def: #export (new Order) - (All [a] (-> (Order a) (Set a))) - {#order Order - #root #;None}) - -(def: #export (member? tree elem) - (All [a] (-> (Set a) a Bool)) - (let [(^open "T/") (get@ #order tree)] - (loop [node (get@ #root tree)] - (case node - #;None - false - - (#;Some node) - (or (T/= elem (get@ #value node)) - (recur (get@ #left node)) - (recur (get@ #right node))))))) - -(do-template [ ] - [(def: #export ( tree) - (All [a] (-> (Set a) (Maybe a))) - (loop [node (get@ #root tree)] - (case node - #;None - #;None - - (#;Some node) - (recur (get@ node)))))] - - [min #left] - [max #right] - ) - -(do-template [ ] - [(def: #export ( tree) - (All [a] (-> (Set a) Nat)) - (loop [node (get@ #root tree)] - (case node - #;None - +0 - - (#;Some node) - (n.inc ( (recur (get@ #left node)) - (recur (get@ #right node)))))))] - - [size n.+] - [depth n.max] - ) - -(do-template [ ] - [(def: ( self) - (All [a] (-> (Node a) (Node a))) - (case (get@ #color self) - - (set@ #color self) - - - - ))] - - [blacken #Red #Black self] - [redden #Black #Red (error! error-message)] - ) - -(def: (balance-left-add parent self) - (All [a] (-> (Node a) (Node a) (Node a))) - (with-expansions - [ (as-is (black (get@ #value parent) - (#;Some self) - (get@ #right parent)))] - (case (get@ #color self) - #Red - (case (get@ #left self) - (^multi (#;Some left) - [(get@ #color left) #Red]) - (red (get@ #value self) - (#;Some (blacken left)) - (#;Some (black (get@ #value parent) - (get@ #right self) - (get@ #right parent)))) - - _ - (case (get@ #right self) - (^multi (#;Some right) - [(get@ #color right) #Red]) - (red (get@ #value right) - (#;Some (black (get@ #value self) - (get@ #left self) - (get@ #left right))) - (#;Some (black (get@ #value parent) - (get@ #right right) - (get@ #right parent)))) - - _ - )) - - #Black - - ))) - -(def: (balance-right-add parent self) - (All [a] (-> (Node a) (Node a) (Node a))) - (with-expansions - [ (as-is (black (get@ #value parent) - (get@ #left parent) - (#;Some self)))] - (case (get@ #color self) - #Red - (case (get@ #right self) - (^multi (#;Some right) - [(get@ #color right) #Red]) - (red (get@ #value self) - (#;Some (black (get@ #value parent) - (get@ #left parent) - (get@ #left self))) - (#;Some (blacken right))) - - _ - (case (get@ #left self) - (^multi (#;Some left) - [(get@ #color left) #Red]) - (red (get@ #value left) - (#;Some (black (get@ #value parent) - (get@ #left parent) - (get@ #left left))) - (#;Some (black (get@ #value self) - (get@ #right left) - (get@ #right self)))) - - _ - )) - - #Black - - ))) - -(def: (add-left addition center) - (All [a] (-> (Node a) (Node a) (Node a))) - (case (get@ #color center) - #Red - (red (get@ #value center) (#;Some addition) (get@ #right center)) - - #Black - (balance-left-add center addition) - )) - -(def: (add-right addition center) - (All [a] (-> (Node a) (Node a) (Node a))) - (case (get@ #color center) - #Red - (red (get@ #value center) (get@ #left center) (#;Some addition)) - - #Black - (balance-right-add center addition) - )) - -(def: #export (add elem tree) - (All [a] (-> a (Set a) (Set a))) - (let [(^open "T/") (get@ #order tree) - root' (loop [?root (get@ #root tree)] - (case ?root - #;None - (#;Some (red elem #;None #;None)) - - (#;Some root) - (let [reference (get@ #value root)] - (with-expansions - [ (do-template [ ] - [( reference elem) - (let [side-root (get@ root) - outcome (recur side-root)] - (if (is side-root outcome) - ?root - (#;Some ( (default (undefined) outcome) - root))))] - - [T/< #left add-left] - [T/> #right add-right] - )] - (cond - - ## (T/= reference elem) - ?root - ))) - ))] - (set@ #root root' tree))) - -(def: (left-balance value ?left ?right) - (All [a] (-> a (Maybe (Node a)) (Maybe (Node a)) (Node a))) - (case ?left - (^multi (#;Some left) - [(get@ #color left) #Red] - [(get@ #left left) (#;Some left.left)] - [(get@ #color left.left) #Red]) - (red (get@ #value left) - (#;Some (blacken left.left)) - (#;Some (black value (get@ #right left) ?right))) - - (^multi (#;Some left) - [(get@ #color left) #Red] - [(get@ #right left) (#;Some left.right)] - [(get@ #color left.right) #Red]) - (red (get@ #value left.right) - (#;Some (black (get@ #value left) - (get@ #left left) - (get@ #left left.right))) - (#;Some (black value - (get@ #right left.right) - ?right))) - - _ - (black value ?left ?right))) - -(def: (right-balance value ?left ?right) - (All [a] (-> a (Maybe (Node a)) (Maybe (Node a)) (Node a))) - (case ?right - (^multi (#;Some right) - [(get@ #color right) #Red] - [(get@ #right right) (#;Some right.right)] - [(get@ #color right.right) #Red]) - (red (get@ #value right) - (#;Some (black value ?left (get@ #left right))) - (#;Some (blacken right.right))) - - (^multi (#;Some right) - [(get@ #color right) #Red] - [(get@ #left right) (#;Some right.left)] - [(get@ #color right.left) #Red]) - (red (get@ #value right.left) - (#;Some (black value ?left (get@ #left right.left))) - (#;Some (black (get@ #value right) - (get@ #right right.left) - (get@ #right right)))) - - _ - (black value ?left ?right))) - -(def: (balance-left-remove value ?left ?right) - (All [a] (-> a (Maybe (Node a)) (Maybe (Node a)) (Node a))) - (case ?left - (^multi (#;Some left) - [(get@ #color left) #Red]) - (red value (#;Some (blacken left)) ?right) - - _ - (case ?right - (^multi (#;Some right) - [(get@ #color right) #Black]) - (right-balance value ?left (#;Some (redden right))) - - (^multi (#;Some right) - [(get@ #color right) #Red] - [(get@ #left right) (#;Some right.left)] - [(get@ #color right.left) #Black]) - (red (get@ #value right.left) - (#;Some (black value ?left (get@ #left right.left))) - (#;Some (right-balance (get@ #value right) - (get@ #right right.left) - (:: Functor map redden (get@ #right right))))) - - _ - (error! error-message)) - )) - -(def: (balance-right-remove value ?left ?right) - (All [a] (-> a (Maybe (Node a)) (Maybe (Node a)) (Node a))) - (case ?right - (^multi (#;Some right) - [(get@ #color right) #Red]) - (red value ?left (#;Some (blacken right))) - - _ - (case ?left - (^multi (#;Some left) - [(get@ #color left) #Black]) - (left-balance value (#;Some (redden left)) ?right) - - (^multi (#;Some left) - [(get@ #color left) #Red] - [(get@ #right left) (#;Some left.right)] - [(get@ #color left.right) #Black]) - (red (get@ #value left.right) - (#;Some (left-balance (get@ #value left) - (:: Functor map redden (get@ #left left)) - (get@ #left left.right))) - (#;Some (black value (get@ #right left.right) ?right))) - - _ - (error! error-message) - ))) - -(def: (prepend ?left ?right) - (All [a] (-> (Maybe (Node a)) (Maybe (Node a)) (Maybe (Node a)))) - (case [?left ?right] - [#;None _] - ?right - - [_ #;None] - ?left - - [(#;Some left) (#;Some right)] - (case [(get@ #color left) (get@ #color right)] - [#Red #Red] - (do M;Monad - [fused (prepend (get@ #right left) (get@ #right right))] - (case (get@ #color fused) - #Red - (wrap (red (get@ #value fused) - (#;Some (red (get@ #value left) - (get@ #left left) - (get@ #left fused))) - (#;Some (red (get@ #value right) - (get@ #right fused) - (get@ #right right))))) - - #Black - (wrap (red (get@ #value left) - (get@ #left left) - (#;Some (red (get@ #value right) - (#;Some fused) - (get@ #right right))))))) - - [#Red #Black] - (#;Some (red (get@ #value left) - (get@ #left left) - (prepend (get@ #right left) - ?right))) - - [#Black #Red] - (#;Some (red (get@ #value right) - (prepend ?left - (get@ #left right)) - (get@ #right right))) - - [#Black #Black] - (do M;Monad - [fused (prepend (get@ #right left) (get@ #left right))] - (case (get@ #color fused) - #Red - (wrap (red (get@ #value fused) - (#;Some (black (get@ #value left) - (get@ #left left) - (get@ #left fused))) - (#;Some (black (get@ #value right) - (get@ #right fused) - (get@ #right right))))) - - #Black - (wrap (balance-left-remove (get@ #value left) - (get@ #left left) - (#;Some (black (get@ #value right) - (#;Some fused) - (get@ #right right))))) - )) - ))) - -(def: #export (remove elem tree) - (All [a] (-> a (Set a) (Set a))) - (let [(^open "T/") (get@ #order tree) - [?root found?] (loop [?root (get@ #root tree)] - (case ?root - #;None - [#;None false] - - (#;Some root) - (let [root-val (get@ #value root)] - (if (T/= root-val elem) - [(prepend (get@ #left root) - (get@ #right root)) - true] - (let [go-left? (T/< root-val elem)] - (case (recur (if go-left? - (get@ #left root) - (get@ #right root))) - [#;None false] - [#;None false] - - [side-outcome _] - (if go-left? - (case (get@ #left root) - (^multi (#;Some left) - [(get@ #color left) #Black]) - [(#;Some (balance-left-remove root-val side-outcome (get@ #right root))) - false] - - _ - [(#;Some (red root-val side-outcome (get@ #right root))) - false]) - (case (get@ #right root) - (^multi (#;Some right) - [(get@ #color right) #Black]) - [(#;Some (balance-right-remove root-val (get@ #left root) side-outcome)) - false] - - _ - [(#;Some (red root-val (get@ #left root) side-outcome)) - false]) - ))) - )) - ))] - (case ?root - #;None - (if found? - (set@ #root ?root tree) - tree) - - (#;Some root) - (set@ #root (#;Some (blacken root)) tree) - ))) - -(def: #export (from-list Order list) - (All [a] (-> (Order a) (List a) (Set a))) - (L/fold add (new Order) list)) - -(def: #export (to-list tree) - (All [a] (-> (Set a) (List a))) - (loop [node (get@ #root tree)] - (case node - #;None - (list) - - (#;Some node') - ($_ L/append - (recur (get@ #left node')) - (list (get@ #value node')) - (recur (get@ #right node')))))) - -(def: #export (union left right) - (All [a] (-> (Set a) (Set a) (Set a))) - (L/fold add right (to-list left))) - -(def: #export (intersection left right) - (All [a] (-> (Set a) (Set a) (Set a))) - (|> (to-list right) - (list;filter (member? left)) - (from-list (get@ #order right)))) - -(def: #export (difference param subject) - (All [a] (-> (Set a) (Set a) (Set a))) - (|> (to-list subject) - (list;filter (. not (member? param))) - (from-list (get@ #order subject)))) - -(def: #export (sub? super sub) - (All [a] (-> (Set a) (Set a) Bool)) - (list;every? (member? super) (to-list sub))) - -(def: #export (super? sub super) - (All [a] (-> (Set a) (Set a) Bool)) - (sub? super sub)) - -(struct: #export Eq (All [a] (Eq (Set a))) - (def: (= reference sample) - (:: (list;Eq (:: sample eq)) - = (to-list reference) (to-list sample)))) diff --git a/stdlib/source/lux/data/coll/ordered/dict.lux b/stdlib/source/lux/data/coll/ordered/dict.lux new file mode 100644 index 000000000..714f14b5d --- /dev/null +++ b/stdlib/source/lux/data/coll/ordered/dict.lux @@ -0,0 +1,562 @@ +(;module: + lux + (lux (control monad + eq + [order #+ Order]) + (data (coll [list "L/" Monad Monoid Fold]) + ["p" product] + ["M" maybe #+ Functor]) + [macro] + (macro [code] + ["s" syntax #+ syntax: Syntax]))) + +(def: error-message Text "Invariant violation") + +(type: Color #Red #Black) + +(type: (Node k v) + {#color Color + #key k + #value v + #left (Maybe (Node k v)) + #right (Maybe (Node k v))}) + +(do-template [ ] + [(def: ( key value left right) + (All [k v] (-> k v (Maybe (Node k v)) (Maybe (Node k v)) (Node k v))) + {#color + #key key + #value value + #left left + #right right})] + + [red #Red] + [black #Black] + ) + +(type: #export (Dict k v) + {#order (Order k) + #root (Maybe (Node k v))}) + +(def: #export (new Order) + (All [k v] (-> (Order k) (Dict k v))) + {#order Order + #root #;None}) + +## TODO: Doing inneficient access of Order functions due to compiler bug. +## TODO: Must improve it as soon as bug is fixed. +(def: #export (get key dict) + (All [k v] (-> k (Dict k v) (Maybe v))) + (let [## (^open "T/") (get@ #order dict) + ] + (loop [node (get@ #root dict)] + (case node + #;None + #;None + + (#;Some node) + (let [node-key (get@ #key node)] + (cond (:: dict = node-key key) + ## (T/= node-key key) + (#;Some (get@ #value node)) + + (:: dict < node-key key) + ## (T/< node-key key) + (recur (get@ #left node)) + + ## (T/> (get@ #key node) key) + (recur (get@ #right node)))) + )))) + +(def: #export (contains? key dict) + (All [k v] (-> k (Dict k v) Bool)) + (let [## (^open "T/") (get@ #order dict) + ] + (loop [node (get@ #root dict)] + (case node + #;None + false + + (#;Some node) + (let [node-key (get@ #key node)] + (or (:: dict = node-key key) + ## (T/= node-key key) + (if (:: dict < node-key key) + ## (T/< node-key key) + (recur (get@ #left node)) + (recur (get@ #right node))))))))) + +(do-template [ ] + [(def: #export ( dict) + (All [k v] (-> (Dict k v) (Maybe v))) + (case (get@ #root dict) + #;None + #;None + + (#;Some node) + (loop [node node] + (case (get@ node) + #;None + (#;Some (get@ #value node)) + + (#;Some side) + (recur side)))))] + + [min #left] + [max #right] + ) + +(do-template [ ] + [(def: #export ( dict) + (All [k v] (-> (Dict k v) Nat)) + (loop [node (get@ #root dict)] + (case node + #;None + +0 + + (#;Some node) + (n.inc ( (recur (get@ #left node)) + (recur (get@ #right node)))))))] + + [size n.+] + [depth n.max] + ) + +(do-template [ ] + [(def: ( self) + (All [k v] (-> (Node k v) (Node k v))) + (case (get@ #color self) + + (set@ #color self) + + + + ))] + + [blacken #Red #Black self] + [redden #Black #Red (error! error-message)] + ) + +(def: (balance-left-add parent self) + (All [k v] (-> (Node k v) (Node k v) (Node k v))) + (with-expansions + [ (as-is (black (get@ #key parent) + (get@ #value parent) + (#;Some self) + (get@ #right parent)))] + (case (get@ #color self) + #Red + (case (get@ #left self) + (^multi (#;Some left) + [(get@ #color left) #Red]) + (red (get@ #key self) + (get@ #value self) + (#;Some (blacken left)) + (#;Some (black (get@ #key parent) + (get@ #value parent) + (get@ #right self) + (get@ #right parent)))) + + _ + (case (get@ #right self) + (^multi (#;Some right) + [(get@ #color right) #Red]) + (red (get@ #key right) + (get@ #value right) + (#;Some (black (get@ #key self) + (get@ #value self) + (get@ #left self) + (get@ #left right))) + (#;Some (black (get@ #key parent) + (get@ #value parent) + (get@ #right right) + (get@ #right parent)))) + + _ + )) + + #Black + + ))) + +(def: (balance-right-add parent self) + (All [k v] (-> (Node k v) (Node k v) (Node k v))) + (with-expansions + [ (as-is (black (get@ #key parent) + (get@ #value parent) + (get@ #left parent) + (#;Some self)))] + (case (get@ #color self) + #Red + (case (get@ #right self) + (^multi (#;Some right) + [(get@ #color right) #Red]) + (red (get@ #key self) + (get@ #value self) + (#;Some (black (get@ #key parent) + (get@ #value parent) + (get@ #left parent) + (get@ #left self))) + (#;Some (blacken right))) + + _ + (case (get@ #left self) + (^multi (#;Some left) + [(get@ #color left) #Red]) + (red (get@ #key left) + (get@ #value left) + (#;Some (black (get@ #key parent) + (get@ #value parent) + (get@ #left parent) + (get@ #left left))) + (#;Some (black (get@ #key self) + (get@ #value self) + (get@ #right left) + (get@ #right self)))) + + _ + )) + + #Black + + ))) + +(def: (add-left addition center) + (All [k v] (-> (Node k v) (Node k v) (Node k v))) + (case (get@ #color center) + #Red + (red (get@ #key center) (get@ #value center) (#;Some addition) (get@ #right center)) + + #Black + (balance-left-add center addition) + )) + +(def: (add-right addition center) + (All [k v] (-> (Node k v) (Node k v) (Node k v))) + (case (get@ #color center) + #Red + (red (get@ #key center) (get@ #value center) (get@ #left center) (#;Some addition)) + + #Black + (balance-right-add center addition) + )) + +(def: #export (put key value dict) + (All [k v] (-> k v (Dict k v) (Dict k v))) + (let [(^open "T/") (get@ #order dict) + root' (loop [?root (get@ #root dict)] + (case ?root + #;None + (#;Some (red key value #;None #;None)) + + (#;Some root) + (let [reference (get@ #key root)] + (with-expansions + [ (do-template [ ] + [( reference key) + (let [side-root (get@ root) + outcome (recur side-root)] + (if (is side-root outcome) + ?root + (#;Some ( (default (undefined) outcome) + root))))] + + [T/< #left add-left] + [T/> #right add-right] + )] + (cond + + ## (T/= reference key) + ?root + ))) + ))] + (set@ #root root' dict))) + +(def: (left-balance key value ?left ?right) + (All [k v] (-> k v (Maybe (Node k v)) (Maybe (Node k v)) (Node k v))) + (case ?left + (^multi (#;Some left) + [(get@ #color left) #Red] + [(get@ #left left) (#;Some left.left)] + [(get@ #color left.left) #Red]) + (red (get@ #key left) + (get@ #value left) + (#;Some (blacken left.left)) + (#;Some (black key value (get@ #right left) ?right))) + + (^multi (#;Some left) + [(get@ #color left) #Red] + [(get@ #right left) (#;Some left.right)] + [(get@ #color left.right) #Red]) + (red (get@ #key left.right) + (get@ #value left.right) + (#;Some (black (get@ #key left) + (get@ #value left) + (get@ #left left) + (get@ #left left.right))) + (#;Some (black key value + (get@ #right left.right) + ?right))) + + _ + (black key value ?left ?right))) + +(def: (right-balance key value ?left ?right) + (All [k v] (-> k v (Maybe (Node k v)) (Maybe (Node k v)) (Node k v))) + (case ?right + (^multi (#;Some right) + [(get@ #color right) #Red] + [(get@ #right right) (#;Some right.right)] + [(get@ #color right.right) #Red]) + (red (get@ #key right) + (get@ #value right) + (#;Some (black key value ?left (get@ #left right))) + (#;Some (blacken right.right))) + + (^multi (#;Some right) + [(get@ #color right) #Red] + [(get@ #left right) (#;Some right.left)] + [(get@ #color right.left) #Red]) + (red (get@ #key right.left) + (get@ #value right.left) + (#;Some (black key value ?left (get@ #left right.left))) + (#;Some (black (get@ #key right) + (get@ #value right) + (get@ #right right.left) + (get@ #right right)))) + + _ + (black key value ?left ?right))) + +(def: (balance-left-remove key value ?left ?right) + (All [k v] (-> k v (Maybe (Node k v)) (Maybe (Node k v)) (Node k v))) + (case ?left + (^multi (#;Some left) + [(get@ #color left) #Red]) + (red key value (#;Some (blacken left)) ?right) + + _ + (case ?right + (^multi (#;Some right) + [(get@ #color right) #Black]) + (right-balance key value ?left (#;Some (redden right))) + + (^multi (#;Some right) + [(get@ #color right) #Red] + [(get@ #left right) (#;Some right.left)] + [(get@ #color right.left) #Black]) + (red (get@ #key right.left) + (get@ #value right.left) + (#;Some (black key value ?left (get@ #left right.left))) + (#;Some (right-balance (get@ #key right) + (get@ #value right) + (get@ #right right.left) + (:: Functor map redden (get@ #right right))))) + + _ + (error! error-message)) + )) + +(def: (balance-right-remove key value ?left ?right) + (All [k v] (-> k v (Maybe (Node k v)) (Maybe (Node k v)) (Node k v))) + (case ?right + (^multi (#;Some right) + [(get@ #color right) #Red]) + (red key value ?left (#;Some (blacken right))) + + _ + (case ?left + (^multi (#;Some left) + [(get@ #color left) #Black]) + (left-balance key value (#;Some (redden left)) ?right) + + (^multi (#;Some left) + [(get@ #color left) #Red] + [(get@ #right left) (#;Some left.right)] + [(get@ #color left.right) #Black]) + (red (get@ #key left.right) + (get@ #value left.right) + (#;Some (left-balance (get@ #key left) + (get@ #value left) + (:: Functor map redden (get@ #left left)) + (get@ #left left.right))) + (#;Some (black key value (get@ #right left.right) ?right))) + + _ + (error! error-message) + ))) + +(def: (prepend ?left ?right) + (All [k v] (-> (Maybe (Node k v)) (Maybe (Node k v)) (Maybe (Node k v)))) + (case [?left ?right] + [#;None _] + ?right + + [_ #;None] + ?left + + [(#;Some left) (#;Some right)] + (case [(get@ #color left) (get@ #color right)] + [#Red #Red] + (do M;Monad + [fused (prepend (get@ #right left) (get@ #right right))] + (case (get@ #color fused) + #Red + (wrap (red (get@ #key fused) + (get@ #value fused) + (#;Some (red (get@ #key left) + (get@ #value left) + (get@ #left left) + (get@ #left fused))) + (#;Some (red (get@ #key right) + (get@ #value right) + (get@ #right fused) + (get@ #right right))))) + + #Black + (wrap (red (get@ #key left) + (get@ #value left) + (get@ #left left) + (#;Some (red (get@ #key right) + (get@ #value right) + (#;Some fused) + (get@ #right right))))))) + + [#Red #Black] + (#;Some (red (get@ #key left) + (get@ #value left) + (get@ #left left) + (prepend (get@ #right left) + ?right))) + + [#Black #Red] + (#;Some (red (get@ #key right) + (get@ #value right) + (prepend ?left + (get@ #left right)) + (get@ #right right))) + + [#Black #Black] + (do M;Monad + [fused (prepend (get@ #right left) (get@ #left right))] + (case (get@ #color fused) + #Red + (wrap (red (get@ #key fused) + (get@ #value fused) + (#;Some (black (get@ #key left) + (get@ #value left) + (get@ #left left) + (get@ #left fused))) + (#;Some (black (get@ #key right) + (get@ #value right) + (get@ #right fused) + (get@ #right right))))) + + #Black + (wrap (balance-left-remove (get@ #key left) + (get@ #value left) + (get@ #left left) + (#;Some (black (get@ #key right) + (get@ #value right) + (#;Some fused) + (get@ #right right))))) + )) + ))) + +(def: #export (remove key dict) + (All [k v] (-> k (Dict k v) (Dict k v))) + (let [(^open "T/") (get@ #order dict) + [?root found?] (loop [?root (get@ #root dict)] + (case ?root + #;None + [#;None false] + + (#;Some root) + (let [root-key (get@ #key root) + root-val (get@ #value root)] + (if (T/= root-key key) + [(prepend (get@ #left root) + (get@ #right root)) + true] + (let [go-left? (T/< root-key key)] + (case (recur (if go-left? + (get@ #left root) + (get@ #right root))) + [#;None false] + [#;None false] + + [side-outcome _] + (if go-left? + (case (get@ #left root) + (^multi (#;Some left) + [(get@ #color left) #Black]) + [(#;Some (balance-left-remove root-key root-val side-outcome (get@ #right root))) + false] + + _ + [(#;Some (red root-key root-val side-outcome (get@ #right root))) + false]) + (case (get@ #right root) + (^multi (#;Some right) + [(get@ #color right) #Black]) + [(#;Some (balance-right-remove root-key root-val (get@ #left root) side-outcome)) + false] + + _ + [(#;Some (red root-key root-val (get@ #left root) side-outcome)) + false]) + ))) + )) + ))] + (case ?root + #;None + (if found? + (set@ #root ?root dict) + dict) + + (#;Some root) + (set@ #root (#;Some (blacken root)) dict) + ))) + +(def: #export (from-list Order list) + (All [k v] (-> (Order k) (List [k v]) (Dict k v))) + (L/fold (function [[key value] dict] + (put key value dict)) + (new Order) + list)) + +(do-template [ ] + [(def: #export ( dict) + (All [k v] (-> (Dict k v) (List ))) + (loop [node (get@ #root dict)] + (case node + #;None + (list) + + (#;Some node') + ($_ L/append + (recur (get@ #left node')) + (list ) + (recur (get@ #right node'))))))] + + [entries [k v] [(get@ #key node') (get@ #value node')]] + [keys k (get@ #key node')] + [values v (get@ #value node')] + ) + +(struct: #export (Eq Eq) (All [k v] (-> (Eq v) (Eq (Dict k v)))) + (def: (= reference sample) + (let [Eq (:: sample eq)] + (loop [entriesR (entries reference) + entriesS (entries sample)] + (case [entriesR entriesS] + [#;Nil #;Nil] + true + + [(#;Cons [keyR valueR] entriesR') (#;Cons [keyS valueS] entriesS')] + (and (:: Eq = keyR keyS) + (:: Eq = valueR valueS) + (recur entriesR' entriesS')) + + _ + false))))) diff --git a/stdlib/source/lux/data/coll/ordered/set.lux b/stdlib/source/lux/data/coll/ordered/set.lux new file mode 100644 index 000000000..1ee2861e8 --- /dev/null +++ b/stdlib/source/lux/data/coll/ordered/set.lux @@ -0,0 +1,86 @@ +(;module: + lux + (lux (control monad + eq + [order #+ Order]) + (data (coll [list "" Monad "L/" Monoid Fold] + (ordered ["d" dict])) + ["p" product] + ["M" maybe #+ Functor]) + [macro] + (macro [code] + ["s" syntax #+ syntax: Syntax]))) + +(type: #export (Set a) + (d;Dict a a)) + +(def: #export new + (All [a] (-> (Order a) (Set a))) + d;new) + +(def: #export (member? set elem) + (All [a] (-> (Set a) a Bool)) + (d;contains? elem set)) + +(do-template [ ] + [(def: #export ( set) + (All [a] (-> (Set a) (Maybe a))) + ( set))] + + [min d;min] + [max d;max] + ) + +(do-template [ ] + [(def: #export ( set) + (All [a] (-> (Set a) Nat)) + ( set))] + + [size d;size] + [depth d;depth] + ) + +(def: #export (add elem set) + (All [a] (-> a (Set a) (Set a))) + (d;put elem elem set)) + +(def: #export (remove elem set) + (All [a] (-> a (Set a) (Set a))) + (d;remove elem set)) + +(def: #export (from-list Order list) + (All [a] (-> (Order a) (List a) (Set a))) + (L/fold add (new Order) list)) + +(def: #export (to-list set) + (All [a] (-> (Set a) (List a))) + (d;keys set)) + +(def: #export (union left right) + (All [a] (-> (Set a) (Set a) (Set a))) + (L/fold add right (to-list left))) + +(def: #export (intersection left right) + (All [a] (-> (Set a) (Set a) (Set a))) + (|> (to-list right) + (list;filter (member? left)) + (from-list (get@ #d;order right)))) + +(def: #export (difference param subject) + (All [a] (-> (Set a) (Set a) (Set a))) + (|> (to-list subject) + (list;filter (. not (member? param))) + (from-list (get@ #d;order subject)))) + +(def: #export (sub? super sub) + (All [a] (-> (Set a) (Set a) Bool)) + (list;every? (member? super) (to-list sub))) + +(def: #export (super? sub super) + (All [a] (-> (Set a) (Set a) Bool)) + (sub? super sub)) + +(struct: #export Eq (All [a] (Eq (Set a))) + (def: (= reference sample) + (:: (list;Eq (:: sample eq)) + = (to-list reference) (to-list sample)))) diff --git a/stdlib/test/test/lux/data/coll/ordered.lux b/stdlib/test/test/lux/data/coll/ordered.lux deleted file mode 100644 index 0ee02dea6..000000000 --- a/stdlib/test/test/lux/data/coll/ordered.lux +++ /dev/null @@ -1,67 +0,0 @@ -(;module: - lux - (lux [io] - (control monad) - (data (coll ["&" ordered] - ["S" set] - [list "" Fold]) - [number] - text/format) - ["R" math/random]) - lux/test) - -(def: gen-nat - (R;Random Nat) - (|> R;nat - (:: R;Monad map (n.% +100)))) - -(context: "Sets" - [sizeL gen-nat - sizeR gen-nat - setL (|> (R;set number;Hash sizeL gen-nat) - (:: @ map (|>. S;to-list (&;from-list number;Order)))) - setR (|> (R;set number;Hash sizeR gen-nat) - (:: @ map (|>. S;to-list (&;from-list number;Order)))) - #let [(^open "&/") &;Eq]] - ($_ seq - (test "I can query the size of a set." - (n.= sizeL (&;size setL))) - - (test "Converting sets to/from lists can't change their values." - (|> setL - &;to-list (&;from-list number;Order) - (&/= setL))) - - (test "Order is preserved." - (let [listL (&;to-list setL) - (^open "L/") (list;Eq number;Eq)] - (L/= listL - (list;sort n.< listL)))) - - (test "Every set is a sub-set of the union of itself with another." - (let [setLR (&;union setL setR)] - (and (&;sub? setLR setL) - (&;sub? setLR setR)))) - - (test "Every set is a super-set of the intersection of itself with another." - (let [setLR (&;intersection setL setR)] - (and (&;super? setLR setL) - (&;super? setLR setR)))) - - (test "Union with the empty set leaves a set unchanged." - (&/= setL - (&;union (&;new number;Order) - setL))) - - (test "Intersection with the empty set results in the empty set." - (let [empty-set (&;new number;Order)] - (&/= empty-set - (&;intersection empty-set setL)))) - - (test "After substracting a set A from another B, no member of A can be a member of B." - (let [sub (&;difference setR setL)] - (not (list;any? (&;member? sub) (&;to-list setR))))) - - (test "Every member of a set must be identifiable." - (list;every? (&;member? setL) (&;to-list setL))) - )) diff --git a/stdlib/test/test/lux/data/coll/ordered/dict.lux b/stdlib/test/test/lux/data/coll/ordered/dict.lux new file mode 100644 index 000000000..8793be9c2 --- /dev/null +++ b/stdlib/test/test/lux/data/coll/ordered/dict.lux @@ -0,0 +1,86 @@ +(;module: + lux + (lux [io] + (control monad + eq) + (data [product] + [number] + (coll (ordered ["&" dict]) + ["s" set] + ["d" dict] + [list "L/" Functor])) + ["r" math/random]) + lux/test) + +(context: "Dict" + [size (|> r;nat (:: @ map (n.% +100))) + keys (r;set number;Hash size r;nat) + values (r;set number;Hash size r;nat) + extra-key (|> r;nat (r;filter (|>. (s;member? keys) not))) + extra-value r;nat + #let [pairs (list;zip2 (s;to-list keys) + (s;to-list values)) + sample (&;from-list number;Order pairs) + sorted-pairs (list;sort (function [[left _] [right _]] + (n.< left right)) + pairs) + sorted-values (L/map product;right sorted-pairs) + (^open "&/") (&;Eq number;Eq)]] + ($_ seq + (test "Can query the size of a dictionary." + (n.= size (&;size sample))) + + (test "Can query value for minimum key." + (case [(&;min sample) (list;head sorted-values)] + [#;None #;None] + true + + [(#;Some reference) (#;Some sample)] + (n.= reference sample) + + _ + false)) + + (test "Can query value for maximum key." + (case [(&;max sample) (list;last sorted-values)] + [#;None #;None] + true + + [(#;Some reference) (#;Some sample)] + (n.= reference sample) + + _ + false)) + + (test "Converting dictionaries to/from lists cannot change their values." + (|> sample + &;entries (&;from-list number;Order) + (&/= sample))) + + (test "Order is preserved." + (let [(^open "L/") (list;Eq (: (Eq [Nat Nat]) + (function [[kr vr] [ks vs]] + (and (n.= kr ks) + (n.= vr vs)))))] + (L/= (&;entries sample) + sorted-pairs))) + + (test "Every key in a dictionary must be identifiable." + (list;every? (function [key] (&;contains? key sample)) + (&;keys sample))) + + (test "Can add and remove elements in a dictionary." + (and (not (&;contains? extra-key sample)) + (let [sample' (&;put extra-key extra-value sample) + sample'' (&;remove extra-key sample')] + (and (&;contains? extra-key sample') + (not (&;contains? extra-key sample'')) + (case [(&;get extra-key sample') + (&;get extra-key sample'')] + [(#;Some found) #;None] + (n.= extra-value found) + + _ + false))) + )) + )) diff --git a/stdlib/test/test/lux/data/coll/ordered/set.lux b/stdlib/test/test/lux/data/coll/ordered/set.lux new file mode 100644 index 000000000..40b448f1e --- /dev/null +++ b/stdlib/test/test/lux/data/coll/ordered/set.lux @@ -0,0 +1,92 @@ +(;module: + lux + (lux [io] + (control monad) + (data (coll (ordered ["&" set]) + ["s" set] + [list "" Fold]) + [number] + text/format) + ["r" math/random]) + lux/test) + +(def: gen-nat + (r;Random Nat) + (|> r;nat + (:: r;Monad map (n.% +100)))) + +(context: "Sets" + [sizeL gen-nat + sizeR gen-nat + listL (|> (r;set number;Hash sizeL gen-nat) (:: @ map s;to-list)) + listR (|> (r;set number;Hash sizeR gen-nat) (:: @ map s;to-list)) + #let [(^open "&/") &;Eq + setL (&;from-list number;Order listL) + setR (&;from-list number;Order listR) + sortedL (list;sort n.< listL) + minL (list;head sortedL) + maxL (list;last sortedL)]] + ($_ seq + (test "I can query the size of a set." + (n.= sizeL (&;size setL))) + + (test "Can query minimum value." + (case [(&;min setL) minL] + [#;None #;None] + true + + [(#;Some reference) (#;Some sample)] + (n.= reference sample) + + _ + false)) + + (test "Can query maximum value." + (case [(&;max setL) maxL] + [#;None #;None] + true + + [(#;Some reference) (#;Some sample)] + (n.= reference sample) + + _ + false)) + + (test "Converting sets to/from lists can't change their values." + (|> setL + &;to-list (&;from-list number;Order) + (&/= setL))) + + (test "Order is preserved." + (let [listL (&;to-list setL) + (^open "L/") (list;Eq number;Eq)] + (L/= listL + (list;sort n.< listL)))) + + (test "Every set is a sub-set of the union of itself with another." + (let [setLR (&;union setL setR)] + (and (&;sub? setLR setL) + (&;sub? setLR setR)))) + + (test "Every set is a super-set of the intersection of itself with another." + (let [setLR (&;intersection setL setR)] + (and (&;super? setLR setL) + (&;super? setLR setR)))) + + (test "Union with the empty set leaves a set unchanged." + (&/= setL + (&;union (&;new number;Order) + setL))) + + (test "Intersection with the empty set results in the empty set." + (let [empty-set (&;new number;Order)] + (&/= empty-set + (&;intersection empty-set setL)))) + + (test "After substracting a set A from another B, no member of A can be a member of B." + (let [sub (&;difference setR setL)] + (not (list;any? (&;member? sub) (&;to-list setR))))) + + (test "Every member of a set must be identifiable." + (list;every? (&;member? setL) (&;to-list setL))) + )) -- cgit v1.2.3