From 15ff808a5ddd2d2c9e21774c1147ff82e015a498 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Mon, 27 Mar 2017 23:07:24 -0400 Subject: - Expanded the lux/control/interval module. - Implemented Enum. --- stdlib/source/lux/control/interval.lux | 187 ++++++++++++++++++++++--- stdlib/source/lux/data/number.lux | 15 ++- stdlib/test/test/lux/control/interval.lux | 217 ++++++++++++++++++++++++++++++ stdlib/test/tests.lux | 1 + 4 files changed, 399 insertions(+), 21 deletions(-) create mode 100644 stdlib/test/test/lux/control/interval.lux (limited to 'stdlib') 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 elem) +(def: #export (between Enum bottom top) + (All [a] (-> (Enum a) a a (Interval a))) + (struct (def: enum Enum) + (def: bottom bottom) + (def: top top))) + +(def: #export (singleton Enum elem) + (All [a] (-> (Enum a) a (Interval a))) + (struct (def: enum Enum) + (def: bottom elem) + (def: top elem))) + +(do-template [ ] + [(def: #export ( interval) + (All [a] (-> (Interval a) Bool)) + (let [(^open) interval] + ( 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 [ ] + [(def: #export ( elem interval) + (All [a] (-> a (Interval a) Bool)) + (let [(^open) interval] + (= elem)))] + + [starts-with? bottom] + [ends-with? top] + ) + +(def: #export (borders? interval elem) (All [a] (-> (Interval a) a Bool)) - (let [(^open) Interval] - (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 [ ] + [(def: #export ( reference sample) + (All [a] (-> (Interval a) (Interval a) Bool)) + (let [(^open) reference] + (and (= (:: reference ) (:: sample )) + ( (:: reference ) (:: sample )))))] + + [starts? bottom <= top] + [finishes? top >= bottom] + ) + +(do-template [ ] + [(def: #export ( reference sample) + (All [a] (-> a (Interval a) Bool)) + (let [(^open) sample] + (and ( reference bottom) + ( reference top))))] + + [before? <] + [after? >] + ) + +(struct: #export Eq (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 = reference sample)) + (inner? (intersection reference sample))) + + ## (outer? sample) + (not (:: Eq = 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 n.inc n.dec] [Int Ord i.inc i.dec] + [Real Ord (r.+ (_lux_proc [ "real" "smallest-value"] [])) (r.- (_lux_proc [ "real" "smallest-value"] []))] + [Deg Ord (d.+ (_lux_proc [ "deg" "min-value"] [])) (d.- (_lux_proc [ "deg" "min-value"] []))] ) -(do-template [ ] +(do-template [ ] [(struct: #export _ (Interval ) - (def: ord ) + (def: enum ) (def: top ) (def: bottom ))] - [ Nat Ord (_lux_proc [ "nat" "max-value"] []) (_lux_proc [ "nat" "min-value"] [])] - [ Int Ord (_lux_proc [ "int" "max-value"] []) (_lux_proc [ "int" "min-value"] [])] - [Real Ord (_lux_proc ["real" "max-value"] []) (_lux_proc ["real" "min-value"] [])] - [ Deg Ord (_lux_proc [ "deg" "max-value"] []) (_lux_proc [ "deg" "min-value"] [])]) + [ Nat Enum (_lux_proc [ "nat" "max-value"] []) (_lux_proc [ "nat" "min-value"] [])] + [ Int Enum (_lux_proc [ "int" "max-value"] []) (_lux_proc [ "int" "min-value"] [])] + [Real Enum (_lux_proc ["real" "max-value"] []) (_lux_proc ["real" "min-value"] [])] + [ Deg Enum (_lux_proc [ "deg" "max-value"] []) (_lux_proc [ "deg" "min-value"] [])] + ) (do-template [ ] [(struct: #export (Monoid ) 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]] + ($_ seq + (assert "Every interval is equal to itself." + (and (let [self (&;between number;Enum bottom top)] + (&/= self self)) + (let [self (&;between number;Enum top bottom)] + (&/= self self)) + (let [self (&;singleton number;Enum bottom)] + (&/= self self)))))) + +(test: "Boundaries" + [bottom R;int + top R;int + #let [interval (&;between number;Enum 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 [ ] + [(def: + (R;Random (&;Interval Int)) + (do R;Monad + [bottom R;int + top (|> R;int (R;filter (|>. (i.= bottom) not)))] + (if ( top bottom) + (wrap (&;between number;Enum bottom top)) + (wrap (&;between number;Enum top bottom)))))] + + [gen-inner i.<] + [gen-outer i.>] + ) + +(def: gen-singleton + (R;Random (&;Interval Int)) + (do R;Monad + [point R;int] + (wrap (&;singleton number;Enum 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]] + ($_ 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]] + ($_ 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]] + ($_ 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 +3 R;int) + (:: @ map (|>. S;to-list + (L;sort i.<) + (case> (^ (list b t1 t2)) + [b t1 t2] + + _ + (undefined))))) + #let [left (&;singleton number;Enum l) + right (&;singleton number;Enum 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 +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 t1 t2) + int-right (&;between number;Enum 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 b t2) + (&;between number;Enum b t1))) + (assert "Can check if 2 intervals finish together." + (&;finishes? (&;between number;Enum b t2) + (&;between number;Enum t1 t2))) + )) + +(test: "Nesting & overlap" + [some-interval gen-interval + [x0 x1 x2 x3] (|> (R;set number;Hash +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 x1 x2) + large-inner (&;between number;Enum 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 x0 x2) + right-inner (&;between number;Enum 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 x2 x1) + large-outer (&;between number;Enum 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 x0 x1) + right-inner (&;between number;Enum x2 x3) + outer (&;between number;Enum x0 x3)] + (assert "Inners can be nested inside outers." + (and (&;nested? outer left-inner) + (&;nested? outer right-inner)))) + (let [left-inner (&;between number;Enum x0 x2) + right-inner (&;between number;Enum x1 x3) + outer (&;between number;Enum 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] -- cgit v1.2.3