diff options
Diffstat (limited to '')
| -rw-r--r-- | stdlib/source/lux/control/interval.lux | 187 | ||||
| -rw-r--r-- | stdlib/source/lux/data/number.lux | 15 | ||||
| -rw-r--r-- | stdlib/test/test/lux/control/interval.lux | 217 | ||||
| -rw-r--r-- | stdlib/test/tests.lux | 1 |
4 files changed, 399 insertions, 21 deletions
diff --git a/stdlib/source/lux/control/interval.lux b/stdlib/source/lux/control/interval.lux index 7071c49ef..1b197840b 100644 --- a/stdlib/source/lux/control/interval.lux +++ b/stdlib/source/lux/control/interval.lux @@ -1,27 +1,184 @@ (;module: lux - (lux (control ord))) + (lux (control eq + [ord] + [enum #+ Enum]))) ## Signatures (sig: #export (Interval a) {#;doc "A representation of top and bottom boundaries for an ordered type."} - (: (Ord a) - ord) + (: (Enum a) + enum) (: a - top) + bottom) (: a - bottom)) + top)) -(def: #export (within? Interval<a> elem) +(def: #export (between Enum<a> bottom top) + (All [a] (-> (Enum a) a a (Interval a))) + (struct (def: enum Enum<a>) + (def: bottom bottom) + (def: top top))) + +(def: #export (singleton Enum<a> elem) + (All [a] (-> (Enum a) a (Interval a))) + (struct (def: enum Enum<a>) + (def: bottom elem) + (def: top elem))) + +(do-template [<name> <comp>] + [(def: #export (<name> interval) + (All [a] (-> (Interval a) Bool)) + (let [(^open) interval] + (<comp> bottom top)))] + + [inner? >] + [outer? <] + [singleton? =] + ) + +(def: #export (within? interval elem) + (All [a] (-> (Interval a) a Bool)) + (let [(^open) interval] + (cond (inner? interval) + (and (>= bottom elem) + (<= top elem)) + + (outer? interval) + (or (>= bottom elem) + (<= top elem)) + + ## singleton + (and (= bottom elem) + (= top elem))))) + +(do-template [<name> <limit>] + [(def: #export (<name> elem interval) + (All [a] (-> a (Interval a) Bool)) + (let [(^open) interval] + (= <limit> elem)))] + + [starts-with? bottom] + [ends-with? top] + ) + +(def: #export (borders? interval elem) (All [a] (-> (Interval a) a Bool)) - (let [(^open) Interval<a>] - (if (>= bottom top) - ## Inside order - (and (>= bottom elem) - (<= top elem)) - ## Outside order - (and (<= bottom elem) - (>= top elem)) - ))) + (or (starts-with? elem interval) + (ends-with? elem interval))) + +(def: #export (union left right) + (All [a] (-> (Interval a) (Interval a) (Interval a))) + (struct (def: enum (get@ #enum right)) + (def: bottom (ord;min (get@ [#enum #enum;ord] right) (:: left bottom) (:: right bottom))) + (def: top (ord;max (get@ [#enum #enum;ord] right) (:: left top) (:: right top))))) + +(def: #export (intersection left right) + (All [a] (-> (Interval a) (Interval a) (Interval a))) + (struct (def: enum (get@ #enum right)) + (def: bottom (ord;max (get@ [#enum #enum;ord] right) (:: left bottom) (:: right bottom))) + (def: top (ord;min (get@ [#enum #enum;ord] right) (:: left top) (:: right top))))) + +(def: #export (complement interval) + (All [a] (-> (Interval a) (Interval a))) + (let [(^open) interval] + (struct (def: enum (get@ #enum interval)) + (def: bottom (succ top)) + (def: top (pred bottom))))) + +(def: #export (precedes? reference sample) + (All [a] (-> (Interval a) (Interval a) Bool)) + (let [(^open) reference + limit (:: reference bottom)] + (and (< limit (:: sample bottom)) + (< limit (:: sample top))))) + +(def: #export (succeeds? reference sample) + (All [a] (-> (Interval a) (Interval a) Bool)) + (precedes? sample reference)) + +(def: #export (meets? reference sample) + (All [a] (-> (Interval a) (Interval a) Bool)) + (let [(^open) reference + limit (:: reference bottom)] + (and (<= limit (:: sample bottom)) + (= limit (:: sample top))))) + +(def: #export (touches? reference sample) + (All [a] (-> (Interval a) (Interval a) Bool)) + (or (meets? reference sample) + (meets? sample reference))) + +(do-template [<name> <eq-side> <ineq> <ineq-side>] + [(def: #export (<name> reference sample) + (All [a] (-> (Interval a) (Interval a) Bool)) + (let [(^open) reference] + (and (= (:: reference <eq-side>) (:: sample <eq-side>)) + (<ineq> (:: reference <ineq-side>) (:: sample <ineq-side>)))))] + + [starts? bottom <= top] + [finishes? top >= bottom] + ) + +(do-template [<name> <comp>] + [(def: #export (<name> reference sample) + (All [a] (-> a (Interval a) Bool)) + (let [(^open) sample] + (and (<comp> reference bottom) + (<comp> reference top))))] + + [before? <] + [after? >] + ) + +(struct: #export Eq<Interval> (All [a] (Eq (Interval a))) + (def: (= reference sample) + (let [(^open) reference] + (and (= bottom (:: sample bottom)) + (= top (:: sample top)))))) + +(def: #export (nested? reference sample) + (All [a] (-> (Interval a) (Interval a) Bool)) + (cond (or (singleton? sample) + (and (inner? reference) (inner? sample)) + (and (outer? reference) (outer? sample))) + (let [(^open) reference] + (and (>= (:: reference bottom) (:: sample bottom)) + (<= (:: reference top) (:: sample top)))) + + (or (singleton? reference) + (and (inner? reference) (outer? sample))) + false + + ## (and (outer? reference) (inner? sample)) + (let [(^open) reference] + (or (and (>= (:: reference bottom) (:: sample bottom)) + (> (:: reference bottom) (:: sample top))) + (and (< (:: reference top) (:: sample bottom)) + (<= (:: reference top) (:: sample top))))) + )) + +(def: #export (overlaps? reference sample) + (All [a] (-> (Interval a) (Interval a) Bool)) + (let [(^open) reference] + (cond (singleton? sample) + false + + (singleton? reference) + (and (>= (:: sample bottom) (:: reference bottom)) + (<= (:: sample top) (:: reference top))) + + (or (and (inner? sample) (outer? reference)) + (and (outer? sample) (inner? reference))) + (or (>= (:: reference bottom) (:: sample top)) + (<= (:: reference top) (:: sample bottom))) + + (inner? sample) + (and (not (:: Eq<Interval> = reference sample)) + (inner? (intersection reference sample))) + + ## (outer? sample) + (not (:: Eq<Interval> = reference sample)) + ))) diff --git a/stdlib/source/lux/data/number.lux b/stdlib/source/lux/data/number.lux index 1a29fc5b6..8c1c021b4 100644 --- a/stdlib/source/lux/data/number.lux +++ b/stdlib/source/lux/data/number.lux @@ -92,18 +92,21 @@ [Nat Ord<Nat> n.inc n.dec] [Int Ord<Int> i.inc i.dec] + [Real Ord<Real> (r.+ (_lux_proc [ "real" "smallest-value"] [])) (r.- (_lux_proc [ "real" "smallest-value"] []))] + [Deg Ord<Deg> (d.+ (_lux_proc [ "deg" "min-value"] [])) (d.- (_lux_proc [ "deg" "min-value"] []))] ) -(do-template [<type> <ord> <top> <bottom>] +(do-template [<type> <enum> <top> <bottom>] [(struct: #export _ (Interval <type>) - (def: ord <ord>) + (def: enum <enum>) (def: top <top>) (def: bottom <bottom>))] - [ Nat Ord<Nat> (_lux_proc [ "nat" "max-value"] []) (_lux_proc [ "nat" "min-value"] [])] - [ Int Ord<Int> (_lux_proc [ "int" "max-value"] []) (_lux_proc [ "int" "min-value"] [])] - [Real Ord<Real> (_lux_proc ["real" "max-value"] []) (_lux_proc ["real" "min-value"] [])] - [ Deg Ord<Deg> (_lux_proc [ "deg" "max-value"] []) (_lux_proc [ "deg" "min-value"] [])]) + [ Nat Enum<Nat> (_lux_proc [ "nat" "max-value"] []) (_lux_proc [ "nat" "min-value"] [])] + [ Int Enum<Int> (_lux_proc [ "int" "max-value"] []) (_lux_proc [ "int" "min-value"] [])] + [Real Enum<Real> (_lux_proc ["real" "max-value"] []) (_lux_proc ["real" "min-value"] [])] + [ Deg Enum<Deg> (_lux_proc [ "deg" "max-value"] []) (_lux_proc [ "deg" "min-value"] [])] + ) (do-template [<name> <type> <unit> <append>] [(struct: #export <name> (Monoid <type>) diff --git a/stdlib/test/test/lux/control/interval.lux b/stdlib/test/test/lux/control/interval.lux new file mode 100644 index 000000000..2127ff6df --- /dev/null +++ b/stdlib/test/test/lux/control/interval.lux @@ -0,0 +1,217 @@ +(;module: + lux + lux/test + (lux (control monad + ["&" interval]) + [io] + ["R" math/random] + (data text/format + [number] + ["S" coll/set] + ["L" coll/list]) + pipe)) + +(test: "Equality." + [bottom R;int + top R;int + #let [(^open "&/") &;Eq<Interval>]] + ($_ seq + (assert "Every interval is equal to itself." + (and (let [self (&;between number;Enum<Int> bottom top)] + (&/= self self)) + (let [self (&;between number;Enum<Int> top bottom)] + (&/= self self)) + (let [self (&;singleton number;Enum<Int> bottom)] + (&/= self self)))))) + +(test: "Boundaries" + [bottom R;int + top R;int + #let [interval (&;between number;Enum<Int> bottom top)]] + ($_ seq + (assert "Every boundary value belongs to it's interval." + (and (&;within? interval bottom) + (&;within? interval top))) + (assert "Every interval starts with its bottom." + (&;starts-with? bottom interval)) + (assert "Every interval ends with its top." + (&;ends-with? top interval)) + (assert "The boundary values border the interval." + (and (&;borders? interval bottom) + (&;borders? interval top))) + )) + +(def: (list-to-4tuple list) + (-> (List Int) [Int Int Int Int]) + (case list + (^ (list x0 x1 x2 x3)) + [x0 x1 x2 x3] + + _ + (undefined))) + + +(do-template [<name> <cmp>] + [(def: <name> + (R;Random (&;Interval Int)) + (do R;Monad<Random> + [bottom R;int + top (|> R;int (R;filter (|>. (i.= bottom) not)))] + (if (<cmp> top bottom) + (wrap (&;between number;Enum<Int> bottom top)) + (wrap (&;between number;Enum<Int> top bottom)))))] + + [gen-inner i.<] + [gen-outer i.>] + ) + +(def: gen-singleton + (R;Random (&;Interval Int)) + (do R;Monad<Random> + [point R;int] + (wrap (&;singleton number;Enum<Int> point)))) + +(def: gen-interval + (R;Random (&;Interval Int)) + ($_ R;either + gen-inner + gen-outer + gen-singleton)) + +(test: "Unions" + [some-interval gen-interval + left-inner gen-inner + right-inner gen-inner + left-singleton gen-singleton + right-singleton gen-singleton + left-outer gen-outer + right-outer gen-outer + #let [(^open "&/") &;Eq<Interval>]] + ($_ seq + (assert "The union of an interval to itself yields the same interval." + (&/= some-interval (&;union some-interval some-interval))) + (assert "The union of 2 inner intervals is another inner interval." + (&;inner? (&;union left-inner right-inner))) + (assert "The union of 2 outer intervals yields an inner interval when their complements don't overlap, and an outer when they do." + (if (&;overlaps? (&;complement left-outer) (&;complement right-outer)) + (&;outer? (&;union left-outer right-outer)) + (&;inner? (&;union left-outer right-outer)))) + )) + +(test: "Intersections" + [some-interval gen-interval + left-inner gen-inner + right-inner gen-inner + left-singleton gen-singleton + right-singleton gen-singleton + left-outer gen-outer + right-outer gen-outer + #let [(^open "&/") &;Eq<Interval>]] + ($_ seq + (assert "The intersection of an interval to itself yields the same interval." + (&/= some-interval (&;intersection some-interval some-interval))) + (assert "The intersection of 2 inner intervals yields an inner interval when they overlap, and an outer when they don't." + (if (&;overlaps? left-inner right-inner) + (&;inner? (&;intersection left-inner right-inner)) + (&;outer? (&;intersection left-inner right-inner)))) + (assert "The intersection of 2 outer intervals is another outer interval." + (&;outer? (&;intersection left-outer right-outer))) + )) + +(test: "Complement" + [some-interval gen-interval + #let [(^open "&/") &;Eq<Interval>]] + ($_ seq + (assert "The complement of a complement is the same as the original." + (&/= some-interval (|> some-interval &;complement &;complement))) + (assert "The complement of an interval does not overlap it." + (not (&;overlaps? some-interval (&;complement some-interval)))) + )) + +(test: "Positioning/location" + [[l m r] (|> (R;set number;Hash<Int> +3 R;int) + (:: @ map (|>. S;to-list + (L;sort i.<) + (case> (^ (list b t1 t2)) + [b t1 t2] + + _ + (undefined))))) + #let [left (&;singleton number;Enum<Int> l) + right (&;singleton number;Enum<Int> r)]] + ($_ seq + (assert "'precedes?' and 'succeeds?' are symetric." + (and (&;precedes? right left) + (&;succeeds? left right))) + (assert "Can check if an interval is before or after some element." + (and (&;before? m left) + (&;after? m right))) + )) + +(test: "Touching intervals" + [[b t1 t2] (|> (R;set number;Hash<Int> +3 R;int) + (:: @ map (|>. S;to-list + (L;sort i.<) + (case> (^ (list b t1 t2)) + [b t1 t2] + + _ + (undefined))))) + #let [int-left (&;between number;Enum<Int> t1 t2) + int-right (&;between number;Enum<Int> b t1)]] + ($_ seq + (assert "An interval meets another if it's top is the other's bottom." + (&;meets? int-left int-right)) + (assert "Two intervals touch one another if any one meets the other." + (&;touches? int-left int-right)) + (assert "Can check if 2 intervals start together." + (&;starts? (&;between number;Enum<Int> b t2) + (&;between number;Enum<Int> b t1))) + (assert "Can check if 2 intervals finish together." + (&;finishes? (&;between number;Enum<Int> b t2) + (&;between number;Enum<Int> t1 t2))) + )) + +(test: "Nesting & overlap" + [some-interval gen-interval + [x0 x1 x2 x3] (|> (R;set number;Hash<Int> +4 R;int) + (:: @ map (|>. S;to-list + (L;sort i.<) + (case> (^ (list x0 x1 x2 x3)) + [x0 x1 x2 x3] + + _ + (undefined)))))] + ($_ seq + (assert "Every interval is nested into itself." + (&;nested? some-interval some-interval)) + (assert "No interval overlaps with itself." + (not (&;overlaps? some-interval some-interval))) + (let [small-inner (&;between number;Enum<Int> x1 x2) + large-inner (&;between number;Enum<Int> x0 x3)] + (assert "Inner intervals can be nested inside one another." + (and (&;nested? large-inner small-inner) + (not (&;nested? small-inner large-inner))))) + (let [left-inner (&;between number;Enum<Int> x0 x2) + right-inner (&;between number;Enum<Int> x1 x3)] + (assert "Inner intervals can overlap one another." + (and (&;overlaps? left-inner right-inner) + (&;overlaps? right-inner left-inner)))) + (let [small-outer (&;between number;Enum<Int> x2 x1) + large-outer (&;between number;Enum<Int> x3 x0)] + (assert "Outer intervals can be nested inside one another." + (and (&;nested? small-outer large-outer) + (not (&;nested? large-outer small-outer))))) + (let [left-inner (&;between number;Enum<Int> x0 x1) + right-inner (&;between number;Enum<Int> x2 x3) + outer (&;between number;Enum<Int> x0 x3)] + (assert "Inners can be nested inside outers." + (and (&;nested? outer left-inner) + (&;nested? outer right-inner)))) + (let [left-inner (&;between number;Enum<Int> x0 x2) + right-inner (&;between number;Enum<Int> x1 x3) + outer (&;between number;Enum<Int> x1 x2)] + (assert "Inners can overlap outers." + (and (&;overlaps? outer left-inner) + (&;overlaps? outer right-inner)))) + )) diff --git a/stdlib/test/tests.lux b/stdlib/test/tests.lux index ce01da97e..d92595424 100644 --- a/stdlib/test/tests.lux +++ b/stdlib/test/tests.lux @@ -22,6 +22,7 @@ ["_;" frp] ["_;" promise] ["_;" stm]) + (control ["_;" interval]) ["_;" effect] (data [bit] [bool] |