diff options
| -rw-r--r-- | lux-mode/lux-mode.el | 2 | ||||
| -rw-r--r-- | stdlib/source/lux/data/coll/priority-queue.lux | 86 | ||||
| -rw-r--r-- | stdlib/source/lux/data/coll/queue.lux | 6 | ||||
| -rw-r--r-- | stdlib/source/lux/data/coll/seq.lux | 208 | ||||
| -rw-r--r-- | stdlib/source/lux/data/coll/tree/finger.lux | 54 | ||||
| -rw-r--r-- | stdlib/source/lux/data/number.lux | 2 | ||||
| -rw-r--r-- | stdlib/test/test/lux/data/coll/list.lux | 2 | ||||
| -rw-r--r-- | stdlib/test/test/lux/data/coll/priority-queue.lux | 56 | ||||
| -rw-r--r-- | stdlib/test/test/lux/data/coll/seq.lux | 128 | ||||
| -rw-r--r-- | stdlib/test/tests.lux | 4 |
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] |