From ddacd6a4db08a5546222f2b2c49499c16e7ae536 Mon Sep 17 00:00:00 2001
From: Eduardo Julian
Date: Mon, 3 Apr 2017 20:36:25 -0400
Subject: - Priority-queues and sequences can now be empty.

---
 stdlib/source/lux/data/coll/priority-queue.lux    | 135 ++++++-----
 stdlib/source/lux/data/coll/seq.lux               | 260 ++++++++++++++--------
 stdlib/test/test/lux/data/coll/priority-queue.lux |  42 ++--
 stdlib/test/test/lux/data/coll/seq.lux            |  15 +-
 stdlib/test/tests.lux                             |   2 +-
 5 files changed, 269 insertions(+), 185 deletions(-)

(limited to 'stdlib')

diff --git a/stdlib/source/lux/data/coll/priority-queue.lux b/stdlib/source/lux/data/coll/priority-queue.lux
index 9bc65df1d..f02b4de57 100644
--- a/stdlib/source/lux/data/coll/priority-queue.lux
+++ b/stdlib/source/lux/data/coll/priority-queue.lux
@@ -1,86 +1,103 @@
 (;module:
   lux
-  (lux (control eq)
+  (lux (control eq
+                monad)
        (data (coll (tree ["F" finger]))
-             [number])))
+             [number]
+             maybe)))
 
 (type: #export Priority Nat)
 
 (type: #export (Queue a)
-  (F;Fingers Priority a))
+  (Maybe (F;Fingers Priority a)))
 
 (def: max-priority Priority (_lux_proc [ "nat" "max-value"] []))
 (def: min-priority Priority (_lux_proc [ "nat" "min-value"] []))
 
