diff options
author | Eduardo Julian | 2017-04-03 20:34:38 -0400 |
---|---|---|
committer | Eduardo Julian | 2017-04-03 20:34:38 -0400 |
commit | 95100b81d87e55668b242ef40aac623f52523e03 (patch) | |
tree | d32457ef7d46e63ba023115c1e7ccb2367200977 /stdlib | |
parent | 367c56f33d72621120bcf00953f5fafffb028e97 (diff) |
- Persistent queues and sequences can now be empty.
Diffstat (limited to 'stdlib')
-rw-r--r-- | stdlib/source/lux/data/coll/priority-queue.lux | 135 | ||||
-rw-r--r-- | stdlib/source/lux/data/coll/seq.lux | 260 | ||||
-rw-r--r-- | stdlib/test/test/lux/data/coll/priority-queue.lux | 42 | ||||
-rw-r--r-- | stdlib/test/test/lux/data/coll/seq.lux | 15 |
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." |