aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--lux-mode/lux-mode.el2
-rw-r--r--stdlib/source/lux/data/coll/priority-queue.lux86
-rw-r--r--stdlib/source/lux/data/coll/queue.lux6
-rw-r--r--stdlib/source/lux/data/coll/seq.lux208
-rw-r--r--stdlib/source/lux/data/coll/tree/finger.lux54
-rw-r--r--stdlib/source/lux/data/number.lux2
-rw-r--r--stdlib/test/test/lux/data/coll/list.lux2
-rw-r--r--stdlib/test/test/lux/data/coll/priority-queue.lux56
-rw-r--r--stdlib/test/test/lux/data/coll/seq.lux128
-rw-r--r--stdlib/test/tests.lux4
10 files changed, 541 insertions, 7 deletions
diff --git a/lux-mode/lux-mode.el b/lux-mode/lux-mode.el
index 6511c66cb..4ca40f257 100644
--- a/lux-mode/lux-mode.el
+++ b/lux-mode/lux-mode.el
@@ -231,7 +231,7 @@ Called by `imenu--generic-function'."
"object" "jvm-import" "do-to" "with-open" "synchronized" "class-for"
"doc"
"|E" "|F" "|H" "effect:" "handler:" "with-handler" "doE" "lift"
- "regex"
+ "regex" "seq"
) t)
"\\>")
1 font-lock-builtin-face)
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]