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.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
5 files changed, 352 insertions, 4 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.*]
generated by cgit v1.2.3 (git 2.25.1) at 2024-09-18 00:55:48 +0000