aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source
diff options
context:
space:
mode:
Diffstat (limited to 'stdlib/source')
-rw-r--r--stdlib/source/lux/data/coll/priority-queue.lux135
-rw-r--r--stdlib/source/lux/data/coll/seq.lux260
2 files changed, 242 insertions, 153 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)))))))
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-06 14:39:22 +0000