aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--stdlib/source/lux/data/coll/ordered/dict.lux (renamed from stdlib/source/lux/data/coll/ordered.lux)387
-rw-r--r--stdlib/source/lux/data/coll/ordered/set.lux86
-rw-r--r--stdlib/test/test/lux/data/coll/ordered/dict.lux86
-rw-r--r--stdlib/test/test/lux/data/coll/ordered/set.lux (renamed from stdlib/test/test/lux/data/coll/ordered.lux)47
4 files changed, 436 insertions, 170 deletions
diff --git a/stdlib/source/lux/data/coll/ordered.lux b/stdlib/source/lux/data/coll/ordered/dict.lux
index 5a9794f85..714f14b5d 100644
--- a/stdlib/source/lux/data/coll/ordered.lux
+++ b/stdlib/source/lux/data/coll/ordered/dict.lux
@@ -3,7 +3,7 @@
(lux (control monad
eq
[order #+ Order])
- (data (coll [list "" Monad<List> "L/" Monoid<List> Fold<List>])
+ (data (coll [list "L/" Monad<List> Monoid<List> Fold<List>])
["p" product]
["M" maybe #+ Functor<Maybe>])
[macro]
@@ -14,16 +14,18 @@
(type: Color #Red #Black)
-(type: (Node a)
+(type: (Node k v)
{#color Color
- #value a
- #left (Maybe (Node a))
- #right (Maybe (Node a))})
+ #key k
+ #value v
+ #left (Maybe (Node k v))
+ #right (Maybe (Node k v))})
(do-template [<create> <color>]
- [(def: (<create> value left right)
- (All [a] (-> a (Maybe (Node a)) (Maybe (Node a)) (Node a)))
+ [(def: (<create> key value left right)
+ (All [k v] (-> k v (Maybe (Node k v)) (Maybe (Node k v)) (Node k v)))
{#color <color>
+ #key key
#value value
#left left
#right right})]
@@ -32,47 +34,82 @@
[black #Black]
)
-(type: #export (Set a)
- {#order (Order a)
- #root (Maybe (Node a))})
+(type: #export (Dict k v)
+ {#order (Order k)
+ #root (Maybe (Node k v))})
-(def: #export (new Order<a>)
- (All [a] (-> (Order a) (Set a)))
- {#order Order<a>
+(def: #export (new Order<k>)
+ (All [k v] (-> (Order k) (Dict k v)))
+ {#order Order<k>
#root #;None})
-(def: #export (member? tree elem)
- (All [a] (-> (Set a) a Bool))
- (let [(^open "T/") (get@ #order tree)]
- (loop [node (get@ #root tree)]
+## 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)
- (or (T/= elem (get@ #value node))
- (recur (get@ #left node))
- (recur (get@ #right 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 [<name> <side>]
- [(def: #export (<name> tree)
- (All [a] (-> (Set a) (Maybe a)))
- (loop [node (get@ #root tree)]
- (case node
- #;None
- #;None
+ [(def: #export (<name> dict)
+ (All [k v] (-> (Dict k v) (Maybe v)))
+ (case (get@ #root dict)
+ #;None
+ #;None
- (#;Some node)
- (recur (get@ <side> node)))))]
+ (#;Some node)
+ (loop [node node]
+ (case (get@ <side> node)
+ #;None
+ (#;Some (get@ #value node))
+
+ (#;Some side)
+ (recur side)))))]
[min #left]
[max #right]
)
(do-template [<name> <op>]
- [(def: #export (<name> tree)
- (All [a] (-> (Set a) Nat))
- (loop [node (get@ #root tree)]
+ [(def: #export (<name> dict)
+ (All [k v] (-> (Dict k v) Nat))
+ (loop [node (get@ #root dict)]
(case node
#;None
+0
@@ -87,7 +124,7 @@
(do-template [<name> <other-color> <self-color> <no-change>]
[(def: (<name> self)
- (All [a] (-> (Node a) (Node a)))
+ (All [k v] (-> (Node k v) (Node k v)))
(case (get@ #color self)
<other-color>
(set@ #color <self-color> self)
@@ -101,9 +138,10 @@
)
(def: (balance-left-add parent self)
- (All [a] (-> (Node a) (Node a) (Node a)))
+ (All [k v] (-> (Node k v) (Node k v) (Node k v)))
(with-expansions
- [<default-behavior> (as-is (black (get@ #value parent)
+ [<default-behavior> (as-is (black (get@ #key parent)
+ (get@ #value parent)
(#;Some self)
(get@ #right parent)))]
(case (get@ #color self)
@@ -111,9 +149,11 @@
(case (get@ #left self)
(^multi (#;Some left)
[(get@ #color left) #Red])
- (red (get@ #value self)
+ (red (get@ #key self)
+ (get@ #value self)
(#;Some (blacken left))
- (#;Some (black (get@ #value parent)
+ (#;Some (black (get@ #key parent)
+ (get@ #value parent)
(get@ #right self)
(get@ #right parent))))
@@ -121,11 +161,14 @@
(case (get@ #right self)
(^multi (#;Some right)
[(get@ #color right) #Red])
- (red (get@ #value right)
- (#;Some (black (get@ #value self)
+ (red (get@ #key right)
+ (get@ #value right)
+ (#;Some (black (get@ #key self)
+ (get@ #value self)
(get@ #left self)
(get@ #left right)))
- (#;Some (black (get@ #value parent)
+ (#;Some (black (get@ #key parent)
+ (get@ #value parent)
(get@ #right right)
(get@ #right parent))))
@@ -137,9 +180,10 @@
)))
(def: (balance-right-add parent self)
- (All [a] (-> (Node a) (Node a) (Node a)))
+ (All [k v] (-> (Node k v) (Node k v) (Node k v)))
(with-expansions
- [<default-behavior> (as-is (black (get@ #value parent)
+ [<default-behavior> (as-is (black (get@ #key parent)
+ (get@ #value parent)
(get@ #left parent)
(#;Some self)))]
(case (get@ #color self)
@@ -147,8 +191,10 @@
(case (get@ #right self)
(^multi (#;Some right)
[(get@ #color right) #Red])
- (red (get@ #value self)
- (#;Some (black (get@ #value parent)
+ (red (get@ #key self)
+ (get@ #value self)
+ (#;Some (black (get@ #key parent)
+ (get@ #value parent)
(get@ #left parent)
(get@ #left self)))
(#;Some (blacken right)))
@@ -157,11 +203,14 @@
(case (get@ #left self)
(^multi (#;Some left)
[(get@ #color left) #Red])
- (red (get@ #value left)
- (#;Some (black (get@ #value parent)
+ (red (get@ #key left)
+ (get@ #value left)
+ (#;Some (black (get@ #key parent)
+ (get@ #value parent)
(get@ #left parent)
(get@ #left left)))
- (#;Some (black (get@ #value self)
+ (#;Some (black (get@ #key self)
+ (get@ #value self)
(get@ #right left)
(get@ #right self))))
@@ -173,38 +222,38 @@
)))
(def: (add-left addition center)
- (All [a] (-> (Node a) (Node a) (Node a)))
+ (All [k v] (-> (Node k v) (Node k v) (Node k v)))
(case (get@ #color center)
#Red
- (red (get@ #value center) (#;Some addition) (get@ #right center))
+ (red (get@ #key center) (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)))
+ (All [k v] (-> (Node k v) (Node k v) (Node k v)))
(case (get@ #color center)
#Red
- (red (get@ #value center) (get@ #left center) (#;Some addition))
+ (red (get@ #key center) (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)]
+(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 elem #;None #;None))
+ (#;Some (red key value #;None #;None))
(#;Some root)
- (let [reference (get@ #value root)]
+ (let [reference (get@ #key root)]
(with-expansions
[<sides> (do-template [<comp> <tag> <add>]
- [(<comp> reference elem)
+ [(<comp> reference key)
(let [side-root (get@ <tag> root)
outcome (recur side-root)]
(if (is side-root outcome)
@@ -217,82 +266,90 @@
)]
(cond <sides>
- ## (T/= reference elem)
+ ## (T/= reference key)
?root
)))
))]
- (set@ #root root' tree)))
+ (set@ #root root' dict)))
-(def: (left-balance value ?left ?right)
- (All [a] (-> a (Maybe (Node a)) (Maybe (Node a)) (Node a)))
+(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@ #value left)
+ (red (get@ #key left)
+ (get@ #value left)
(#;Some (blacken left.left))
- (#;Some (black value (get@ #right left) ?right)))
+ (#;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@ #value left.right)
- (#;Some (black (get@ #value left)
+ (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 value
+ (#;Some (black key value
(get@ #right left.right)
?right)))
_
- (black value ?left ?right)))
+ (black key value ?left ?right)))
-(def: (right-balance value ?left ?right)
- (All [a] (-> a (Maybe (Node a)) (Maybe (Node a)) (Node a)))
+(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@ #value right)
- (#;Some (black value ?left (get@ #left right)))
+ (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@ #value right.left)
- (#;Some (black value ?left (get@ #left right.left)))
- (#;Some (black (get@ #value right)
+ (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 value ?left ?right)))
+ (black key value ?left ?right)))
-(def: (balance-left-remove value ?left ?right)
- (All [a] (-> a (Maybe (Node a)) (Maybe (Node a)) (Node a)))
+(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 value (#;Some (blacken left)) ?right)
+ (red key value (#;Some (blacken left)) ?right)
_
(case ?right
(^multi (#;Some right)
[(get@ #color right) #Black])
- (right-balance value ?left (#;Some (redden right)))
+ (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@ #value right.left)
- (#;Some (black value ?left (get@ #left right.left)))
- (#;Some (right-balance (get@ #value right)
+ (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<Maybe> map redden (get@ #right right)))))
@@ -300,35 +357,37 @@
(error! error-message))
))
-(def: (balance-right-remove value ?left ?right)
- (All [a] (-> a (Maybe (Node a)) (Maybe (Node a)) (Node a)))
+(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 value ?left (#;Some (blacken right)))
+ (red key value ?left (#;Some (blacken right)))
_
(case ?left
(^multi (#;Some left)
[(get@ #color left) #Black])
- (left-balance value (#;Some (redden left)) ?right)
+ (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@ #value left.right)
- (#;Some (left-balance (get@ #value left)
+ (red (get@ #key left.right)
+ (get@ #value left.right)
+ (#;Some (left-balance (get@ #key left)
+ (get@ #value left)
(:: Functor<Maybe> map redden (get@ #left left))
(get@ #left left.right)))
- (#;Some (black value (get@ #right left.right) ?right)))
+ (#;Some (black key value (get@ #right left.right) ?right)))
_
(error! error-message)
)))
(def: (prepend ?left ?right)
- (All [a] (-> (Maybe (Node a)) (Maybe (Node a)) (Maybe (Node a))))
+ (All [k v] (-> (Maybe (Node k v)) (Maybe (Node k v)) (Maybe (Node k v))))
(case [?left ?right]
[#;None _]
?right
@@ -343,29 +402,36 @@
[fused (prepend (get@ #right left) (get@ #right right))]
(case (get@ #color fused)
#Red
- (wrap (red (get@ #value fused)
- (#;Some (red (get@ #value left)
+ (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@ #value right)
+ (#;Some (red (get@ #key right)
+ (get@ #value right)
(get@ #right fused)
(get@ #right right)))))
#Black
- (wrap (red (get@ #value left)
+ (wrap (red (get@ #key left)
+ (get@ #value left)
(get@ #left left)
- (#;Some (red (get@ #value right)
+ (#;Some (red (get@ #key right)
+ (get@ #value right)
(#;Some fused)
(get@ #right right)))))))
[#Red #Black]
- (#;Some (red (get@ #value left)
+ (#;Some (red (get@ #key left)
+ (get@ #value left)
(get@ #left left)
(prepend (get@ #right left)
?right)))
[#Black #Red]
- (#;Some (red (get@ #value right)
+ (#;Some (red (get@ #key right)
+ (get@ #value right)
(prepend ?left
(get@ #left right))
(get@ #right right)))
@@ -375,38 +441,44 @@
[fused (prepend (get@ #right left) (get@ #left right))]
(case (get@ #color fused)
#Red
- (wrap (red (get@ #value fused)
- (#;Some (black (get@ #value left)
+ (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@ #value right)
+ (#;Some (black (get@ #key right)
+ (get@ #value right)
(get@ #right fused)
(get@ #right right)))))
#Black
- (wrap (balance-left-remove (get@ #value left)
+ (wrap (balance-left-remove (get@ #key left)
+ (get@ #value left)
(get@ #left left)
- (#;Some (black (get@ #value right)
+ (#;Some (black (get@ #key right)
+ (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)]
+(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-val (get@ #value root)]
- (if (T/= root-val elem)
+ (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-val elem)]
+ (let [go-left? (T/< root-key key)]
(case (recur (if go-left?
(get@ #left root)
(get@ #right root)))
@@ -418,20 +490,20 @@
(case (get@ #left root)
(^multi (#;Some left)
[(get@ #color left) #Black])
- [(#;Some (balance-left-remove root-val side-outcome (get@ #right root)))
+ [(#;Some (balance-left-remove root-key root-val side-outcome (get@ #right root)))
false]
_
- [(#;Some (red root-val side-outcome (get@ #right root)))
+ [(#;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-val (get@ #left root) side-outcome))
+ [(#;Some (balance-right-remove root-key root-val (get@ #left root) side-outcome))
false]
_
- [(#;Some (red root-val (get@ #left root) side-outcome))
+ [(#;Some (red root-key root-val (get@ #left root) side-outcome))
false])
)))
))
@@ -439,55 +511,52 @@
(case ?root
#;None
(if found?
- (set@ #root ?root tree)
- tree)
+ (set@ #root ?root dict)
+ dict)
(#;Some root)
- (set@ #root (#;Some (blacken root)) tree)
+ (set@ #root (#;Some (blacken root)) dict)
)))
-(def: #export (from-list Order<a> list)
- (All [a] (-> (Order a) (List a) (Set a)))
- (L/fold add (new Order<a>) list))
+(def: #export (from-list Order<l> list)
+ (All [k v] (-> (Order k) (List [k v]) (Dict k v)))
+ (L/fold (function [[key value] dict]
+ (put key value dict))
+ (new Order<l>)
+ list))
+
+(do-template [<name> <type> <output>]
+ [(def: #export (<name> dict)
+ (All [k v] (-> (Dict k v) (List <type>)))
+ (loop [node (get@ #root dict)]
+ (case node
+ #;None
+ (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<Set> (All [a] (Eq (Set a)))
+ (#;Some node')
+ ($_ L/append
+ (recur (get@ #left node'))
+ (list <output>)
+ (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<Dict> Eq<v>) (All [k v] (-> (Eq v) (Eq (Dict k v))))
(def: (= reference sample)
- (:: (list;Eq<List> (:: sample eq))
- = (to-list reference) (to-list sample))))
+ (let [Eq<k> (:: 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<k> = keyR keyS)
+ (:: Eq<v> = 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<List> "L/" Monoid<List> Fold<List>]
+ (ordered ["d" dict]))
+ ["p" product]
+ ["M" maybe #+ Functor<Maybe>])
+ [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 [<name> <alias>]
+ [(def: #export (<name> set)
+ (All [a] (-> (Set a) (Maybe a)))
+ (<alias> set))]
+
+ [min d;min]
+ [max d;max]
+ )
+
+(do-template [<name> <alias>]
+ [(def: #export (<name> set)
+ (All [a] (-> (Set a) Nat))
+ (<alias> 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<a> list)
+ (All [a] (-> (Order a) (List a) (Set a)))
+ (L/fold add (new Order<a>) 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<Set> (All [a] (Eq (Set a)))
+ (def: (= reference sample)
+ (:: (list;Eq<List> (:: sample eq))
+ = (to-list reference) (to-list sample))))
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<List>]))
+ ["r" math/random])
+ lux/test)
+
+(context: "Dict"
+ [size (|> r;nat (:: @ map (n.% +100)))
+ keys (r;set number;Hash<Nat> size r;nat)
+ values (r;set number;Hash<Nat> 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<Nat> pairs)
+ sorted-pairs (list;sort (function [[left _] [right _]]
+ (n.< left right))
+ pairs)
+ sorted-values (L/map product;right sorted-pairs)
+ (^open "&/") (&;Eq<Dict> number;Eq<Nat>)]]
+ ($_ 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<Nat>)
+ (&/= sample)))
+
+ (test "Order is preserved."
+ (let [(^open "L/") (list;Eq<List> (: (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.lux b/stdlib/test/test/lux/data/coll/ordered/set.lux
index 0ee02dea6..40b448f1e 100644
--- a/stdlib/test/test/lux/data/coll/ordered.lux
+++ b/stdlib/test/test/lux/data/coll/ordered/set.lux
@@ -2,31 +2,56 @@
lux
(lux [io]
(control monad)
- (data (coll ["&" ordered]
- ["S" set]
+ (data (coll (ordered ["&" set])
+ ["s" set]
[list "" Fold<List>])
[number]
text/format)
- ["R" math/random])
+ ["r" math/random])
lux/test)
(def: gen-nat
- (R;Random Nat)
- (|> R;nat
- (:: R;Monad<Random> map (n.% +100))))
+ (r;Random Nat)
+ (|> r;nat
+ (:: r;Monad<Random> map (n.% +100))))
(context: "Sets"
[sizeL gen-nat
sizeR gen-nat
- setL (|> (R;set number;Hash<Nat> sizeL gen-nat)
- (:: @ map (|>. S;to-list (&;from-list number;Order<Nat>))))
- setR (|> (R;set number;Hash<Nat> sizeR gen-nat)
- (:: @ map (|>. S;to-list (&;from-list number;Order<Nat>))))
- #let [(^open "&/") &;Eq<Set>]]
+ listL (|> (r;set number;Hash<Nat> sizeL gen-nat) (:: @ map s;to-list))
+ listR (|> (r;set number;Hash<Nat> sizeR gen-nat) (:: @ map s;to-list))
+ #let [(^open "&/") &;Eq<Set>
+ setL (&;from-list number;Order<Nat> listL)
+ setR (&;from-list number;Order<Nat> 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<Nat>)
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-09 20:01:48 +0000