Removed extraneous files that DrDr was running
This commit is contained in:
Neil Toronto
parent
eaf68e6e85
commit
aa83f80d64
|
|
@ -2,4 +2,4 @@
|
|||
|
||||
(define scribblings '(["scribblings/math.scrbl" (multi-page)]))
|
||||
|
||||
(define compile-omit-paths '("tests" "private/todo"))
|
||||
(define compile-omit-paths '("tests"))
|
||||
|
|
|
|||
|
|
@ -1,370 +0,0 @@
|
|||
#lang typed/racket/base
|
||||
|
||||
(require racket/match
|
||||
racket/performance-hint
|
||||
(for-syntax racket/base)
|
||||
"../../flonum.rkt")
|
||||
|
||||
(provide
|
||||
;; Types
|
||||
(rename-out [-Empty-Interval Empty-Interval]
|
||||
[-Nonempty-Interval Nonempty-Interval])
|
||||
Interval
|
||||
;; Constructors
|
||||
empty-interval
|
||||
nonempty-interval
|
||||
interval
|
||||
;; Predicates
|
||||
empty-interval?
|
||||
nonempty-interval?
|
||||
interval?
|
||||
;; Accessors
|
||||
interval-min
|
||||
interval-max
|
||||
interval-min?
|
||||
interval-max?
|
||||
;; Common intervals
|
||||
real-interval
|
||||
nonnegative-interval
|
||||
positive-interval
|
||||
negative-interval
|
||||
nonpositive-interval
|
||||
;; Basic interval ops
|
||||
interval-member?
|
||||
interval-subset?
|
||||
interval-disjoint?
|
||||
interval-intersect
|
||||
interval-join
|
||||
interval-union
|
||||
interval-subtract
|
||||
)
|
||||
|
||||
;; ===================================================================================================
|
||||
;; Empty interval type
|
||||
|
||||
(struct: Empty-Interval () #:transparent
|
||||
#:property prop:custom-print-quotable 'never
|
||||
#:property prop:custom-write (λ (_ port write?) (fprintf port "empty-interval")))
|
||||
|
||||
(define-type -Empty-Interval Empty-Interval)
|
||||
|
||||
(define empty-interval (Empty-Interval))
|
||||
(define empty-interval? Empty-Interval?)
|
||||
|
||||
;; ===================================================================================================
|
||||
;; Nonempty interval type
|
||||
|
||||
(: print-nonempty-interval (Nonempty-Interval Output-Port (U #t #f 0 1) -> Any))
|
||||
(define (print-nonempty-interval ivl port write?)
|
||||
(match-define (nonempty-interval a b a? b?) ivl)
|
||||
(cond [(and a? b?) (fprintf port "(interval ~v ~v)" a b)]
|
||||
[else (fprintf port "(interval ~v ~v ~a ~a)" a b a? b?)]))
|
||||
|
||||
(struct: Nonempty-Interval ([min : Float] [max : Float] [min? : Boolean] [max? : Boolean])
|
||||
#:property prop:custom-print-quotable 'never
|
||||
#:property prop:custom-write print-nonempty-interval)
|
||||
|
||||
(define-type -Nonempty-Interval Nonempty-Interval)
|
||||
|
||||
(define nonempty-interval? Nonempty-Interval?)
|
||||
(define nonempty-interval-min Nonempty-Interval-min)
|
||||
(define nonempty-interval-max Nonempty-Interval-max)
|
||||
(define nonempty-interval-min? Nonempty-Interval-min?)
|
||||
(define nonempty-interval-max? Nonempty-Interval-max?)
|
||||
|
||||
(: valid-nonempty-interval? (Float Float Any Any -> Any))
|
||||
(define (valid-nonempty-interval? a b a? b?)
|
||||
(cond [(= a b) (cond [(= a -inf.0) #f]
|
||||
[(= b +inf.0) #f]
|
||||
[else (and a? b?)])]
|
||||
[else (and (-inf.0 . <= . a)
|
||||
(a . < . b)
|
||||
(b . <= . +inf.0))]))
|
||||
|
||||
(: unsafe-nonempty-interval (Float Float Boolean Boolean -> Nonempty-Interval))
|
||||
(define (unsafe-nonempty-interval a b a? b?)
|
||||
(Nonempty-Interval (if (equal? a -0.0) 0.0 a)
|
||||
(if (= b 0.0) -0.0 b)
|
||||
(if (= -inf.0 a) #f a?)
|
||||
(if (= +inf.0 b) #f b?)))
|
||||
|
||||
(: make-nonempty-interval (case-> (Float Float -> Nonempty-Interval)
|
||||
(Float Float Any -> Nonempty-Interval)
|
||||
(Float Float Any Any -> Nonempty-Interval)))
|
||||
(define (make-nonempty-interval a b [a? #t] [b? #t])
|
||||
(cond [(valid-nonempty-interval? a b a? b?)
|
||||
(unsafe-nonempty-interval a b (and a? #t) (and b? #t))]
|
||||
[else
|
||||
(raise-result-error 'nonempty-interval "Nonempty-Interval" empty-interval)]))
|
||||
|
||||
(define-match-expander nonempty-interval
|
||||
(λ (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ a b a? b?) (syntax/loc stx (Nonempty-Interval a b a? b?))]))
|
||||
(λ (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ . args) (syntax/loc stx (make-nonempty-interval . args))]
|
||||
[_ (syntax/loc stx make-nonempty-interval)])))
|
||||
|
||||
(define real-interval (unsafe-nonempty-interval -inf.0 +inf.0 #f #f))
|
||||
(define nonnegative-interval (unsafe-nonempty-interval 0.0 +inf.0 #t #f))
|
||||
(define positive-interval (unsafe-nonempty-interval 0.0 +inf.0 #f #f))
|
||||
(define nonpositive-interval (unsafe-nonempty-interval -inf.0 0.0 #f #t))
|
||||
(define negative-interval (unsafe-nonempty-interval -inf.0 0.0 #f #f))
|
||||
|
||||
;; ===================================================================================================
|
||||
|
||||
(define-type Interval (U Empty-Interval Nonempty-Interval))
|
||||
(define (interval? v) (or (empty-interval? v) (nonempty-interval? v)))
|
||||
|
||||
(: interval (case-> (Float Float -> Interval)
|
||||
(Float Float Any -> Interval)
|
||||
(Float Float Any Any -> Interval)))
|
||||
(define (interval a b [a? #t] [b? #t])
|
||||
(cond [(valid-nonempty-interval? a b a? b?)
|
||||
(unsafe-nonempty-interval a b (and a? #t) (and b? #t))]
|
||||
[else
|
||||
empty-interval]))
|
||||
|
||||
(define-syntax-rule (define-interval-wrapper name f empty-value)
|
||||
(define name
|
||||
(λ: ([ivl : Interval])
|
||||
(if (empty-interval? ivl) empty-value (f ivl)))))
|
||||
|
||||
(begin-encourage-inline
|
||||
|
||||
(: interval-min (Interval -> Float))
|
||||
(define-interval-wrapper interval-min nonempty-interval-min +nan.0)
|
||||
|
||||
(: interval-max (Interval -> Float))
|
||||
(define-interval-wrapper interval-max nonempty-interval-max +nan.0)
|
||||
|
||||
(: interval-min? (Interval -> Boolean))
|
||||
(define-interval-wrapper interval-min? nonempty-interval-min? #f)
|
||||
|
||||
(: interval-max? (Interval -> Boolean))
|
||||
(define-interval-wrapper interval-max? nonempty-interval-max? #f)
|
||||
|
||||
)
|
||||
|
||||
;; ===================================================================================================
|
||||
;; Membership
|
||||
|
||||
(: nonempty-interval-member? (Nonempty-Interval Float -> Boolean))
|
||||
(define (nonempty-interval-member? I x)
|
||||
(match-define (nonempty-interval a b a? b?) I)
|
||||
(cond [(and (a . < . x) (x . < . b)) #t]
|
||||
[(or (x . < . a) (b . < . x)) #f]
|
||||
[(and (= x a) a?) #t]
|
||||
[(and (= x b) b?) #t]
|
||||
[else #f]))
|
||||
|
||||
;; ===================================================================================================
|
||||
;; Subset test
|
||||
|
||||
(: nonempty-interval-subset? (Nonempty-Interval Nonempty-Interval -> Boolean))
|
||||
(define (nonempty-interval-subset? I1 I2)
|
||||
(match-define (nonempty-interval a1 b1 a1? b1?) I1)
|
||||
(match-define (nonempty-interval a2 b2 a2? b2?) I2)
|
||||
(cond [(or (a1 . >= . b2) (b1 . <= . a2)) #f]
|
||||
[else (and (cond [(a1 . > . a2) #t]
|
||||
[(a1 . < . a2) #f]
|
||||
[else (or (not a1?) a2?)])
|
||||
(cond [(b1 . < . b2) #t]
|
||||
[(b1 . > . b2) #f]
|
||||
[else (or (not b1?) b2?)]))]))
|
||||
|
||||
;; ===================================================================================================
|
||||
;; Disjointness test
|
||||
|
||||
(: nonempty-interval-disjoint? (Nonempty-Interval Nonempty-Interval -> Boolean))
|
||||
(define (nonempty-interval-disjoint? I1 I2)
|
||||
(match-define (nonempty-interval a1 b1 a1? b1?) I1)
|
||||
(match-define (nonempty-interval a2 b2 a2? b2?) I2)
|
||||
(define a (max a1 a2))
|
||||
(define b (min b1 b2))
|
||||
(cond [(< a b) #f]
|
||||
[(> a b) #t]
|
||||
[else (define a?
|
||||
(cond [(a1 . > . a2) a1?]
|
||||
[(a1 . < . a2) a2?]
|
||||
[else (and a1? a2?)]))
|
||||
(define b?
|
||||
(cond [(b1 . > . b2) b2?]
|
||||
[(b1 . < . b2) b1?]
|
||||
[else (and b1? b2?)]))
|
||||
(not (and a? b?))]))
|
||||
|
||||
;; ===================================================================================================
|
||||
;; Intersection
|
||||
|
||||
(: nonempty-interval-intersect (Nonempty-Interval Nonempty-Interval -> Interval))
|
||||
(define (nonempty-interval-intersect I1 I2)
|
||||
(match-define (nonempty-interval a1 b1 a1? b1?) I1)
|
||||
(match-define (nonempty-interval a2 b2 a2? b2?) I2)
|
||||
(define-values (a a?)
|
||||
(cond [(a1 . > . a2) (values a1 a1?)]
|
||||
[(a1 . < . a2) (values a2 a2?)]
|
||||
[else (values a1 (and a1? a2?))]))
|
||||
(define-values (b b?)
|
||||
(cond [(b1 . > . b2) (values b2 b2?)]
|
||||
[(b1 . < . b2) (values b1 b1?)]
|
||||
[else (values b1 (and b1? b2?))]))
|
||||
(cond [(valid-nonempty-interval? a b a? b?)
|
||||
(Nonempty-Interval a b a? b?)]
|
||||
[else
|
||||
empty-interval]))
|
||||
|
||||
;; ===================================================================================================
|
||||
;; Join
|
||||
|
||||
(begin-encourage-inline
|
||||
|
||||
(: inline-nonempty-interval-join (Float Float Boolean Boolean Float Float Boolean Boolean
|
||||
-> Nonempty-Interval))
|
||||
(define (inline-nonempty-interval-join a1 b1 a1? b1? a2 b2 a2? b2?)
|
||||
(define-values (a a?)
|
||||
(cond [(a1 . < . a2) (values a1 a1?)]
|
||||
[(a1 . > . a2) (values a2 a2?)]
|
||||
[else (values a1 (or a1? a2?))]))
|
||||
(define-values (b b?)
|
||||
(cond [(b1 . > . b2) (values b1 b1?)]
|
||||
[(b1 . < . b2) (values b2 b2?)]
|
||||
[else (values b1 (or b1? b2?))]))
|
||||
(Nonempty-Interval a b a? b?))
|
||||
|
||||
)
|
||||
|
||||
(: nonempty-interval-join (Nonempty-Interval Nonempty-Interval -> Nonempty-Interval))
|
||||
(define (nonempty-interval-join I1 I2)
|
||||
(match-define (nonempty-interval a1 b1 a1? b1?) I1)
|
||||
(match-define (nonempty-interval a2 b2 a2? b2?) I2)
|
||||
(inline-nonempty-interval-join a1 b1 a1? b1? a2 b2 a2? b2?))
|
||||
|
||||
;; ===================================================================================================
|
||||
;; Union
|
||||
|
||||
(: nonempty-interval-union (Nonempty-Interval Nonempty-Interval
|
||||
-> (Values Interval Nonempty-Interval)))
|
||||
(define (nonempty-interval-union I1 I2)
|
||||
(match-define (nonempty-interval a1 b1 a1? b1?) I1)
|
||||
(match-define (nonempty-interval a2 b2 a2? b2?) I2)
|
||||
(cond
|
||||
;; |-----| or (-----|
|
||||
;; |-----| |-----)
|
||||
[(or (a1 . > . b2) (and (= a1 b2) (not (or a1? b2?)))) (values I2 I1)]
|
||||
;; |-----| or |-----)
|
||||
;; |-----| (-----|
|
||||
[(or (b1 . < . a2) (and (= b1 a2) (not (or b1? a2?)))) (values I1 I2)]
|
||||
;; Overlapping
|
||||
[else (values empty-interval (inline-nonempty-interval-join a1 b1 a1? b1? a2 b2 a2? b2?))]))
|
||||
|
||||
;; ===================================================================================================
|
||||
;; Difference
|
||||
|
||||
(: nonempty-interval-subtract (Nonempty-Interval Nonempty-Interval
|
||||
-> (Values Interval Interval)))
|
||||
(define (nonempty-interval-subtract I1 I2)
|
||||
(match-define (nonempty-interval a1 b1 a1? b1?) I1)
|
||||
(match-define (nonempty-interval a2 b2 a2? b2?) I2)
|
||||
(cond
|
||||
;; |-----| or |-----|
|
||||
;; |-----| |-----|
|
||||
[(a1 . >= . b2) (if (and (= a1 b2) a1? b2?)
|
||||
(values empty-interval (interval a1 b1 #f b1?))
|
||||
(values empty-interval I1))]
|
||||
;; |-----| or |-----|
|
||||
;; |-----| |-----|
|
||||
[(b1 . <= . a2) (if (and (= b1 a2) b1? a2?)
|
||||
(values empty-interval (interval a1 b1 a1? #f))
|
||||
(values empty-interval I1))]
|
||||
[else
|
||||
(define I3
|
||||
(cond
|
||||
;; |------->
|
||||
;; |--------->
|
||||
[(a1 . > . a2) empty-interval]
|
||||
;; |--------->
|
||||
;; |--------->
|
||||
[(a1 . = . a2) (if (or (not a1?) a2?) empty-interval (interval a1 a1 #t #t))]
|
||||
;; |--------->
|
||||
;; |------->
|
||||
[else (interval a1 a2 a1? (not a2?))]))
|
||||
(define I4
|
||||
(cond
|
||||
;; <-------|
|
||||
;; <---------|
|
||||
[(b1 . < . b2) empty-interval]
|
||||
;; <---------|
|
||||
;; <---------|
|
||||
[(b1 . = . b2) (if (or (not b1?) b2?) empty-interval (interval b1 b1 #t #t))]
|
||||
;; <---------|
|
||||
;; <-------|
|
||||
[else (interval b2 b1 (not b2?) b1?)]))
|
||||
(cond [(empty-interval? I4) (values I4 I3)]
|
||||
[else (values I3 I4)])]))
|
||||
|
||||
;; ===================================================================================================
|
||||
|
||||
(begin-encourage-inline
|
||||
|
||||
(: interval-member? (case-> (Empty-Interval Float -> #f)
|
||||
(Interval Float -> Boolean)))
|
||||
(define (interval-member? I x)
|
||||
(cond [(empty-interval? I) #f]
|
||||
[else (nonempty-interval-member? I x)]))
|
||||
|
||||
(: interval-subset? (case-> (Interval Empty-Interval -> #t)
|
||||
(Empty-Interval Nonempty-Interval -> #f)
|
||||
(Interval Interval -> Boolean)))
|
||||
(define (interval-subset? I1 I2)
|
||||
(cond [(empty-interval? I2) #t]
|
||||
[(empty-interval? I1) #f]
|
||||
[else (nonempty-interval-subset? I1 I2)]))
|
||||
|
||||
(: interval-disjoint? (case-> (Empty-Interval Interval -> #t)
|
||||
(Interval Empty-Interval -> #t)
|
||||
(Interval Interval -> Boolean)))
|
||||
(define (interval-disjoint? I1 I2)
|
||||
(cond [(empty-interval? I1) #t]
|
||||
[(empty-interval? I2) #t]
|
||||
[else (nonempty-interval-disjoint? I1 I2)]))
|
||||
|
||||
(: interval-intersect (case-> (Empty-Interval Interval -> Empty-Interval)
|
||||
(Interval Empty-Interval -> Empty-Interval)
|
||||
(Interval Interval -> Interval)))
|
||||
(define (interval-intersect I1 I2)
|
||||
(cond [(empty-interval? I1) I1]
|
||||
[(empty-interval? I2) I2]
|
||||
[else (nonempty-interval-intersect I1 I2)]))
|
||||
|
||||
(: interval-join (case-> (Empty-Interval Empty-Interval -> Empty-Interval)
|
||||
(Interval Nonempty-Interval -> Nonempty-Interval)
|
||||
(Nonempty-Interval Interval -> Nonempty-Interval)
|
||||
(Interval Interval -> Interval)))
|
||||
(define (interval-join I1 I2)
|
||||
(cond [(empty-interval? I1) I2]
|
||||
[(empty-interval? I2) I1]
|
||||
[else (nonempty-interval-join I1 I2)]))
|
||||
|
||||
(: interval-union
|
||||
(case-> (Empty-Interval Empty-Interval -> (Values Empty-Interval Empty-Interval))
|
||||
(Empty-Interval Nonempty-Interval -> (Values Empty-Interval Nonempty-Interval))
|
||||
(Nonempty-Interval Empty-Interval -> (Values Empty-Interval Nonempty-Interval))
|
||||
(Nonempty-Interval Nonempty-Interval -> (Values Interval Nonempty-Interval))
|
||||
(Interval Interval -> (Values Interval Interval))))
|
||||
(define (interval-union I1 I2)
|
||||
(cond [(empty-interval? I1) (values I1 I2)]
|
||||
[(empty-interval? I2) (values I2 I1)]
|
||||
[else (nonempty-interval-union I1 I2)]))
|
||||
|
||||
(: interval-subtract
|
||||
(case-> (Empty-Interval Interval -> (Values Empty-Interval Empty-Interval))
|
||||
(Nonempty-Interval Empty-Interval -> (Values Empty-Interval Nonempty-Interval))
|
||||
(Interval Interval -> (Values Interval Interval))))
|
||||
(define (interval-subtract I1 I2)
|
||||
(cond [(empty-interval? I1) (values I1 I1)]
|
||||
[(empty-interval? I2) (values I2 I1)]
|
||||
[else (nonempty-interval-subtract I1 I2)]))
|
||||
|
||||
) ; begin-encourage-inline
|
||||
|
|
@ -1,115 +0,0 @@
|
|||
#lang typed/racket/base
|
||||
|
||||
(require racket/fixnum
|
||||
racket/list
|
||||
"../unsafe.rkt")
|
||||
|
||||
(provide Basis-Index
|
||||
integer->basis-index
|
||||
list->basis-index
|
||||
basis-index->list
|
||||
basis-index-degree
|
||||
basis-index+
|
||||
basis-index<)
|
||||
|
||||
(struct: basis-indexes ([degree : Natural] [list : (Listof Natural)])
|
||||
#:transparent)
|
||||
|
||||
(: integer->basis-index (Integer -> Natural))
|
||||
(define (integer->basis-index t)
|
||||
(if (t . >= . 0) t (raise-argument-error 'integer->basis-index "Natural" t)))
|
||||
|
||||
(: integer->basis-indexes (Integer -> basis-indexes))
|
||||
(define (integer->basis-indexes t)
|
||||
(cond [(t . >= . 0) (basis-indexes t (list t))]
|
||||
[else (raise-argument-error 'integer->basis-indexes "Natural" t)]))
|
||||
|
||||
(: basis-indexes+ (basis-indexes basis-indexes -> basis-indexes))
|
||||
(define (basis-indexes+ m0 m1)
|
||||
(basis-indexes
|
||||
(+ (basis-indexes-degree m0)
|
||||
(basis-indexes-degree m1))
|
||||
(let loop ([t0s (basis-indexes-list m0)]
|
||||
[t1s (basis-indexes-list m1)])
|
||||
(cond [(empty? t0s) t1s]
|
||||
[(empty? t1s) t0s]
|
||||
[else (list* (+ (first t0s) (first t1s))
|
||||
(loop (rest t0s) (rest t1s)))]))))
|
||||
|
||||
(: basis-indexes< (basis-indexes basis-indexes -> Boolean))
|
||||
(define (basis-indexes< m0 m1)
|
||||
(define d0 (basis-indexes-degree m0))
|
||||
(define d1 (basis-indexes-degree m1))
|
||||
(or (d0 . < . d1)
|
||||
(and (= d0 d1)
|
||||
(let loop ([t0s (basis-indexes-list m0)]
|
||||
[t1s (basis-indexes-list m1)])
|
||||
(cond [(empty? t0s) #f]
|
||||
[(empty? t1s) #f]
|
||||
[else
|
||||
(define t0 (first t0s))
|
||||
(define t1 (first t1s))
|
||||
(cond [(t0 . < . t1) #t]
|
||||
[(t0 . > . t1) #f]
|
||||
[else (loop (rest t0s) (rest t1s))])])))))
|
||||
|
||||
;; ===================================================================================================
|
||||
|
||||
(define-type Basis-Index-In (U Integer basis-indexes))
|
||||
(define-type Basis-Index (U Natural basis-indexes))
|
||||
|
||||
(: list->basis-index ((Listof Integer) -> Basis-Index))
|
||||
(define (list->basis-index orig-ts)
|
||||
(cond [(empty? orig-ts) 0]
|
||||
[(empty? (rest orig-ts)) (integer->basis-index (first orig-ts))]
|
||||
[else
|
||||
(let loop ([ts orig-ts]
|
||||
[#{acc : (Listof Natural)} empty]
|
||||
[#{d : Natural} 0])
|
||||
(cond [(empty? ts)
|
||||
;; Remove trailing zeros (they're in the front because `acc' is reversed)
|
||||
(let loop ([ts acc])
|
||||
(cond [(empty? ts) 0]
|
||||
[(empty? (rest ts)) (first ts)]
|
||||
[else
|
||||
(define t (first ts))
|
||||
(cond [(= t 0) (loop (rest ts))]
|
||||
[else (basis-indexes d (reverse ts))])]))]
|
||||
[else
|
||||
(define t (first ts))
|
||||
(cond [(t . < . 0) (raise-argument-error 'list->basis-index "Natural" orig-ts)]
|
||||
[else (loop (rest ts) (list* t acc) (+ d t))])]))]))
|
||||
|
||||
(: basis-index-degree (Basis-Index-In -> Natural))
|
||||
(define (basis-index-degree m)
|
||||
(cond [(basis-indexes? m) (basis-indexes-degree m)]
|
||||
[(m . < . 0) (raise-argument-error 'basis-index-degree "(U Natural basis-indexes)" m)]
|
||||
[else m]))
|
||||
|
||||
(: basis-index->list (Basis-Index-In -> (Listof Natural)))
|
||||
(define (basis-index->list m)
|
||||
(cond [(basis-indexes? m) (basis-indexes-list m)]
|
||||
[(m . < . 0) (raise-argument-error 'basis-index->list "(U Natural basis-indexes)" m)]
|
||||
[else (list m)]))
|
||||
|
||||
(: basis-index+ (Basis-Index-In Basis-Index-In -> Basis-Index))
|
||||
(define (basis-index+ m0 m1)
|
||||
(if (basis-indexes? m0)
|
||||
(if (basis-indexes? m1)
|
||||
(basis-indexes+ m0 m1)
|
||||
(basis-indexes+ m0 (integer->basis-indexes m1)))
|
||||
(if (basis-indexes? m1)
|
||||
(basis-indexes+ (integer->basis-indexes m0) m1)
|
||||
(+ (integer->basis-index m0)
|
||||
(integer->basis-index m1)))))
|
||||
|
||||
(: basis-index< (Basis-Index-In Basis-Index-In -> Boolean))
|
||||
(define (basis-index< m0 m1)
|
||||
(if (basis-indexes? m0)
|
||||
(if (basis-indexes? m1)
|
||||
(basis-indexes< m0 m1)
|
||||
(basis-indexes< m0 (integer->basis-indexes m1)))
|
||||
(if (basis-indexes? m1)
|
||||
(basis-indexes< (integer->basis-indexes m0) m1)
|
||||
(< (integer->basis-index m0)
|
||||
(integer->basis-index m1)))))
|
||||
|
|
@ -1,78 +0,0 @@
|
|||
#lang typed/racket/base
|
||||
|
||||
(require racket/list
|
||||
racket/match
|
||||
"basis-index.rkt")
|
||||
|
||||
(struct: (A) polynomial-term ([coefficient : A] [basis : Basis-Index])
|
||||
#:transparent)
|
||||
|
||||
(define-type (Polynomial-Terms A) (Listof (polynomial-term A)))
|
||||
|
||||
(struct: (A) Polynomial ([terms : (Polynomial-Terms A)])
|
||||
#:transparent)
|
||||
|
||||
(: sort-polynomial-terms (All (A) ((Polynomial-Terms A) -> (Polynomial-Terms A))))
|
||||
(define (sort-polynomial-terms ts)
|
||||
((inst sort (polynomial-term A) Basis-Index)
|
||||
ts
|
||||
basis-index<
|
||||
#:key polynomial-term-basis
|
||||
#:cache-keys? #t))
|
||||
|
||||
(: make-polynomial (All (A) ((Polynomial-Terms A) -> (Polynomial A))))
|
||||
(define (make-polynomial ts)
|
||||
(Polynomial (sort-polynomial-terms ts)))
|
||||
|
||||
(: poly+ (All (A) ((Polynomial A) (Polynomial A) (A A -> A) -> (Polynomial A))))
|
||||
(define (poly+ p0 p1 +)
|
||||
(define v0s (Polynomial-terms p0))
|
||||
(define v1s (Polynomial-terms p1))
|
||||
(Polynomial
|
||||
(let: loop : (Polynomial-Terms A) ([v0s : (Polynomial-Terms A) (Polynomial-terms p0)]
|
||||
[v1s : (Polynomial-Terms A) (Polynomial-terms p1)])
|
||||
(cond [(empty? v0s) v1s]
|
||||
[(empty? v1s) v0s]
|
||||
[else
|
||||
(define v0 (first v0s))
|
||||
(define v1 (first v1s))
|
||||
(define i0 (polynomial-term-basis v0))
|
||||
(define i1 (polynomial-term-basis v1))
|
||||
(cond [(basis-index< i0 i1) (cons v0 (loop (rest v0s) v1s))]
|
||||
[(basis-index< i1 i0) (cons v1 (loop v0s (rest v1s)))]
|
||||
[else (list* (polynomial-term
|
||||
(+ (polynomial-term-coefficient v0)
|
||||
(polynomial-term-coefficient v1)) i0)
|
||||
(loop (rest v0s) (rest v1s)))])]))))
|
||||
|
||||
(: term-cons (All (A) ((polynomial-term A) (Polynomial-Terms A) (A A -> A) -> (Polynomial-Terms A))))
|
||||
(define (term-cons t ts +)
|
||||
(define i (polynomial-term-basis t))
|
||||
(let: loop : (Polynomial-Terms A) ([ts : (Polynomial-Terms A) ts])
|
||||
(cond [(empty? ts) (list t)]
|
||||
[else
|
||||
(define t0 (first ts))
|
||||
(define i0 (polynomial-term-basis t0))
|
||||
(cond [(basis-index< i i0) (cons t ts)]
|
||||
[(basis-index< i0 i) (list* t0 (loop (rest ts)))]
|
||||
[else (list* (polynomial-term
|
||||
(+ (polynomial-term-coefficient t)
|
||||
(polynomial-term-coefficient t0)) i)
|
||||
(rest ts))])])))
|
||||
|
||||
(: poly* (All (A) ((Polynomial A) (Polynomial A) (A A -> A) (A A -> A) -> (Polynomial A))))
|
||||
(define (poly* p0 p1 + *)
|
||||
(define v0s (Polynomial-terms p0))
|
||||
(define v1s (Polynomial-terms p1))
|
||||
(Polynomial
|
||||
(let: loop0 : (Polynomial-Terms A) ([v0s : (Polynomial-Terms A) (Polynomial-terms p0)])
|
||||
(cond [(empty? v0s) empty]
|
||||
[else
|
||||
(match-define (polynomial-term c0 i0) (first v0s))
|
||||
(let: loop1 : (Polynomial-Terms A) ([v1s : (Polynomial-Terms A) (Polynomial-terms p1)])
|
||||
(cond [(empty? v1s) (loop0 (rest v0s))]
|
||||
[else
|
||||
(match-define (polynomial-term c1 i1) (first v1s))
|
||||
(define new-t (polynomial-term (* c0 c1) (basis-index+ i0 i1)))
|
||||
(define new-ts (loop1 (rest v1s)))
|
||||
(term-cons new-t new-ts +)]))]))))
|
||||
|
|
@ -1,98 +0,0 @@
|
|||
#lang typed/racket
|
||||
|
||||
(require racket/fixnum
|
||||
"chebyshev.rkt")
|
||||
|
||||
(define-syntax (do-unfold-polynomial stx)
|
||||
(syntax-case stx ()
|
||||
[(_ [(b-names ...) init-bs] unfold-proc multiply-add zero n es cs)
|
||||
(syntax/loc stx
|
||||
(let-values ([(b-names ...) init-bs])
|
||||
(let loop ([i 0] [res zero] [b-names b-names] ...)
|
||||
(cond [(i . < . n)
|
||||
(let-values ([(a b-names ...) (unfold-proc (vector-ref es i) b-names ...)])
|
||||
(loop (+ i 1) (multiply-add (vector-ref cs i) a res) b-names ...))]
|
||||
[else
|
||||
res]))))]))
|
||||
|
||||
(define-syntax (unfold-polynomial stx)
|
||||
(syntax-case stx ()
|
||||
[(_ unfolder x deg n es cs)
|
||||
(with-syntax ([([(b-names ...) init-bs] unfold-proc multiply-add zero)
|
||||
(local-expand #'(unfolder deg n x)
|
||||
(syntax-local-context)
|
||||
#f)])
|
||||
(syntax/loc stx
|
||||
(do-unfold-polynomial [(b-names ...) init-bs] unfold-proc multiply-add zero n es cs)))]))
|
||||
|
||||
(: monomial-apply ((Vectorof Integer) (Vectorof Real) -> Real))
|
||||
(define (monomial-apply es xs)
|
||||
(define n (min (vector-length es) (vector-length xs)))
|
||||
(let loop ([#{i : Nonnegative-Fixnum} 0] [#{z : Real} 1])
|
||||
(cond [(i . fx< . n)
|
||||
(define w (expt (vector-ref xs i) (vector-ref es i)))
|
||||
(with-asserts ([w real?])
|
||||
(loop (fx+ i 1) (* z w)))]
|
||||
[else z])))
|
||||
|
||||
(define-syntax (power-unfolder stx)
|
||||
(syntax-case stx ()
|
||||
[(_ deg n x)
|
||||
#'([() (values)]
|
||||
(λ (a) (expt x a))
|
||||
(λ: ([u : Real] [v : Real] [w : Real]) (+ (* u v) w))
|
||||
(ann 0 Real))]))
|
||||
|
||||
(define-syntax (lacunary-unfolder stx)
|
||||
(syntax-case stx ()
|
||||
[(_ deg n x)
|
||||
#'([() (values)]
|
||||
(λ: ([a : (Vectorof Integer)]) (monomial-apply a x))
|
||||
(λ: ([u : Real] [v : Real] [w : Real]) (+ (* u v) w))
|
||||
(ann 0 Real))]))
|
||||
|
||||
(define-syntax (chebyshev-unfolder stx)
|
||||
(syntax-case stx ()
|
||||
[(_ deg n x)
|
||||
#'([(ts) (let ()
|
||||
(define ts (ann (make-vector (+ deg 1) #f) (Vectorof (Option Real))))
|
||||
(vector-set! ts 0 1)
|
||||
(vector-set! ts 1 x)
|
||||
ts)]
|
||||
(let ()
|
||||
(: get-t (Integer (Vectorof (Option Real)) -> (Values Real (Vectorof (Option Real)))))
|
||||
(define (get-t a ts)
|
||||
(define t
|
||||
(or (vector-ref ts a)
|
||||
(let*-values ([(t-1 ts) (get-t (- a 1) ts)]
|
||||
[(t-2 ts) (get-t (- a 2) ts)]
|
||||
[(t) (- (* 2 (* x t-1)) t-2)])
|
||||
(vector-set! ts a t)
|
||||
t)))
|
||||
(values t ts))
|
||||
get-t)
|
||||
(λ: ([u : Real] [v : Real] [w : Real]) (+ (* u v) w))
|
||||
(ann 0 Real))]))
|
||||
|
||||
(define x 10)
|
||||
(define y 5)
|
||||
|
||||
(define: xs : Any
|
||||
(unfold-polynomial power-unfolder x 5 4 #(0 1 2 3) #(5 2 3 1)))
|
||||
|
||||
(define: ys : Any
|
||||
(unfold-polynomial lacunary-unfolder
|
||||
(ann (vector x y) (Vectorof Real))
|
||||
#(5 5)
|
||||
4
|
||||
(ann #(#(1 2) #(2 1) #(4 3) #(5 5)) (Vectorof (Vectorof Integer)))
|
||||
#(5 2 3 1)))
|
||||
|
||||
(define: zs : Any
|
||||
(unfold-polynomial chebyshev-unfolder
|
||||
x
|
||||
5
|
||||
4
|
||||
(ann #(0 1 3 5) (Vectorof Integer))
|
||||
#(2.55 3.1 2.1 1.1)))
|
||||
|
||||
Loading…
Reference in New Issue
Block a user