- Renamed lux/data/coll/ordered to lux/data/coll/ordered/set.

- Created ordered dictionary implementation, and based the set implementation upon it.

2 files changed, 314 insertions, 159 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))))