aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--stdlib/source/lux/data/coll/priority-queue.lux135
-rw-r--r--stdlib/source/lux/data/coll/seq.lux260
-rw-r--r--stdlib/test/test/lux/data/coll/priority-queue.lux42
-rw-r--r--stdlib/test/test/lux/data/coll/seq.lux15
4 files changed, 268 insertions, 184 deletions
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."
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-06 02:28:36 +0000