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 ++++ 3 files changed, 648 insertions(+), 493 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 (limited to 'stdlib/source') 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)))) -- cgit v1.2.3