aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--luxc/src/lux/analyser/proc/common.clj2
-rw-r--r--luxc/src/lux/compiler/js/proc/common.clj2
-rw-r--r--luxc/src/lux/compiler/jvm/proc/common.clj2
-rw-r--r--stdlib/source/lux/control/interval.lux187
-rw-r--r--stdlib/source/lux/data/number.lux15
-rw-r--r--stdlib/test/test/lux/control/interval.lux217
-rw-r--r--stdlib/test/tests.lux1
7 files changed, 405 insertions, 21 deletions
diff --git a/luxc/src/lux/analyser/proc/common.clj b/luxc/src/lux/analyser/proc/common.clj
index 9a295b1eb..ff85600ab 100644
--- a/luxc/src/lux/analyser/proc/common.clj
+++ b/luxc/src/lux/analyser/proc/common.clj
@@ -272,6 +272,7 @@
^:private analyse-deg-min-value &type/Deg ["deg" "min-value"]
^:private analyse-deg-max-value &type/Deg ["deg" "max-value"]
+ ^:private analyse-real-smallest-value &type/Real ["real" "smallest-value"]
^:private analyse-real-min-value &type/Real ["real" "min-value"]
^:private analyse-real-max-value &type/Real ["real" "max-value"]
^:private analyse-real-not-a-number &type/Real ["real" "not-a-number"]
@@ -591,6 +592,7 @@
"<" (analyse-real-lt analyse exo-type ?values)
"encode" (analyse-real-encode analyse exo-type ?values)
"decode" (analyse-real-decode analyse exo-type ?values)
+ "smallest-value" (analyse-real-smallest-value analyse exo-type ?values)
"min-value" (analyse-real-min-value analyse exo-type ?values)
"max-value" (analyse-real-max-value analyse exo-type ?values)
"not-a-number" (analyse-real-not-a-number analyse exo-type ?values)
diff --git a/luxc/src/lux/compiler/js/proc/common.clj b/luxc/src/lux/compiler/js/proc/common.clj
index cd67104f4..f6591c8fa 100644
--- a/luxc/src/lux/compiler/js/proc/common.clj
+++ b/luxc/src/lux/compiler/js/proc/common.clj
@@ -178,6 +178,7 @@
^:private compile-deg-min-value &&lux/compile-deg 0
^:private compile-deg-max-value &&lux/compile-deg -1
+ ^:private compile-real-smallest-value &&lux/compile-real Double/MIN_VALUE
^:private compile-real-min-value &&lux/compile-real (* -1.0 Double/MAX_VALUE)
^:private compile-real-max-value &&lux/compile-real Double/MAX_VALUE
@@ -552,6 +553,7 @@
"<" (compile-real-lt compile ?values special-args)
"encode" (compile-real-encode compile ?values special-args)
"decode" (compile-real-decode compile ?values special-args)
+ "smallest-value" (compile-real-smallest-value compile ?values special-args)
"max-value" (compile-real-max-value compile ?values special-args)
"min-value" (compile-real-min-value compile ?values special-args)
"not-a-number" (compile-real-not-a-number compile ?values special-args)
diff --git a/luxc/src/lux/compiler/jvm/proc/common.clj b/luxc/src/lux/compiler/jvm/proc/common.clj
index ffb621c3b..c8623985a 100644
--- a/luxc/src/lux/compiler/jvm/proc/common.clj
+++ b/luxc/src/lux/compiler/jvm/proc/common.clj
@@ -378,6 +378,7 @@
^:private compile-deg-min-value (.visitLdcInsn 0) &&/wrap-long
^:private compile-deg-max-value (.visitLdcInsn -1) &&/wrap-long
+ ^:private compile-real-smallest-value (.visitLdcInsn Double/MIN_VALUE) &&/wrap-double
^:private compile-real-min-value (.visitLdcInsn (* -1.0 Double/MAX_VALUE)) &&/wrap-double
^:private compile-real-max-value (.visitLdcInsn Double/MAX_VALUE) &&/wrap-double
@@ -996,6 +997,7 @@
"=" (compile-real-eq compile ?values special-args)
"<" (compile-real-lt compile ?values special-args)
"hash" (compile-real-hash compile ?values special-args)
+ "smallest-value" (compile-real-smallest-value compile ?values special-args)
"max-value" (compile-real-max-value compile ?values special-args)
"min-value" (compile-real-min-value compile ?values special-args)
"not-a-number" (compile-real-not-a-number compile ?values special-args)
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]
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-06 02:26:46 +0000