aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source
diff options
context:
space:
mode:
Diffstat (limited to 'stdlib/source')
-rw-r--r--stdlib/source/lux/control/interval.lux187
-rw-r--r--stdlib/source/lux/data/number.lux15
2 files changed, 181 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>)
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-29 18:51:53 +0000