-(def: #export (new priority value)
-  (All [a] (-> Priority a (Queue a)))
-  {#F;monoid number;Max@Monoid<Nat>
-   #F;tree (#F;Leaf priority value)})
+(def: #export empty
+  Queue
+  #;None)
 
 (def: #export (peek queue)
-  (All [a] (-> (Queue a) a))
-  (default (undefined)
-    (F;search (n.= (F;tag queue)) queue)))
+  (All [a] (-> (Queue a) (Maybe a)))
+  (do Monad<Maybe>
+    [fingers queue]
+    (wrap (default (undefined)
+            (F;search (n.= (F;tag fingers)) fingers)))))
 
 (def: #export (size queue)
   (All [a] (-> (Queue a) Nat))
-  (loop [node (get@ #F;tree queue)]
-    (case node
-      (#F;Leaf _ _)
-      +1
+  (case queue
+    #;None
+    +0
 
-      (#F;Branch _ left right)
-      (n.+ (recur left) (recur right)))))
+    (#;Some fingers)
+    (loop [node (get@ #F;tree fingers)]
+      (case node
+        (#F;Leaf _ _)
+        +1
+
+        (#F;Branch _ left right)
+        (n.+ (recur left) (recur right))))))
 
 (def: #export (member? Eq<a> queue member)
   (All [a] (-> (Eq a) (Queue a) a Bool))
-  (loop [node (get@ #F;tree queue)]
-    (case node
-      (#F;Leaf _ reference)
-      (:: Eq<a> = reference member)
+  (case queue
+    #;None
+    false
+
+    (#;Some fingers)
+    (loop [node (get@ #F;tree fingers)]
+      (case node
+        (#F;Leaf _ reference)
+        (:: Eq<a> = reference member)
 
-      (#F;Branch _ left right)
-      (or (recur left)
-          (recur right)))))
+        (#F;Branch _ left right)
+        (or (recur left)
+            (recur right))))))
 
 (def: #export (pop queue)
   (All [a] (-> (Queue a) (Queue a)))
-  (let [highest-priority (F;tag queue)
-        node' (loop [node (get@ #F;tree queue)]
-                (case node
-                  (#F;Leaf priority reference)
-                  (if (n.= highest-priority priority)
-                    #;None
-                    (#;Some node))
-
-                  (#F;Branch priority left right)
-                  (if (n.= highest-priority (F;tag (set@ #F;tree left queue)))
-                    (case (recur left)
-                      #;None
-                      (#;Some right)
-
-                      (#;Some =left)
-                      (|> (F;branch (set@ #F;tree =left queue)
-                                    (set@ #F;tree right queue))
-                          (get@ #F;tree)
-                          #;Some))
-                    (case (recur right)
-                      #;None
-                      (#;Some left)
-
-                      (#;Some =right)
-                      (|> (F;branch (set@ #F;tree left queue)
-                                    (set@ #F;tree =right queue))
-                          (get@ #F;tree)
-                          #;Some))
-                    )))]
-    (case node'
-      #;None
-      queue
-      
-      (#;Some node'')
-      (set@ #F;tree node'' queue))))
+  (do Monad<Maybe>
+    [fingers queue
+     #let [highest-priority (F;tag fingers)]
+     node' (loop [node (get@ #F;tree fingers)]
+             (case node
+               (#F;Leaf priority reference)
+               (if (n.= highest-priority priority)
+                 #;None
+                 (#;Some node))
+
+               (#F;Branch priority left right)
+               (if (n.= highest-priority (F;tag (set@ #F;tree left fingers)))
+                 (case (recur left)
+                   #;None
+                   (#;Some right)
+
+                   (#;Some =left)
+                   (|> (F;branch (set@ #F;tree =left fingers)
+                                 (set@ #F;tree right fingers))
+                       (get@ #F;tree)
+                       #;Some))
+                 (case (recur right)
+                   #;None
+                   (#;Some left)
+
+                   (#;Some =right)
+                   (|> (F;branch (set@ #F;tree left fingers)
+                                 (set@ #F;tree =right fingers))
+                       (get@ #F;tree)
+                       #;Some))
+                 )))]
+    (wrap (set@ #F;tree node' fingers))))
 
 (def: #export (push priority value queue)
   (All [a] (-> Priority a (Queue a) (Queue a)))
-  (F;branch queue (new priority value)))
+  (let [addition {#F;monoid number;Max@Monoid<Nat>
+                  #F;tree (#F;Leaf priority value)}]
+    (case queue
+      #;None
+      (#;Some addition)
+
+      (#;Some fingers)
+      (#;Some (F;branch fingers addition)))))
diff --git a/stdlib/source/lux/data/coll/seq.lux b/stdlib/source/lux/data/coll/seq.lux
index 1912a31a8..0e28d7f91 100644
--- a/stdlib/source/lux/data/coll/seq.lux
+++ b/stdlib/source/lux/data/coll/seq.lux
@@ -14,24 +14,27 @@
               ["s" syntax #+ syntax: Syntax])))
 
 (type: #export (Seq a)
-  (F;Fingers Nat a))
+  (Maybe (F;Fingers Nat a)))
 
 (def: default-size Nat +1)
 
-(def: #export (new value)
-  (All [a] (-> a (Seq a)))
+(def: (new value)
+  (All [a] (-> a (F;Fingers Nat a)))
   {#F;monoid number;Add@Monoid<Nat>
    #F;tree (#F;Leaf default-size value)})
 
 (do-template [<name> <side>]
   [(def: #export (<name> seq)
-     (All [a] (-> (Seq a) a))
-     (case (get@ #F;tree seq)
-       (#F;Leaf tag value)
-       value
-       
-       (#F;Branch tag left right)
-       (<name> (set@ #F;tree <side> seq))))]
+     (All [a] (-> (Seq a) (Maybe a)))
+     (do Monad<Maybe>
+       [fingers seq]
+       (wrap (loop [node (get@ #F;tree fingers)]
+               (case node
+                 (#F;Leaf tag value)
+                 value
+                 
+                 (#F;Branch tag left right)
+                 (recur <side>))))))]
 
   [first left]
   [last right]
@@ -39,34 +42,68 @@
 
 (def: #export (prepend prefix subject)
   (All [a] (-> a (Seq a) (Seq a)))
-  (F;branch (new prefix) subject))
+  (case subject
+    #;None
+    (#;Some (new prefix))
+
+    (#;Some fingers)
+    (#;Some (F;branch (new prefix) fingers))))
 
 (def: #export (append suffix subject)
   (All [a] (-> a (Seq a) (Seq a)))
-  (F;branch subject (new suffix)))
+  (case subject
+    #;None
+    (#;Some (new suffix))
+
+    (#;Some fingers)
+    (#;Some (F;branch fingers (new suffix)))))
+
+(def: #export (concat left right)
+  (All [a] (-> (Seq a) (Seq a) (Seq a)))
+  (case [left right]
+    [_ #;None]
+    left
+    
+    [#;None _]
+    right
+
+    [(#;Some left') (#;Some right')]
+    (#;Some (F;branch left' right'))))
 
 (def: #export (nth idx seq)
   (All [a] (-> Nat (Seq a) (Maybe a)))
-  (F;search (n.> idx) seq))
+  (do Monad<Maybe>
+    [fingers seq]
+    (F;search (n.> idx) fingers)))
 
 (def: #export (size seq)
   (All [a] (-> (Seq a) Nat))
-  (case (get@ #F;tree seq)
-    (^or (#F;Leaf tag value) (#F;Branch tag left right))
-    tag))
+  (case seq
+    #;None
+    +0
+
+    (#;Some fingers)
+    (case (get@ #F;tree fingers)
+      (^or (#F;Leaf tag value) (#F;Branch tag left right))
+      tag)))
 
 (def: #export (to-list seq)
   (All [a] (-> (Seq a) (List a)))
-  (loop [node (get@ #F;tree seq)]
-    (case node
-      (#F;Leaf tag value)
-      (list value)
-      
-      (#F;Branch tag left right)
-      (L/append (recur left) (recur right)))))
+  (case seq
+    #;None
+    (list)
+
+    (#;Some fingers)
+    (loop [node (get@ #F;tree fingers)]
+      (case node
+        (#F;Leaf tag value)
+        (list value)
+        
+        (#F;Branch tag left right)
+        (L/append (recur left) (recur right))))))
 
 (def: #export (from-list xs)
-  (All [a] (-> (List a) (Maybe (Seq a))))
+  (All [a] (-> (List a) (Seq a)))
   (loop [xs xs]
     (do Monad<Maybe>
       [[_ tree] (loop [xs xs]
@@ -92,71 +129,97 @@
 
 (def: #export (reverse seq)
   (All [a] (-> (Seq a) (Seq a)))
-  (|> seq to-list L;reverse from-list (default (undefined))))
+  (do Monad<Maybe>
+    [fingers seq
+     #let [node' (loop [node (get@ #F;tree fingers)]
+                   (case node
+                     (#F;Leaf tag value)
+                     node
+                     
+                     (#F;Branch tag left right)
+                     (#F;Branch tag (recur right) (recur left))))]]
+    (wrap (set@ #F;tree node' fingers))))
 
 (def: #export (member? Eq<a> xs x)
   (All [a] (-> (Eq a) (Seq a) a Bool))
-  (loop [xs (get@ #F;tree xs)]
-    (case xs
-      (#F;Leaf tag reference)
-      (:: Eq<a> = reference x)
+  (case xs
+    #;None
+    false
 
-      (#F;Branch tag left right)
-      (or (recur left)
-          (recur right)))))
+    (#;Some fingers)
+    (loop [xs (get@ #F;tree fingers)]
+      (case xs
+        (#F;Leaf tag reference)
+        (:: Eq<a> = reference x)
 
-(do-template [<name> <op>]
+        (#F;Branch tag left right)
+        (or (recur left)
+            (recur right))))))
+
+(do-template [<name> <op> <default>]
   [(def: #export (<name> pred seq)
      (All [a] (-> (-> a Bool) (Seq a) Bool))
-     (loop [seq (get@ #F;tree seq)]
-       (case seq
-         (#F;Leaf tag reference)
-         (pred reference)
-
-         (#F;Branch tag left right)
-         (<op> (recur left)
-               (recur right)))))]
-
-  [every? and]
-  [any?   or]
+     (case seq
+       #;None
+       <default>
+
+       (#;Some fingers)
+       (loop [seq (get@ #F;tree fingers)]
+         (case seq
+           (#F;Leaf tag reference)
+           (pred reference)
+
+           (#F;Branch tag left right)
+           (<op> (recur left)
+                 (recur right))))))]
+
+  [every? and true]
+  [any?   or  false]
   )
 
 (def: #export (sort < seq)
   (All [a] (-> (-> a a Bool) (Seq a) (Seq a)))
-  (|> seq to-list (L;sort <) from-list (default (undefined))))
+  (|> seq to-list (L;sort <) from-list))
 
 (def: #export (find pred seq)
   {#;doc "Returns the first value in the sequence for which the predicate is true."}
   (All [a]
     (-> (-> a Bool) (Seq a) (Maybe a)))
-  (loop [seq (get@ #F;tree seq)]
-    (case seq
-      (#F;Leaf tag value)
-      (if (pred value)
-        (#;Some value)
-        #;None)
+  (do Monad<Maybe>
+    [fingers seq]
+    (loop [seq (get@ #F;tree fingers)]
+      (case seq
+        (#F;Leaf tag value)
+        (if (pred value)
+          (#;Some value)
+          #;None)
 
-      (#F;Branch tag left right)
-      
-      (case (recur left)
-        #;None
-        (recur right)
+        (#F;Branch tag left right)
+        
+        (case (recur left)
+          #;None
+          (recur right)
 
-        output
-        output))))
+          output
+          output)))))
 
 (struct: #export _ (Fold Seq)
   (def: (fold f init seq)
-    (loop [init init
-           node (get@ #F;tree seq)]
-      (case node
-        (#F;Leaf tag value)
-        (f value init)
-        
-        (#F;Branch tag left right)
-        (recur (recur init left)
-               right)
-        ))))
+    (case seq
+      #;None
+      init
+
+      (#;Some fingers)
+      (loop [init init
+             node (get@ #F;tree fingers)]
+        (case node
+          (#F;Leaf tag value)
+          (f value init)
+          
+          (#F;Branch tag left right)
+          (recur (recur init left)
+                 right)
+          )))))
 
 (struct: #export (Eq<Seq> Eq<a>)
   (All [a] (-> (Eq a) (Eq (Seq a))))
@@ -167,41 +230,50 @@
 
 (struct: #export _ (Functor Seq)
   (def: (map f ma)
-    {#F;monoid number;Add@Monoid<Nat>
-     #F;tree (loop [tree (get@ #F;tree ma)]
-               (case tree
-                 (#F;Leaf tag value)
-                 (#F;Leaf tag (f value))
-                 
-                 (#F;Branch tag left right)
-                 (#F;Branch tag (recur left) (recur right))))}))
+    (do Monad<Maybe>
+      [fingers ma]
+      (wrap {#F;monoid number;Add@Monoid<Nat>
+             #F;tree (loop [tree (get@ #F;tree fingers)]
+                       (case tree
+                         (#F;Leaf tag value)
+                         (#F;Leaf tag (f value))
+                         
+                         (#F;Branch tag left right)
+                         (#F;Branch tag (recur left) (recur right))))}))))
 
 (struct: #export _ (Applicative Seq)
   (def: functor Functor<Seq>)
 
-  (def: wrap new)
+  (def: wrap (|>. new #;Some))
 
   (def: (apply ff fa)
-    (case (get@ #F;tree ff)
-      (#F;Leaf tag f)
-      (:: Functor<Seq> map f fa)
+    (do Monad<Maybe>
+      [ff' ff]
+      (case (get@ #F;tree ff')
+        (#F;Leaf tag f)
+        (:: Functor<Seq> map f fa)
 
-      (#F;Branch tag lfs rfs)
-      (F;branch (apply (set@ #F;tree lfs ff) fa)
-                (apply (set@ #F;tree rfs ff) fa)))))
+        (#F;Branch tag lfs rfs)
+        (do @
+          [lefts (apply (#;Some (set@ #F;tree lfs ff')) fa)
+           rights (apply (#;Some (set@ #F;tree rfs ff')) fa)]
+          (wrap (F;branch lefts rights)))))))
 
 (struct: #export _ (Monad Seq)
   (def: applicative Applicative<Seq>)
 
   (def: (join ffa)
-    (case (get@ #F;tree ffa)
-      (#F;Leaf tag fa)
-      fa
-      
-      (#F;Branch tag left right)
-      (F;branch (join (set@ #F;tree left ffa))
-                (join (set@ #F;tree right ffa))))))
-
-(syntax: #export (seq [elems (s;many s;any)])
-  (wrap (list (` (default (undefined)
-                   (;;from-list (list (~@ elems))))))))
+    (do Monad<Maybe>
+      [ffa' ffa]
+      (case (get@ #F;tree ffa')
+        (#F;Leaf tag fa)
+        fa
+        
+        (#F;Branch tag left right)
+        (do @
+          [left' (join (#;Some (set@ #F;tree left ffa')))
+           right' (join (#;Some (set@ #F;tree right ffa')))]
+          (wrap (F;branch left' right')))))))
+
+(syntax: #export (seq [elems (s;some s;any)])
+  (wrap (list (` (;;from-list (list (~@ elems)))))))
diff --git a/stdlib/test/test/lux/data/coll/priority-queue.lux b/stdlib/test/test/lux/data/coll/priority-queue.lux
index 5c53edfb1..de885f1ee 100644
--- a/stdlib/test/test/lux/data/coll/priority-queue.lux
+++ b/stdlib/test/test/lux/data/coll/priority-queue.lux
@@ -12,30 +12,18 @@
   (-> Nat (R;Random (&;Queue Nat)))
   (do R;Monad<Random>
     [inputs (R;list size R;nat)]
-    (case inputs
-      (#;Cons head tail)
-      (loop [head head
-             tail tail]
-        (do @
-          [priority R;nat]
-          (case tail
-            (#;Cons head' tail')
-            (do @
-              [=tail (recur head' tail')]
-              (wrap (&;push priority head =tail)))
-
-            _
-            (wrap (&;new priority head)))))
-
-      _
-      (undefined))))
+    (foldM @ (lambda [head tail]
+               (do @
+                 [priority R;nat]
+                 (wrap (&;push priority head tail))))
+           &;empty
+           inputs)))
 
 (test: "Queues"
-  [size (|> R;nat
-            (:: @ map (|>. (n.% +100) (n.max +1))))
+  [size (|> R;nat (:: @ map (n.% +100)))
    sample (gen-queue size)
    non-member-priority R;nat
-   non-member R;nat]
+   non-member (|> R;nat (R;filter (|>. (&;member? number;Eq<Nat> sample) not)))]
   ($_ seq
       (assert "I can query the size of a queue (and empty queues have size 0)."
               (n.= size (&;size sample)))
@@ -43,14 +31,20 @@
       (assert "Enqueueing and dequeing affects the size of queues."
               (and (n.= (n.inc size)
                         (&;size (&;push non-member-priority non-member sample)))
-                   (or (n.= +1 (&;size sample))
+                   (or (n.= +0 (&;size sample))
                        (n.= (n.dec size)
                             (&;size (&;pop sample))))))
 
       (assert "I can query whether an element belongs to a queue."
               (and (and (not (&;member? number;Eq<Nat> sample non-member))
-                        (&;member? number;Eq<Nat> (&;push non-member-priority non-member sample)
+                        (&;member? number;Eq<Nat>
+                                   (&;push non-member-priority non-member sample)
                                    non-member))
-                   (and (&;member? number;Eq<Nat> sample (&;peek sample))
-                        (not (&;member? number;Eq<Nat> (&;pop sample) (&;peek sample))))))
+                   (or (n.= +0 (&;size sample))
+                       (and (&;member? number;Eq<Nat>
+                                       sample
+                                       (default (undefined) (&;peek sample)))
+                            (not (&;member? number;Eq<Nat>
+                                            (&;pop sample)
+                                            (default (undefined) (&;peek sample))))))))
       ))
diff --git a/stdlib/test/test/lux/data/coll/seq.lux b/stdlib/test/test/lux/data/coll/seq.lux
index e62f36854..5fe3a5af1 100644
--- a/stdlib/test/test/lux/data/coll/seq.lux
+++ b/stdlib/test/test/lux/data/coll/seq.lux
@@ -8,7 +8,8 @@
              [text "Text/" Monoid<Text>]
              [number]
              [bool]
-             [product])
+             [product]
+             maybe)
        ["R" math/random]
        pipe)
   lux/test)
@@ -22,13 +23,13 @@
   [size bounded-size
    idx (:: @ map (n.% size) R;nat)
    sample (|> (R;list size R;nat)
-              (:: @ map (|>. &;from-list (default (undefined)))))
+              (:: @ map &;from-list))
    extra R;nat
    #let [(^open "&/") (&;Eq<Seq> number;Eq<Nat>)]]
   ($_ seq
       (assert "Can convert to/from list."
               (|> sample
-                  &;to-list &;from-list (default (undefined))
+                  &;to-list &;from-list
                   (&/= sample)))
       
       (assert "The size function should correctly portray the size of the seq."
@@ -75,7 +76,7 @@
 (test: "Seqs: Part 2"
   [size bounded-size
    sample (|> (R;list size R;nat)
-              (:: @ map (|>. &;from-list (default (undefined)))))
+              (:: @ map &;from-list))
    #let [(^open "&/") (&;Eq<Seq> number;Eq<Nat>)
          (^open "&/") &;Functor<Seq>]]
   ($_ seq
@@ -98,10 +99,10 @@
   [size bounded-size
    idx (:: @ map (n.% size) R;nat)
    sample (|> (R;list size R;nat)
-              (:: @ map (|>. &;from-list (default (undefined)))))
+              (:: @ map &;from-list))
    other-size bounded-size
    other-sample (|> (R;list other-size R;nat)
-                    (:: @ map (|>. &;from-list (default (undefined)))))
+                    (:: @ map &;from-list))
    elem R;nat
    #let [(^open "&/") (&;Eq<Seq> number;Eq<Nat>)
          (^open "&/") &;Monad<Seq>]]
@@ -112,7 +113,7 @@
                         (&/apply (&/wrap n.inc) sample))))
 
       (assert "Seq concatenation is a monad."
-              (&/= (F;branch sample other-sample)
+              (&/= (&;concat sample other-sample)
                    (&/join (&;seq sample other-sample))))
 
       (assert "You can find any value that satisfies some criterium, if such values exist in the seq."
diff --git a/stdlib/test/tests.lux b/stdlib/test/tests.lux
index ca0079092..c773b3f17 100644
--- a/stdlib/test/tests.lux
+++ b/stdlib/test/tests.lux
@@ -46,7 +46,7 @@
                          [set]
                          [ordered]
                          [stack]
-                         [vector]
+                         ## [vector]
                          (tree [rose]
                                [zipper])
                          ["_;" seq]
-- 
cgit v1.2.3