- Implemented finger-trees.

- Implemented random-access sequences and priority-queues on top of finger-trees.

9 files changed, 540 insertions, 6 deletions

diff --git a/stdlib/source/lux/data/coll/priority-queue.lux b/stdlib/source/lux/data/coll/priority-queue.lux
new file mode 100644
index 000000000..9bc65df1d
--- /dev/null
+++ b/stdlib/source/lux/data/coll/priority-queue.lux
@@ -0,0 +1,86 @@
+(;module:
+  lux
+  (lux (control eq)
+       (data (coll (tree ["F" finger]))
+             [number])))
+
+(type: #export Priority Nat)
+
+(type: #export (Queue a)
+  (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 (peek queue)
+  (All [a] (-> (Queue a) a))
+  (default (undefined)
+    (F;search (n.= (F;tag queue)) queue)))
+
+(def: #export (size queue)
+  (All [a] (-> (Queue a) Nat))
+  (loop [node (get@ #F;tree queue)]
+    (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)
+
+      (#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))))
+
+(def: #export (push priority value queue)
+  (All [a] (-> Priority a (Queue a) (Queue a)))
+  (F;branch queue (new priority value)))
diff --git a/stdlib/source/lux/data/coll/queue.lux b/stdlib/source/lux/data/coll/queue.lux
index 5cef04fa7..03d40b020 100644
--- a/stdlib/source/lux/data/coll/queue.lux
+++ b/stdlib/source/lux/data/coll/queue.lux
@@ -38,11 +38,11 @@
   (All [a] (-> (Queue a) Bool))
   (|>. (get@ [#front]) list;empty?))
 
-(def: #export (member? a/Eq queue member)
+(def: #export (member? Eq<a> queue member)
   (All [a] (-> (Eq a) (Queue a) a Bool))
   (let [(^slots [#front #rear]) queue]
-    (or (list;member? a/Eq front member)
-        (list;member? a/Eq rear member))))
+    (or (list;member? Eq<a> front member)
+        (list;member? Eq<a> rear member))))
 
 (def: #export (pop queue)
   (All [a] (-> (Queue a) (Queue a)))
diff --git a/stdlib/source/lux/data/coll/seq.lux b/stdlib/source/lux/data/coll/seq.lux
new file mode 100644
index 000000000..0cf7029ea
--- /dev/null
+++ b/stdlib/source/lux/data/coll/seq.lux
@@ -0,0 +1,208 @@
+(;module:
+  lux
+  (lux (control functor
+                applicative
+                monad
+                eq
+                [ord #+ Ord]
+                fold)
+       (data (coll ["L" list "L/" Monoid<List> Fold<List>]
+                   (tree ["F" finger]))
+             [number]
+             maybe)
+       [compiler]
+       (macro [ast]
+              ["s" syntax #+ syntax: Syntax])))
+
+(type: #export (Seq a)
+  (F;Fingers Nat a))
+
+(def: default-size Nat +1)
+
+(def: #export (new value)
+  (All [a] (-> a (Seq 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))))]
+
+  [first left]
+  [last right]
+  )
+
+(def: #export (prepend prefix subject)
+  (All [a] (-> a (Seq a) (Seq a)))
+  (F;branch (new prefix) subject))
+
+(def: #export (append suffix subject)
+  (All [a] (-> a (Seq a) (Seq a)))
+  (F;branch subject (new suffix)))
+
+(def: #export (nth idx seq)
+  (All [a] (-> Nat (Seq a) (Maybe a)))
+  (F;search (n.> idx) seq))
+
+(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))
+
+(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)))))
+
+(def: #export (from-list xs)
+  (All [a] (-> (List a) (Maybe (Seq a))))
+  (loop [xs xs]
+    (do Monad<Maybe>
+      [[_ tree] (loop [xs xs]
+                  (case xs
+                    #;Nil
+                    #;None
+
+                    (#;Cons x #;Nil)
+                    (wrap [default-size
+                           (#F;Leaf default-size x)])
+
+                    (#;Cons x xs')
+                    (do @
+                      [[sub-size right] (recur xs')
+                       #let [branch-size (n.+ default-size sub-size)]]
+                      (wrap [branch-size
+                             (#F;Branch branch-size
+                                        (#F;Leaf default-size x)
+                                        right)]))
+                    ))]
+      (wrap {#F;monoid number;Add@Monoid<Nat>
+             #F;tree tree}))))
+
+(def: #export (reverse seq)
+  (All [a] (-> (Seq a) (Seq a)))
+  (|> seq to-list L;reverse from-list (default (undefined))))
+
+(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)
+
+      (#F;Branch tag left right)
+      (or (recur left)
+          (recur right)))))
+
+(do-template [<name> <op>]
+  [(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]
+  )
+
+(def: #export (sort < seq)
+  (All [a] (-> (-> a a Bool) (Seq a) (Seq a)))
+  (|> seq to-list (L;sort <) from-list (default (undefined))))
+
+(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)
+
+      (#F;Branch tag left right)
+      
+      (case (recur left)
+        #;None
+        (recur right)
+
+        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)
+        ))))
+
+(struct: #export (Eq<Seq> Eq<a>)
+  (All [a] (-> (Eq a) (Eq (Seq a))))
+  (def: (= xs ys)
+    (:: (L;Eq<List> Eq<a>) =
+        (to-list xs)
+        (to-list ys))))
+
+(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))))}))
+
+(struct: #export _ (Applicative Seq)
+  (def: functor Functor<Seq>)
+
+  (def: wrap new)
+
+  (def: (apply ff fa)
+    (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)))))
+
+(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))))))))
diff --git a/stdlib/source/lux/data/coll/tree/finger.lux b/stdlib/source/lux/data/coll/tree/finger.lux
new file mode 100644
index 000000000..936b8cb89
--- /dev/null
+++ b/stdlib/source/lux/data/coll/tree/finger.lux
@@ -0,0 +1,54 @@
+(;module:
+  lux
+  (lux (control monoid
+                [ord #+ Ord])
+       (data text/format)))
+
+(type: #export (Node m a)
+  (#Leaf m a)
+  (#Branch m (Node m a) (Node m a)))
+
+(type: #export (Fingers m a)
+  {#monoid (Monoid m)
+   #tree (Node m a)})
+
+(def: #export (tag fingers)
+  (All [m a] (-> (Fingers m a) m))
+  (case (get@ #tree fingers)
+    (^or (#Leaf tag _) (#Branch tag _ _))
+    tag))
+
+(def: #export (value fingers)
+  (All [m a] (-> (Fingers m a) a))
+  (case (get@ #tree fingers)
+    (#Leaf tag value)
+    value
+
+    (#Branch tag left right)
+    (value (set@ #tree left fingers))))
+
+(def: #export (branch left right)
+  (All [m a] (-> (Fingers m a) (Fingers m a) (Fingers m a)))
+  (let [Monoid<m> (get@ #monoid right)]
+    {#monoid Monoid<m>
+     #tree (#Branch (:: Monoid<m> append (tag left) (tag right))
+                    (get@ #tree left)
+                    (get@ #tree right))}))
+
+(def: #export (search pred fingers)
+  (All [m a] (-> (-> m Bool) (Fingers m a) (Maybe a)))
+  (if (pred (tag fingers))
+    (let [(^open "tag/") (get@ #monoid fingers)]
+      (loop [_tag tag/unit
+             _node (get@ #tree fingers)]
+        (case _node
+          (#Leaf _ value)
+          (#;Some value)
+
+          (#Branch _ left right)
+          (let [shifted-tag (tag/append _tag
+                                        (tag (set@ #tree left fingers)))]
+            (if (pred shifted-tag)
+              (recur _tag left)
+              (recur shifted-tag right))))))
+    #;None))
diff --git a/stdlib/source/lux/data/number.lux b/stdlib/source/lux/data/number.lux
index 8c1c021b4..c90abf76d 100644
--- a/stdlib/source/lux/data/number.lux
+++ b/stdlib/source/lux/data/number.lux
@@ -111,7 +111,7 @@
 (do-template [<name> <type> <unit> <append>]
   [(struct: #export <name> (Monoid <type>)
      (def: unit <unit>)
-     (def: (append x y) (<append> x y)))]
+     (def: append <append>))]
 
   [ Add@Monoid<Nat>  Nat +0                         n.+]
   [ Mul@Monoid<Nat>  Nat +1                         n.*]
diff --git a/stdlib/test/test/lux/data/coll/list.lux b/stdlib/test/test/lux/data/coll/list.lux
index e1705291a..fe381340d 100644
--- a/stdlib/test/test/lux/data/coll/list.lux
+++ b/stdlib/test/test/lux/data/coll/list.lux
@@ -55,7 +55,7 @@
                      (&;empty? (&;filter (bool;complement n.even?) sample)))
                 (&;any? (bool;complement n.even?) sample)))
 
-      (assert "Any element of the list can be considered it's member."
+      (assert "Any element of the list can be considered its member."
               (let [elem (default (undefined)
                            (&;nth idx sample))]
                 (&;member? number;Eq<Nat> sample elem)))
diff --git a/stdlib/test/test/lux/data/coll/priority-queue.lux b/stdlib/test/test/lux/data/coll/priority-queue.lux
new file mode 100644
index 000000000..5c53edfb1
--- /dev/null
+++ b/stdlib/test/test/lux/data/coll/priority-queue.lux
@@ -0,0 +1,56 @@
+(;module:
+  lux
+  (lux [io]
+       (control monad)
+       (data (coll ["&" priority-queue])
+             [number])
+       ["R" math/random]
+       pipe)
+  lux/test)
+
+(def: (gen-queue size)
+  (-> 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))))
+
+(test: "Queues"
+  [size (|> R;nat
+            (:: @ map (|>. (n.% +100) (n.max +1))))
+   sample (gen-queue size)
+   non-member-priority R;nat
+   non-member R;nat]
+  ($_ seq
+      (assert "I can query the size of a queue (and empty queues have size 0)."
+              (n.= size (&;size sample)))
+
+      (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))
+                       (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)
+                                   non-member))
+                   (and (&;member? number;Eq<Nat> sample (&;peek sample))
+                        (not (&;member? number;Eq<Nat> (&;pop sample) (&;peek sample))))))
+      ))
diff --git a/stdlib/test/test/lux/data/coll/seq.lux b/stdlib/test/test/lux/data/coll/seq.lux
new file mode 100644
index 000000000..e62f36854
--- /dev/null
+++ b/stdlib/test/test/lux/data/coll/seq.lux
@@ -0,0 +1,128 @@
+(;module:
+  lux
+  (lux [io]
+       (control monad)
+       (data (coll ["&" seq]
+                   ["F" tree/finger]
+                   ["L" list])
+             [text "Text/" Monoid<Text>]
+             [number]
+             [bool]
+             [product])
+       ["R" math/random]
+       pipe)
+  lux/test)
+
+(def: bounded-size
+  (R;Random Nat)
+  (|> R;nat
+      (:: R;Monad<Random> map (|>. (n.% +100) (n.+ +10) (n.max +1)))))
+
+(test: "Seqs: Part 1"
+  [size bounded-size
+   idx (:: @ map (n.% size) R;nat)
+   sample (|> (R;list size R;nat)
+              (:: @ map (|>. &;from-list (default (undefined)))))
+   extra R;nat
+   #let [(^open "&/") (&;Eq<Seq> number;Eq<Nat>)]]
+  ($_ seq
+      (assert "Can convert to/from list."
+              (|> sample
+                  &;to-list &;from-list (default (undefined))
+                  (&/= sample)))
+      
+      (assert "The size function should correctly portray the size of the seq."
+              (n.= size (&;size sample)))
+
+      (assert "Reversing a seq does not change it's size."
+              (n.= (&;size sample)
+                   (&;size (&;reverse sample))))
+      
+      (assert "Reversing a seq twice results in the original seq."
+              (&/= sample
+                   (&;reverse (&;reverse sample))))
+
+      (assert "If every element in a list satisfies a predicate, there can't be any that satisfy its complement."
+              (if (&;every? n.even? sample)
+                (not (&;any? (bool;complement n.even?) sample))
+                (&;any? (bool;complement n.even?) sample)))
+
+      (assert "Any element of the list can be considered its member."
+              (and (&;member? number;Eq<Nat>
+                              (&;prepend extra sample)
+                              extra)
+                   (&;member? number;Eq<Nat>
+                              (&;append extra sample)
+                              extra)))
+      
+      (assert "Can do random access to seq elements."
+              (and (|> (&;prepend extra sample)
+                       (&;nth +0)
+                       (case> (#;Some reference)
+                              (n.= reference extra)
+
+                              _
+                              false))
+                   (|> (&;append extra sample)
+                       (&;nth size)
+                       (case> (#;Some reference)
+                              (n.= reference extra)
+
+                              _
+                              false))))
+      ))
+
+(test: "Seqs: Part 2"
+  [size bounded-size
+   sample (|> (R;list size R;nat)
+              (:: @ map (|>. &;from-list (default (undefined)))))
+   #let [(^open "&/") (&;Eq<Seq> number;Eq<Nat>)
+         (^open "&/") &;Functor<Seq>]]
+  ($_ seq
+      (assert "Functor should go over every element of the seq."
+              (let [there (&/map n.inc sample)
+                    back-again (&/map n.dec there)]
+                (and (not (&/= sample there))
+                     (&/= sample back-again))))
+
+      (assert "Sorting a seq shouldn't change it's size."
+              (n.= (&;size sample)
+                   (&;size (&;sort n.< sample))))
+
+      (assert "Sorting a seq with one order should yield the reverse of sorting it with the opposite order."
+              (&/= (&;sort n.< sample)
+                   (&;reverse (&;sort n.> sample))))
+      ))
+
+(test: "Seqs: Part 3"
+  [size bounded-size
+   idx (:: @ map (n.% size) R;nat)
+   sample (|> (R;list size R;nat)
+              (:: @ map (|>. &;from-list (default (undefined)))))
+   other-size bounded-size
+   other-sample (|> (R;list other-size R;nat)
+                    (:: @ map (|>. &;from-list (default (undefined)))))
+   elem R;nat
+   #let [(^open "&/") (&;Eq<Seq> number;Eq<Nat>)
+         (^open "&/") &;Monad<Seq>]]
+  ($_ seq
+      (assert "Applicative allows you to create singleton seqs, and apply seqs of functions to seqs of values."
+              (and (&/= (&;seq elem) (&/wrap elem))
+                   (&/= (&/map n.inc sample)
+                        (&/apply (&/wrap n.inc) sample))))
+
+      (assert "Seq concatenation is a monad."
+              (&/= (F;branch 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."
+              (case (&;find n.even? sample)
+                (#;Some found)
+                (and (n.even? found)
+                     (&;any? n.even? sample)
+                     (not (&;every? (bool;complement n.even?) sample)))
+
+                #;None
+                (and (not (&;any? n.even? sample))
+                     (&;every? (bool;complement n.even?) sample))))
+      ))
diff --git a/stdlib/test/tests.lux b/stdlib/test/tests.lux
index d92595424..c066e551e 100644
--- a/stdlib/test/tests.lux
+++ b/stdlib/test/tests.lux
@@ -48,7 +48,9 @@
                          [stack]
                          ## [vector]
                          (tree [rose]
-                               [zipper]))
+                               [zipper])
+                         ["_;" seq]
+                         ["_;" priority-queue])
                    (text [format])
                    )
              ["_;" math]