suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Added unstable/latent-contract

Browse Source 
Reorganized contracts
Started exposing customization API in plot/utils
Now dog-fooding customization API in earnest
This commit is contained in:
Neil Toronto 2011-11-01 11:38:39 -06:00
parent 6b39863f1c
commit e90ec4b69f
59 changed files with 1182 additions and 749 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
collects/plot/common/area.rkt
View File

@ -15,7 +15,8 @@
"draw.rkt"
"math.rkt"
"sample.rkt"
"parameters.rkt")
"parameters.rkt"
"legend.rkt")
(provide plot-area%)
@ -346,16 +347,16 @@
(match-define (vector x y) v)
(when outline?
(define alpha (send dc get-alpha))
;(define alpha (send dc get-alpha))
(define fg (send dc get-text-foreground))
(send dc set-alpha (alpha-expt alpha 1/8))
;(send dc set-alpha (alpha-expt alpha 1/2))
(send dc set-text-foreground (send dc get-background))
(for* ([dx (list -1 0 1)]
[dy (list -1 0 1)]
#:when (not (and (zero? dx) (zero? dy))))
(draw-text/anchor dc str (+ x dx) (+ y dy) anchor #t 0 angle))
(send dc set-alpha alpha)
;(send dc set-alpha alpha)
(send dc set-text-foreground fg))
(draw-text/anchor dc str x y anchor #t 0 angle)))
@ -607,9 +608,3 @@
(clear-clipping-rect))
)) ; end class
(struct legend-entry (label draw) #:transparent)
(provide (contract-out
(struct legend-entry ([label string?] [draw ((is-a?/c plot-area%) real? real? real? real?
. -> . void?)]))))

37
collects/plot/common/axis-transform.rkt
View File

@ -5,48 +5,35 @@
"contract.rkt"
"contract-doc.rkt")
(provide id-function
axis-transform/c
id-transform
apply-transform
make-axis-transform
axis-transform-compose
axis-transform-append
axis-transform-bound
log-transform
cbrt-transform
hand-drawn-transform
stretch-transform
collapse-transform)
(provide (all-defined-out))
(struct invertible-function (f g) #:transparent)
(provide (contract-out (struct invertible-function ([f (real? . -> . real?)]
[g (real? . -> . real?)]))))
(define (invertible-compose f1 f2)
(defproc (invertible-compose [f1 invertible-function?] [f2 invertible-function?]
) invertible-function?
(match-let ([(invertible-function f1 g1) f1]
[(invertible-function f2 g2) f2])
(invertible-function (compose f1 f2) (compose g2 g1))))
(define axis-transform/c (real? real? invertible-function? . -> . invertible-function?))
(defcontract axis-transform/c (real? real? invertible-function? . -> . invertible-function?))
(defproc (id-transform [x-min real?] [x-max real?] [old-function invertible-function?]
) invertible-function?
old-function)
(define id-function (invertible-function (λ (x) x) (λ (x) x)))
(defthing id-function invertible-function? (invertible-function (λ (x) x) (λ (x) x)))
(defproc (apply-transform [t axis-transform/c] [x-min real?] [x-max real?]) invertible-function?
(t x-min x-max id-function))
;; Turns any total, surjective, monotone flonum op and its inverse into an axis transform
(define ((make-axis-transform f g) x-min x-max old-function)
(define fx-min (f x-min))
(define fx-scale (/ (- x-max x-min) (- (f x-max) fx-min)))
(define (new-f x) (+ x-min (* (- (f x) fx-min) fx-scale)))
(define (new-g y) (g (+ fx-min (/ (- y x-min) fx-scale))))
(invertible-compose (invertible-function new-f new-g) old-function))
(defproc (make-axis-transform [f axis-transform/c] [g axis-transform/c]) axis-transform/c
(λ (x-min x-max old-function)
(define fx-min (f x-min))
(define fx-scale (/ (- x-max x-min) (- (f x-max) fx-min)))
(define (new-f x) (+ x-min (* (- (f x) fx-min) fx-scale)))
(define (new-g y) (g (+ fx-min (/ (- y x-min) fx-scale))))
(invertible-compose (invertible-function new-f new-g) old-function)))
;; ===================================================================================================
;; Axis transform combinators

15
collects/plot/common/contract-doc-stx.rkt
View File

@ -1,15 +0,0 @@
#lang racket/base
(require syntax/parse)
(provide (all-defined-out))
(struct proc+doc (proc-transformer doc-transformer)
#:property prop:procedure (λ (p stx) ((proc+doc-proc-transformer p) stx)))
(define-syntax-class argument-spec
#:description "argument specification"
(pattern [name:id contract:expr])
(pattern [name:id contract:expr default:expr])
(pattern [kw:keyword name:id contract:expr])
(pattern [kw:keyword name:id contract:expr default:expr]))

241
collects/plot/common/contract-doc.rkt
View File

@ -2,33 +2,23 @@
;; Definitions with contracts and contract documentation.
(require racket/contract
(for-syntax racket/base racket/list syntax/parse
"serialize-syntax.rkt"
"contract-doc-stx.rkt")
(require racket/contract unstable/latent-contract racket/provide
(for-syntax racket/base racket/list racket/syntax syntax/parse racket/provide-transform
"serialize-syntax.rkt")
(prefix-in s. scribble/manual)
(prefix-in s. scribble/core)
(prefix-in s. scribble/html-properties))
(provide defproc defparam defthing defcontract doc-apply)
(define-for-syntax (make-proc+doc id-stx doc-transformer)
(proc+doc
(λ (stx)
(syntax-case stx ()
[(_ . args) (quasisyntax/loc stx (#,id-stx . args))]
[_ (quasisyntax/loc stx #,id-stx)]))
doc-transformer))
;; Applies the documentation transformer (use within a scribble/manual module)
(define-syntax (doc-apply stx)
(define (error) (raise-syntax-error 'doc-apply "no associated doc transformer" stx))
(syntax-parse stx
[(_ name:id . pre-flows)
(define p (syntax-local-value #'name error))
(when (not (proc+doc? p)) (error))
((proc+doc-doc-transformer p) (syntax/loc stx (name . pre-flows)))]))
(provide defthing defproc defparam defcontract
only-doc-out doc-apply)
(begin-for-syntax
(define-syntax-class argument-spec
#:description "argument specification"
(pattern [name:id contract:expr])
(pattern [name:id contract:expr default:expr])
(pattern [kw:keyword name:id contract:expr])
(pattern [kw:keyword name:id contract:expr default:expr])))
;; A define-with-value form for scribble documentation
(define (def/value def val . pre-flows)
@ -73,21 +63,76 @@
[else (substring name-str 0 1)]))
(datum->syntax name-stx (string->symbol arg-name-str)))
(define-for-syntax (make-value-name id-stx)
(datum->syntax #f (syntax->datum id-stx)))
(define-for-syntax (make-doc-name ctx id-stx)
(datum->syntax ctx (syntax->datum id-stx)))
;; ===================================================================================================
;; define-with-contract+doc forms
;; Forms to define things with a contract and documentation
;; Define a thing, optionally documenting the value of the thing
(define-syntax (defthing stx)
(syntax-parse stx
[(_ name:id contract:expr #:document-value value:expr)
(with-syntax ([name:doc (format-id #'name "~a:doc" #'name)]
[serialized-contract (serialize-syntax #'contract)]
[serialized-value (serialize-syntax #'value)])
(syntax/loc stx
(begin
(define/latent-contract name contract value)
(define-syntax (name:doc doc-stx)
(syntax-case doc-stx ()
[(ctx . pre-flows)
(with-syntax ([doc-name (datum->syntax #'ctx (syntax-e #'name))]
[doc-contract (unserialize-syntax #'ctx 'serialized-contract)]
[doc-value (unserialize-syntax #'ctx 'serialized-value)])
(syntax/loc doc-stx
(def/value
(s.defthing doc-name doc-contract)
(s.racketblock doc-value)
. pre-flows)))])))))]
[(_ name:id contract:expr value:expr)
(with-syntax ([name:doc (format-id #'name "~a:doc" #'name)]
[serialized-contract (serialize-syntax #'contract)])
(syntax/loc stx
(begin
(define/latent-contract name contract value)
(define-syntax (name:doc doc-stx)
(syntax-case doc-stx ()
[(ctx . pre-flows)
(with-syntax ([doc-name (datum->syntax #'ctx (syntax-e #'name))]
[doc-contract (unserialize-syntax #'ctx 'serialized-contract)])
(syntax/loc doc-stx
(s.defthing doc-name doc-contract . pre-flows)))])))))]))
;; Define a procedure
(define-syntax (defproc stx)
(syntax-parse stx
[(_ (name:id arg:argument-spec ...) result:expr #:document-body body ...+)
(define arg-list (syntax->list #'(arg ...)))
(with-syntax ([name:doc (format-id #'name "~a:doc" #'name)]
[(new-arg ...) (append* (map remove-contract arg-list))]
[(req-contract ...) (append* (map get-required-contract arg-list))]
[(opt-contract ...) (append* (map get-optional-contract arg-list))]
[serialized-args (serialize-syntax #'(arg ...))]
[serialized-result (serialize-syntax #'result)]
[serialized-body (serialize-syntax #'(body ...))])
(syntax/loc stx
(begin
(define/latent-contract (name new-arg ...) (->* (req-contract ...) (opt-contract ...)
result)
body ...)
(define-syntax (name:doc doc-stx)
(syntax-case doc-stx ()
[(ctx . pre-flows)
(with-syntax ([doc-name (datum->syntax #'ctx (syntax-e #'name))]
[doc-args (unserialize-syntax #'ctx 'serialized-args)]
[doc-result (unserialize-syntax #'ctx 'serialized-result)]
[doc-body (unserialize-syntax #'ctx 'serialized-body)])
(syntax/loc doc-stx
(def/value
(s.defproc (doc-name . doc-args) doc-result)
(s.racketblock . doc-body)
. pre-flows)))])))))]
[(_ (name:id arg:argument-spec ...) result:expr body ...+)
(define arg-list (syntax->list #'(arg ...)))
(with-syntax ([value-name (make-value-name #'name)]
(with-syntax ([name:doc (format-id #'name "~a:doc" #'name)]
[(new-arg ...) (append* (map remove-contract arg-list))]
[(req-contract ...) (append* (map get-required-contract arg-list))]
[(opt-contract ...) (append* (map get-optional-contract arg-list))]
@ -95,112 +140,68 @@
[serialized-result (serialize-syntax #'result)])
(syntax/loc stx
(begin
(define/contract (value-name new-arg ...) (->* (req-contract ...) (opt-contract ...)
result)
(define/latent-contract (name new-arg ...) (->* (req-contract ...) (opt-contract ...)
result)
body ...)
(define-syntax name
(make-proc+doc
#'value-name
(λ (doc-stx)
(syntax-case doc-stx ()
[(ctx . pre-flows)
(with-syntax ([doc-name (make-doc-name #'ctx #'name)]
[doc-args (unserialize-syntax #'ctx 'serialized-args)]
[doc-result (unserialize-syntax #'ctx 'serialized-result)])
#'(s.defproc (doc-name . doc-args) doc-result . pre-flows))])))))))]))
(define-syntax (name:doc doc-stx)
(syntax-case doc-stx ()
[(ctx . pre-flows)
(with-syntax ([doc-name (datum->syntax #'ctx (syntax-e #'name))]
[doc-args (unserialize-syntax #'ctx 'serialized-args)]
[doc-result (unserialize-syntax #'ctx 'serialized-result)])
(syntax/loc doc-stx
(s.defproc (doc-name . doc-args) doc-result . pre-flows)))])))))]))
;; Define a parameter
(define-syntax (defparam stx)
(syntax-parse stx
[(_ name:id arg:id contract:expr default:expr)
(with-syntax ([value-name (make-value-name #'name)]
(with-syntax ([name:doc (format-id #'name "~a:doc" #'name)]
[serialized-contract (serialize-syntax #'contract)]
[serialized-default (serialize-syntax #'default)])
(syntax/loc stx
(begin
(define/contract value-name (parameter/c contract) (make-parameter default))
(define-syntax name
(make-proc+doc
#'value-name
(λ (doc-stx)
(syntax-case doc-stx ()
[(ctx . pre-flows)
(with-syntax ([doc-name (make-doc-name #'ctx #'name)]
[doc-arg (make-doc-name #'ctx #'arg)]
[doc-contract (unserialize-syntax #'ctx 'serialized-contract)]
[doc-default (unserialize-syntax #'ctx 'serialized-default)])
#'(def/value
(s.defparam doc-name doc-arg doc-contract)
(s.racketblock doc-default)
. pre-flows))])))))))]
(define/latent-contract name (parameter/c contract) (make-parameter default))
(define-syntax (name:doc doc-stx)
(syntax-case doc-stx ()
[(ctx . pre-flows)
(with-syntax ([doc-name (datum->syntax #'ctx (syntax-e #'name))]
[doc-arg (datum->syntax #'ctx (syntax-e #'arg))]
[doc-contract (unserialize-syntax #'ctx 'serialized-contract)]
[doc-default (unserialize-syntax #'ctx 'serialized-default)])
#'(def/value
(s.defparam doc-name doc-arg doc-contract)
(s.racketblock doc-default)
. pre-flows))])))))]
[(_ name:id contract:expr default:expr)
(quasisyntax/loc stx
(defparam name #,(parameter-name->arg-name #'name) contract default))]))
(define-syntax (defthing stx)
(syntax-parse stx
[(_ name:id contract:expr value:expr)
(with-syntax ([value-name (make-value-name #'name)]
[serialized-contract (serialize-syntax #'contract)])
(syntax/loc stx
(begin
(define/contract value-name contract value)
(define-syntax name
(make-proc+doc
#'value-name
(λ (doc-stx)
(syntax-case doc-stx ()
[(ctx . pre-flows)
(with-syntax ([doc-name (make-doc-name #'ctx #'name)]
[doc-contract (unserialize-syntax #'ctx 'serialized-contract)])
#'(s.defthing doc-name doc-contract . pre-flows))])))))))]))
;; Define a contract or a procedure that returns a contract
(define-syntax (defcontract stx)
(syntax-parse stx
[(_ name:id value:expr)
(with-syntax ([value-name (make-value-name #'name)]
[serialized-value (serialize-syntax #'value)])
(syntax/loc stx
(begin
(define value-name value)
(define-syntax name
(make-proc+doc
#'value-name
(λ (doc-stx)
(syntax-case doc-stx ()
[(ctx . pre-flows)
(with-syntax ([doc-name (make-doc-name #'ctx #'name)]
[doc-contract? (make-doc-name #'ctx #'contract?)]
[doc-value (unserialize-syntax #'ctx 'serialized-value)])
#'(def/value
(s.defthing doc-name doc-contract?)
(s.racketblock doc-value)
. pre-flows))])))))))]
(syntax/loc stx (defthing name contract? #:document-value value))]
[(_ (name:id arg:argument-spec ...) body)
(define arg-list (syntax->list #'(arg ...)))
(with-syntax ([value-name (make-value-name #'name)]
[(new-arg ...) (append* (map remove-contract arg-list))]
[(req-contract ...) (append* (map get-required-contract arg-list))]
[(opt-contract ...) (append* (map get-optional-contract arg-list))]
[serialized-args (serialize-syntax #'(arg ...))]
[serialized-body (serialize-syntax #'body)])
(syntax/loc stx
(begin
(define/contract (value-name new-arg ...) (->* (req-contract ...) (opt-contract ...)
contract?)
body)
(define-syntax name
(make-proc+doc
#'value-name
(λ (doc-stx)
(syntax-case doc-stx (doc)
[(ctx . pre-flows)
(with-syntax ([doc-name (make-doc-name #'ctx #'name)]
[doc-contract? (make-doc-name #'ctx #'contract?)]
[doc-args (unserialize-syntax #'ctx 'serialized-args)]
[doc-body (unserialize-syntax #'ctx 'serialized-body)])
#'(def/value
(s.defproc (doc-name . doc-args) doc-contract?)
(s.racketblock doc-body)
. pre-flows))])))))))]))
(syntax/loc stx (defproc (name arg ...) contract? #:document-body body))]))
;; ===================================================================================================
;; Getting documentation
(define-syntax only-doc-out
(make-provide-pre-transformer
(λ (stx modes)
(syntax-case stx ()
[(_ provide-spec)
(pre-expand-export
(syntax/loc stx
(matching-identifiers-out #rx".*:doc$" provide-spec))
modes)]))))
;; Applies the documentation transformer (use within a scribble/manual module)
(define-syntax (doc-apply stx)
(syntax-parse stx
[(_ name:id . pre-flows)
(with-syntax ([name:doc (format-id #'name "~a:doc" #'name)])
(syntax-protect
(syntax/loc stx (name:doc . pre-flows))))]))

7
collects/plot/common/contract.rkt
View File

@ -1,9 +1,10 @@
#lang racket/base
(require racket/contract racket/draw racket/class
(require racket/contract racket/draw racket/class unstable/latent-contract
"contract-doc.rkt")
(provide (all-defined-out))
(provide (except-out (all-defined-out) treeof)
(activate-contract-out treeof))
;; ===================================================================================================
;; Convenience
@ -36,7 +37,7 @@
(defcontract font-family/c (one-of/c 'default 'decorative 'roman 'script 'swiss
'modern 'symbol 'system))
(define known-point-symbols
(defthing known-point-symbols (listof symbol?) #:document-value
'(dot point pixel
plus times asterisk 5asterisk
odot oplus otimes oasterisk o5asterisk

20
collects/plot/common/date-time.rkt
View File

@ -8,16 +8,7 @@
"math.rkt"
"format.rkt")
(provide seconds-per-minute
seconds-per-hour
seconds-per-day
seconds-per-week
avg-seconds-per-year
avg-seconds-per-month
utc-seconds-round-month
utc-seconds-round-year
plot-date-formatter
plot-time-formatter)
(provide (all-defined-out))
(define seconds-per-minute 60)
(define seconds-per-hour (* 60 seconds-per-minute))
@ -78,12 +69,7 @@
(struct plot-time (second minute hour day) #:transparent)
(provide (contract-out (struct plot-time ([second (and/c (>=/c 0) (</c 60))]
[minute (integer-in 0 59)]
[hour (integer-in 0 23)]
[day exact-integer?]))))
(define (seconds->plot-time s)
(defproc (seconds->plot-time [s real?]) plot-time?
(let* ([s (inexact->exact s)]
[day (floor (/ s seconds-per-day))]
[s (- s (* day seconds-per-day))]
@ -93,7 +79,7 @@
[s (- s (* minute seconds-per-minute))])
(plot-time s minute hour day)))
(define (plot-time->seconds t)
(defproc (plot-time->seconds [t plot-time?]) real?
(match-define (plot-time second minute hour day) t)
(+ second
(* minute seconds-per-minute)

15
collects/plot/common/draw.rkt
View File

@ -58,7 +58,7 @@
(define (color%? c) (is-a? c color%))
(define (->color c)
(defproc (->color [c color/c]) (list/c real? real? real?)
(match c
[(? color%?) (list (send c red) (send c green) (send c blue))]
[(? string?) (define color (send the-color-database find-color c))
@ -82,7 +82,7 @@
(160 32 240) ; magenta
(160 160 160))) ; gray
(define (->pen-color c)
(defproc (->pen-color [c plot-color/c]) (list/c real? real? real?)
(cond [(exact-integer? c) (vector-ref pen-colors (remainder (abs c) 8))]
[else (->color c)]))
@ -96,11 +96,11 @@
(240 224 255) ; magenta
(212 212 212))) ; gray
(define (->brush-color c)
(defproc (->brush-color [c plot-color/c]) (list/c real? real? real?)
(cond [(exact-integer? c) (vector-ref brush-colors (remainder (abs c) 8))]
[else (->color c)]))
(define (->pen-style s)
(defproc (->pen-style [s plot-pen-style/c]) symbol?
(cond [(exact-integer? s) (case (remainder (abs s) 5)
[(0) 'solid]
[(1) 'dot]
@ -110,7 +110,7 @@
[(symbol? s) s]
[else (raise-type-error '->pen-style "symbol or integer" s)]))
(define (->brush-style s)
(defproc (->brush-style [s plot-brush-style/c]) symbol?
(cond [(exact-integer? s) (case (remainder (abs s) 7)
[(0) 'solid]
[(1) 'bdiagonal-hatch]
@ -146,9 +146,10 @@
(map list rs gs bs)))
;; Returns an alpha value b such that, if
(define (alpha-expt a n)
(defproc (alpha-expt [a (real-in 0 1)] [n (>/c 0)]) real?
(- 1 (expt (- 1 a) n)))
(define (maybe-apply/list list-or-proc xs)
(defproc (maybe-apply/list [list-or-proc (or/c (listof any/c) (any/c . -> . any/c))]
[xs (listof any/c)]) (listof any/c)
(cond [(procedure? list-or-proc) (list-or-proc xs)]
[else list-or-proc]))

27
collects/plot/common/format.rkt
View File

@ -7,10 +7,7 @@
"contract-doc.rkt"
"math.rkt")
(provide integer->superscript
real->decimal-string* real->string/trunc
digits-for-range real->plot-label ->plot-label
parse-format-string apply-formatter)
(provide (all-defined-out))
(define (string-map f str)
(list->string (map f (string->list str))))
@ -68,13 +65,6 @@
(remove-trailing-zeros (format "~a.~a" fst rst))
(integer->superscript (sub1 n)))]))
#;
(begin
(require rackunit)
(check-equal? (int-str->e-str "") "0")
(check-equal? (int-str->e-str "0") "0")
(check-equal? (int-str->e-str "10") "1×10\u00b9"))
(define (frac-str->e-str str)
(define n (string-length str))
(let loop ([i 0])
@ -87,15 +77,6 @@
[else
(format "~a.~a×10~a" fst rst (integer->superscript (- (add1 i))))])])))
#;
(begin
(require rackunit)
(check-equal? (frac-str->e-str "") "0")
(check-equal? (frac-str->e-str "0") "0")
(check-equal? (frac-str->e-str "00") "0")
(check-equal? (frac-str->e-str "1") "1×10\u207b\u00b9")
(check-equal? (frac-str->e-str "01") "1×10\u207b\u00b2"))
(define (zero-string n)
(list->string (build-list n (λ _ #\0))))
@ -179,9 +160,9 @@
(loop (+ i 2) (cons (string->symbol (substring str i (+ i 2))) fmt-list))]
[else (loop (+ i 1) (cons (substring str i (+ i 1)) fmt-list))])))
(define (apply-formatter [formatter (symbol? . -> . (or/c string? #f))]
[fmt-list (listof (or/c string? symbol?))]
[d any/c]) (listof string?)
(defproc (apply-formatter [formatter (symbol? . -> . (or/c string? #f))]
[fmt-list (listof (or/c string? symbol?))]
[d any/c]) (listof string?)
(for/list ([fmt (in-list fmt-list)])
(cond [(eq? fmt '~~) "~"]
[(symbol? fmt) (let ([val (formatter fmt d)])

75
collects/plot/common/legend.rkt
View File

@ -3,24 +3,31 @@
;; Functions that create legend entries and lists of legend entries.
(require racket/class racket/match racket/list racket/string racket/sequence racket/contract
"contract.rkt"
"contract-doc.rkt"
"format.rkt"
"draw.rkt"
"utils.rkt"
"area.rkt")
"utils.rkt")
(provide (all-defined-out))
(struct legend-entry (label draw) #:transparent)
;; ===================================================================================================
;; Line legends
(define (line-legend-entry label color width style)
(defproc (line-legend-entry [label string?]
[color plot-color/c] [width (>=/c 0)] [style plot-pen-style/c]
) legend-entry?
(legend-entry label (λ (plot-area x-min x-max y-min y-max)
(define y (* 1/2 (+ y-min y-max)))
(send plot-area set-pen color width style)
(send plot-area set-alpha 1)
(send plot-area draw-line (vector x-min y) (vector x-max y)))))
(define (line-legend-entries label zs z-labels colors widths styles)
(defproc (line-legend-entries [label string?] [zs (listof real?)] [z-labels (listof string?)]
[colors plot-colors/c] [widths pen-widths/c] [styles plot-pen-styles/c]
) (listof legend-entry?)
(define hash
(for/fold ([hash empty]) ([z (in-list zs)]
[z-label (in-list z-labels)]
@ -33,22 +40,27 @@
(for/list ([entry (in-list hash)])
(match-define (cons args vs) entry)
(apply line-legend-entry
(if (= 1 (length vs))
(format "~a = ~a" label (first vs))
(format "~a ∈ {~a}" label (string-join (reverse vs) ",")))
(cond [(= 1 (length vs)) (format "~a = ~a" label (first vs))]
[else (format "~a ∈ {~a}" label (string-join (reverse vs) ","))])
args))))
;; ===================================================================================================
;; Rectangle legends
(define (rectangle-legend-entry label fill-color fill-style line-color line-width line-style)
(defproc (rectangle-legend-entry [label string?]
[fill-color plot-color/c] [fill-style plot-brush-style/c]
[line-color plot-color/c] [line-width (>=/c 0)]
[line-style plot-pen-style/c]) legend-entry?
(legend-entry label (λ (plot-area x-min x-max y-min y-max)
(send plot-area set-brush fill-color fill-style)
(send plot-area set-pen line-color line-width line-style)
(send plot-area set-alpha 1)
(send plot-area draw-rectangle (vector x-min y-min) (vector x-max y-max)))))
(define (rectangle-legend-entries label zs fill-colors fill-styles line-colors line-widths line-styles)
(defproc (rectangle-legend-entries [label string?] [zs (listof real?)]
[fill-colors plot-colors/c] [fill-styles plot-brush-styles/c]
[line-colors plot-colors/c] [line-widths pen-widths/c]
[line-styles plot-pen-styles/c]) (listof legend-entry?)
(define z-min (first zs))
(define z-max (last zs))
(define digits (digits-for-range z-min z-max))
@ -73,9 +85,13 @@
;; ===================================================================================================
;; Interval legends
(define (interval-legend-entry label fill-color fill-style line-color line-width line-style
line1-color line1-width line1-style
line2-color line2-width line2-style)
(defproc (interval-legend-entry
[label string?]
[fill-color plot-color/c] [fill-style plot-brush-style/c]
[line-color plot-color/c] [line-width (>=/c 0)] [line-style plot-pen-style/c]
[line1-color plot-color/c] [line1-width (>=/c 0)] [line1-style plot-pen-style/c]
[line2-color plot-color/c] [line2-width (>=/c 0)] [line2-style plot-pen-style/c]
) legend-entry?
(legend-entry label (λ (plot-area x-min x-max y-min y-max)
(send plot-area set-alpha 1)
;; rectangle
@ -89,15 +105,18 @@
(send plot-area set-pen line2-color line2-width line2-style)
(send plot-area draw-line (vector x-min y-min) (vector x-max y-min)))))
(define (interval-legend-entries label zs labels fill-colors fill-styles
line-colors line-widths line-styles
line1-colors line1-widths line1-styles
line2-colors line2-widths line2-styles)
(defproc (interval-legend-entries
[label string?] [zs (listof real?)] [z-labels (listof string?)]
[fill-colors plot-colors/c] [fill-styles plot-brush-styles/c]
[line-colors plot-colors/c] [line-widths pen-widths/c] [line-styles plot-pen-styles/c]
[line1-colors plot-colors/c] [line1-widths pen-widths/c] [line1-styles plot-pen-styles/c]
[line2-colors plot-colors/c] [line2-widths pen-widths/c] [line2-styles plot-pen-styles/c]
) (listof legend-entry?)
(define hash
(for/fold ([hash empty]) ([za (in-list zs)]
[zb (in-list (rest zs))]
[la (in-list labels)]
[lb (in-list (rest labels))]
[la (in-list z-labels)]
[lb (in-list (rest z-labels))]
[fill-color (in-cycle (maybe-apply/list fill-colors zs))]
[fill-style (in-cycle (maybe-apply/list fill-styles zs))]
[line-color (in-cycle (maybe-apply/list line-colors zs))]
@ -128,9 +147,12 @@
line1-color line1-width line1-style
line2-color line2-width line2-style))))
(define (contour-intervals-legend-entries label zs labels
fill-colors fill-styles line-colors line-widths line-styles
contour-colors contour-widths contour-styles)
(defproc (contour-intervals-legend-entries
[label string?] [zs (listof real?)] [z-labels (listof string?)]
[fill-colors plot-colors/c] [fill-styles plot-brush-styles/c]
[line-colors plot-colors/c] [line-widths pen-widths/c] [line-styles plot-pen-styles/c]
[contour-colors plot-colors/c] [contour-widths pen-widths/c]
[contour-styles plot-pen-styles/c]) (listof legend-entry?)
(define n (- (length zs) 2))
(define ccs (append (list 0)
(sequence-take (in-cycle (maybe-apply/list contour-colors zs)) 0 n)
@ -142,22 +164,25 @@
(sequence-take (in-cycle (maybe-apply/list contour-styles zs)) 0 n)
'(transparent)))
(interval-legend-entries label zs labels
(interval-legend-entries label zs z-labels
fill-colors fill-styles line-colors line-widths line-styles
ccs cws css (rest ccs) (rest cws) (rest css)))
;; ===================================================================================================
;; Point legends
(define (point-legend-entry label symbol color size line-width)
(defproc (point-legend-entry [label string?] [sym point-sym/c]
[color plot-color/c] [size (>=/c 0)] [line-width (>=/c 0)]) legend-entry?
(legend-entry label (λ (plot-area x-min x-max y-min y-max)
(send plot-area set-pen color line-width 'solid)
(send plot-area set-alpha 1)
(send plot-area draw-glyphs
(list (vector (* 1/2 (+ x-min x-max)) (* 1/2 (+ y-min y-max))))
symbol size))))
sym size))))
(define (vector-field-legend-entry label color line-width line-style)
(defproc (vector-field-legend-entry [label string?] [color plot-color/c]
[line-width (>=/c 0)] [line-style plot-pen-style/c]
) legend-entry?
(legend-entry label (λ (plot-area x-min x-max y-min y-max)
(send plot-area set-pen color line-width line-style)
(send plot-area set-alpha 1)

17
collects/plot/common/marching-squares.rkt
View File

@ -1,10 +1,12 @@
#lang racket/base
(require racket/flonum racket/fixnum racket/list racket/match racket/unsafe/ops
(require racket/flonum racket/fixnum racket/list racket/match racket/unsafe/ops racket/contract
(for-syntax racket/base)
"math.rkt")
"math.rkt"
"contract-doc.rkt")
(provide heights->lines heights->polys)
(provide heights->lines heights->polys
heights->lines:doc heights->polys:doc)
;; Returns the interpolated distance of z from za toward zb
;; Examples: if z = za, this returns 0.0
@ -141,7 +143,9 @@ above.
(let ([id (exact->inexact id)] ...)
body0 body ...))
(define (heights->lines xa xb ya yb z z1 z2 z3 z4)
(defproc (heights->lines [xa real?] [xb real?] [ya real?] [yb real?]
[z real?] [z1 real?] [z2 real?] [z3 real?] [z4 real?]
) (list/c (vector/c real? real? real?) (vector/c real? real? real?))
(check-all-real! 'heights->lines xa xb ya yb z z1 z2 z3 z4)
(let-exact->inexact
(xa xb ya yb z z1 z2 z3 z4)
@ -585,7 +589,10 @@ above.
polys2210 polys2211 polys2212
polys2220 polys2221 polys2222))
(define (heights->polys xa xb ya yb za zb z1 z2 z3 z4)
(defproc (heights->polys [xa real?] [xb real?] [ya real?] [yb real?]
[za real?] [zb real?]
[z1 real?] [z2 real?] [z3 real?] [z4 real?]
) (listof (vector/c real? real? real?))
(check-all-real! xa xb ya yb za zb z1 z2 z3 z4)
(let-exact->inexact
(xa xb ya yb za zb z1 z2 z3 z4)

106
collects/plot/common/math.rkt
View File

@ -3,37 +3,38 @@
(require racket/contract racket/unsafe/ops
"contract-doc.rkt")
(provide (all-defined-out))
;; ===================================================================================================
;; Flonums
(provide nan? infinite? special? flblend flatan2 flsum flmodulo fldistance)
(defproc (nan? [x any/c]) boolean?
(eqv? x +nan.0))
(define (nan? x) (eqv? x +nan.0))
(define (infinite? x)
(defproc (infinite? [x any/c]) boolean?
(and (flonum? x) (or (unsafe-fl= x +inf.0) (unsafe-fl= x -inf.0))))
(define (special? x)
(defproc (special? [x any/c]) boolean?
(and (flonum? x) (or (unsafe-fl= x +inf.0) (unsafe-fl= x -inf.0) (eqv? x +nan.0))))
(define (flblend x y α)
(defproc (flblend [x flonum?] [y flonum?] [α flonum?]) flonum?
(cond [(not (flonum? x)) (raise-type-error 'flblend "flonum" 0 x y α)]
[(not (flonum? y)) (raise-type-error 'flblend "flonum" 1 x y α)]
[(not (flonum? α)) (raise-type-error 'flblend "flonum" 2 x y α)]
[else (unsafe-fl+ (unsafe-fl* α x) (unsafe-fl* (unsafe-fl- 1 α) y))]))
(define (flatan2 y x)
(defproc (flatan2 [y flonum?] [x flonum?]) flonum?
(cond [(not (flonum? y)) (raise-type-error 'flatan2 "flonum" 0 x y)]
[(not (flonum? x)) (raise-type-error 'flatan2 "flonum" 1 x y)]
[else (exact->inexact (atan2 y x))]))
(define (flsum f xs)
(defproc (flsum [f (any/c . -> . flonum?)] [xs (listof any/c)]) flonum?
(define ys (map f xs))
(cond [(not (andmap flonum? ys)) (raise-type-error 'sum "any -> flonum" f)]
[else (for/fold ([sum 0.0]) ([y (in-list ys)])
(unsafe-fl+ sum y))]))
(define (flmodulo x y)
(defproc (flmodulo [x flonum?] [y flonum?]) flonum?
(cond [(not (flonum? x)) (raise-type-error 'real-modulo "flonum" 0 x y)]
[(not (flonum? y)) (raise-type-error 'real-modulo "flonum" 1 x y)]
[else (unsafe-fl- x (unsafe-fl* y (unsafe-flfloor (unsafe-fl/ x y))))]))
@ -56,20 +57,15 @@
;; ===================================================================================================
;; Reals
(provide regular? equal?* min* max*
degrees->radians radians->degrees
blend atan2 sum real-modulo distance
floor-log/base ceiling-log/base
polar->cartesian 3d-polar->3d-cartesian)
(define (regular? x) (and (real? x) (not (special? x))))
(defproc (regular? [x any/c]) boolean?
(and (real? x) (not (special? x))))
(define equal?*
(case-lambda
[() #t]
[(x) #t]
[xs (and (equal? (car xs) (cadr xs))
(equal?* (cdr xs)))]))
(apply equal?* (cdr xs)))]))
(define-syntax-rule (min2* x y)
(cond [(x . < . y) x]
@ -110,32 +106,32 @@
(define 180/pi (/ 180 pi))
(define pi/180 (/ pi 180))
(define (degrees->radians d)
(defproc (degrees->radians [d real?]) real?
(cond [(not (real? d)) (raise-type-error 'degrees->radians "real number" d)]
[else (* d pi/180)]))
(define (radians->degrees r)
(defproc (radians->degrees [r real?]) real?
(cond [(not (real? r)) (raise-type-error 'radians->degrees "real number" r)]
[else (* r 180/pi)]))
(define (blend x y α)
(defproc (blend [x real?] [y real?] [α real?]) real?
(cond [(not (real? x)) (raise-type-error 'blend "real number" 0 x y α)]
[(not (real? y)) (raise-type-error 'blend "real number" 1 x y α)]
[(not (real? α)) (raise-type-error 'blend "real number" 2 x y α)]
[else (+ (* α x) (* (- 1 α) y))]))
(define (atan2 y x)
(defproc (atan2 [y real?] [x real?]) real?
(cond [(not (real? y)) (raise-type-error 'atan2 "real number" 0 y x)]
[(not (real? x)) (raise-type-error 'atan2 "real number" 1 y x)]
[(and (zero? y) (zero? x)) 0]
[else (atan y x)]))
(define (sum f xs)
(defproc (sum [f (any/c . -> . real?)] [xs (listof any/c)]) real?
(define ys (map f xs))
(cond [(not (andmap real? ys)) (raise-type-error 'sum "any -> real" f)]
[else (apply + ys)]))
(define (real-modulo x y)
(defproc (real-modulo [x real?] [y real?]) real?
(cond [(not (real? x)) (raise-type-error 'real-modulo "real number" 0 x y)]
[(not (real? y)) (raise-type-error 'real-modulo "real number" 1 x y)]
[else (- x (* y (floor (/ x y))))]))
@ -154,7 +150,7 @@
[xs (cond [(not (andmap real? xs)) (raise-type-error 'distance "real numbers" xs)]
[else (sqrt (sum sqr xs))])]))
(define (floor-log/base b x)
(defproc (floor-log/base [b (and/c exact-integer? (>=/c 2))] [x (>/c 0)]) exact-integer?
(cond [(not (and (exact-integer? b) (b . >= . 2))) (raise-type-error 'floor-log/base
"exact integer >= 2" 0 b x)]
[(not (and (real? x) (x . > . 0))) (raise-type-error 'floor-log/base "real > 0" 1 b x)]
@ -166,13 +162,13 @@
[else y]))]
[else y])]))
(define (ceiling-log/base b x)
(defproc (ceiling-log/base [b (and/c exact-integer? (>=/c 2))] [x (>/c 0)]) exact-integer?
(cond [(not (and (exact-integer? b) (b . >= . 2))) (raise-type-error 'floor-log/base
"exact integer >= 2" 0 b x)]
[(not (and (real? x) (x . > . 0))) (raise-type-error 'floor-log/base "real > 0" 1 b x)]
[else (inexact->exact (ceiling (/ (log (abs x)) (log b))))]))
(define (polar->cartesian θ r)
(defproc (polar->cartesian [θ real?] [r real?]) (vector/c real? real?)
(cond [(not (real? θ)) (raise-type-error 'polar->cartesian "real number" 0 θ r)]
[(not (real? r)) (raise-type-error 'polar->cartesian "real number" 1 θ r)]
[else (let ([θ (exact->inexact θ)]
@ -180,7 +176,7 @@
(vector (unsafe-fl* r (unsafe-flcos θ))
(unsafe-fl* r (unsafe-flsin θ))))]))
(define (3d-polar->3d-cartesian θ ρ r)
(defproc (3d-polar->3d-cartesian [θ real?] [ρ real?] [r real?]) (vector/c real? real? real?)
(cond [(not (real? θ)) (raise-type-error '3d-polar->3d-cartesian "real number" 0 θ ρ r)]
[(not (real? ρ)) (raise-type-error '3d-polar->3d-cartesian "real number" 1 θ ρ r)]
[(not (real? r)) (raise-type-error '3d-polar->3d-cartesian "real number" 2 θ ρ r)]
@ -195,10 +191,8 @@
;; ===================================================================================================
;; Vectors
(provide vcross v+ v- vneg v* v/ vmag^2 vmag vnormalize vdot vregular? v= vcenter
vregular-sublists vnormal)
(define (vcross v1 v2)
(defproc (vcross [v1 (vector/c real? real? real?)] [v2 (vector/c real? real? real?)]
) (vector/c real? real? real?)
(match v1
[(vector (? real? x1) (? real? y1) (? real? z1))
(match v2
@ -253,21 +247,26 @@
[_ (raise-type-error name "vector of 3 reals" 1 v1 v2)])]
[_ (vmap2 name f v1 v2)]))
(define (v+ v1 v2) (unrolled-vmap2 'v+ + v1 v2))
(define (v- v1 v2) (unrolled-vmap2 'v- - v1 v2))
(define (vneg v) (unrolled-vmap 'vneg - v))
(defproc (v+ [v1 (vectorof real?)] [v2 (vectorof real?)]) (vectorof real?)
(unrolled-vmap2 'v+ + v1 v2))
(define (v* v c)
(defproc (v- [v1 (vectorof real?)] [v2 (vectorof real?)]) (vectorof real?)
(unrolled-vmap2 'v- - v1 v2))
(defproc (vneg [v (vectorof real?)]) (vectorof real?)
(unrolled-vmap 'vneg - v))
(defproc (v* [v (vectorof real?)] [c real?]) (vectorof real?)
(cond [(real? c) (define-syntax-rule (f x) (* x c))
(unrolled-vmap 'v* f v)]
[else (raise-type-error 'v* "real" 1 v c)]))
(define (v/ v c)
(defproc (v/ [v (vectorof real?)] [c real?]) (vectorof real?)
(cond [(real? c) (define-syntax-rule (f x) (/ x c))
(unrolled-vmap 'v/ f v)]
[else (raise-type-error 'v/ "real" 1 v c)]))
(define (vmag^2 v)
(defproc (vmag^2 [v (vectorof real?)]) real?
(match v
[(vector (? real? x) (? real? y)) (+ (* x x) (* y y))]
[(vector (? real? x) (? real? y) (? real? z)) (+ (* x x) (* y y) (* z z))]
@ -277,17 +276,19 @@
(+ mag (cond [(real? x) (* x x)]
[else (raise-type-error 'vmag^2 "vector of reals" v)])))]))
(define (vmag v) (sqrt (vmag^2 v)))
(defproc (vmag [v (vectorof real?)]) real?
(sqrt (vmag^2 v)))
(define (vnormalize v)
(defproc (vnormalize [v (vectorof real?)]) (vectorof real?)
(match v
[(vector (? real? x) (? real? y)) (define m (sqrt (+ (* x x) (* y y))))
(vector (/ x m) (/ y m))]
(if (= m 0) v (vector (/ x m) (/ y m)))]
[(vector (? real? x) (? real? y) (? real? z)) (define m (sqrt (+ (* x x) (* y y) (* z z))))
(vector (/ x m) (/ y m) (/ z m))]
[_ (v/ v (vmag v))]))
(if (= m 0) v (vector (/ x m) (/ y m) (/ z m)))]
[_ (define m (vmag v))
(if (= m 0) v (v/ v m))]))
(define (vdot v1 v2)
(defproc (vdot [v1 (vectorof real?)] [v2 (vectorof real?)]) real?
(match v1
[(vector (? real? x1) (? real? y1))
(match v2
@ -312,7 +313,7 @@
(define-syntax-rule (unsafe-flregular? x)
(not (unsafe-flspecial? x)))
(define (vregular? v)
(defproc (vregular? [v (vectorof real?)]) boolean?
(match v
[(vector (? real? x) (? real? y))
(cond [(flonum? x) (unsafe-flregular? x)]
@ -329,7 +330,7 @@
(break #f)))
#t)]))
(define (v= v1 v2)
(defproc (v= [v1 (vectorof real?)] [v2 (vectorof real?)]) boolean?
(match v1
[(vector (? real? x1) (? real? y1))
(match v2
@ -350,7 +351,7 @@
(raise-type-error 'v= "vector of real" 0 v1 v2)))
#t)]))
(define (vcenter vs)
(defproc (vcenter [vs (listof (vectorof real?))]) (vectorof real?)
(match vs
[(list (vector xs ys) ...)
(define mins (vector (apply min* xs) (apply min* ys)))
@ -485,22 +486,9 @@
[x2 (in-list (rest xs))])
(ivl x1 x2))]))
(provide
(contract-out (struct ivl ([min (or/c real? #f)] [max (or/c real? #f)]))
[ivl-meet (->* () () #:rest (listof ivl?) ivl?)]
[ivl-join (->* () () #:rest (listof ivl?) ivl?)])
empty-ivl unknown-ivl ivl-inexact->exact bounds->intervals
ivl-empty? ivl-known? ivl-regular? ivl-singular? ivl-zero-length? ivl-contains?)
;; ===================================================================================================
;; Rectangles
(provide
empty-rect unknown-rect bounding-rect rect-inexact->exact
rect-empty? rect-known? rect-regular? rect-zero-area? rect-singular? rect-contains?
(contract-out [rect-meet (->* () () #:rest (listof (vectorof ivl?)) (vectorof ivl?))]
[rect-join (->* () () #:rest (listof (vectorof ivl?)) (vectorof ivl?))]))
(define vector-andmap
(case-lambda
[(f v) (let/ec break

102
collects/plot/common/parameters.rkt
View File

@ -2,7 +2,7 @@
;; Parameters that control the look and behavior of plots.
(require racket/contract unstable/parameter-group
(require racket/contract unstable/parameter-group unstable/latent-contract
"contract.rkt"
"contract-doc.rkt"
"draw.rkt"
@ -43,6 +43,8 @@
(defparam plot-x-max-ticks exact-positive-integer? 5)
(defparam plot-y-max-ticks exact-positive-integer? 5)
(defparam plot-z-max-ticks exact-positive-integer? 8)
(defparam plot-d-max-ticks exact-positive-integer? 5)
(defparam plot-r-max-ticks exact-positive-integer? 8)
(defparam plot-x-far-max-ticks exact-positive-integer? 5)
(defparam plot-y-far-max-ticks exact-positive-integer? 5)
@ -51,44 +53,35 @@
(defparam plot-decorations? boolean? #t)
(define-parameter-group plot-axes?
(plot-x-axis?
plot-y-axis?
plot-z-axis?
plot-x-far-axis?
plot-y-far-axis?
plot-z-far-axis?)
(plot-x-axis? plot-x-far-axis?
plot-y-axis? plot-y-far-axis?
plot-z-axis? plot-z-far-axis?)
#:struct list)
(define-parameter-group plot-max-ticks
(plot-x-max-ticks
plot-y-max-ticks
plot-z-max-ticks
plot-x-far-max-ticks
plot-y-far-max-ticks
plot-z-far-max-ticks)
(plot-x-max-ticks plot-x-far-max-ticks
plot-y-max-ticks plot-y-far-max-ticks
plot-z-max-ticks plot-z-far-max-ticks
plot-d-max-ticks
plot-r-max-ticks)
#:struct list)
(define-parameter-group plot-appearance
(plot-width
plot-height
plot-foreground
plot-background
plot-foreground-alpha
plot-background-alpha
plot-line-width
plot-tick-size
plot-font-size
plot-font-family
plot-legend-anchor
plot-legend-box-alpha
plot-axes?
plot-max-ticks
plot-decorations?
plot-foreground plot-foreground-alpha
plot-background plot-background-alpha
plot-line-width plot-tick-size
plot-font-size plot-font-family
plot-legend-anchor plot-legend-box-alpha
plot-axes? plot-max-ticks plot-decorations?
plot-animating?))
(define (pen-gap) (* 2 (plot-line-width)))
(defproc (pen-gap) real? #:document-body
(* 2 (plot-line-width)))
(defproc (animated-samples [samples (and/c exact-integer? (>=/c 2))]) (and/c exact-integer? (>=/c 2))
(defproc (animated-samples [samples (and/c exact-integer? (>=/c 2))]
) (and/c exact-integer? (>=/c 2)) #:document-body
(cond [(plot-animating?) (max 2 (ceiling (* 1/4 samples)))]
[else samples]))
@ -138,38 +131,56 @@
(defparam plot-x-transform axis-transform/c id-transform)
(defparam plot-y-transform axis-transform/c id-transform)
(defparam plot-z-transform axis-transform/c id-transform)
(defparam plot-d-transform axis-transform/c id-transform)
(defparam plot-r-transform axis-transform/c id-transform)
(defparam plot-x-ticks ticks? (linear-ticks))
(defparam plot-y-ticks ticks? (linear-ticks))
(defparam plot-z-ticks ticks? (linear-ticks))
(defparam plot-d-ticks ticks? (linear-ticks))
(defparam plot-r-ticks ticks? (linear-ticks))
(defparam plot-x-far-ticks ticks? (ticks-mimic plot-x-ticks))
(defparam plot-y-far-ticks ticks? (ticks-mimic plot-y-ticks))
(defparam plot-z-far-ticks ticks? (ticks-mimic plot-z-ticks))
(struct axis (transform ticks far-ticks) #:transparent)
(struct axis (transform ticks) #:transparent)
(define-parameter-group plot-d-axis (plot-d-transform plot-d-ticks) #:struct axis)
(define-parameter-group plot-r-axis (plot-r-transform plot-r-ticks) #:struct axis)
(define-parameter-group plot-x-axis (plot-x-transform plot-x-ticks plot-x-far-ticks) #:struct axis)
(define-parameter-group plot-y-axis (plot-y-transform plot-y-ticks plot-y-far-ticks) #:struct axis)
(define-parameter-group plot-z-axis (plot-z-transform plot-z-ticks plot-z-far-ticks) #:struct axis)
(define-parameter-group plot-axes (plot-x-axis plot-y-axis plot-z-axis) #:struct list)
(struct dual-axis (transform ticks far-ticks) #:transparent)
(define-parameter-group plot-x-axis (plot-x-transform plot-x-ticks plot-x-far-ticks)
#:struct dual-axis)
(define-parameter-group plot-y-axis (plot-y-transform plot-y-ticks plot-y-far-ticks)
#:struct dual-axis)
(define-parameter-group plot-z-axis (plot-z-transform plot-z-ticks plot-z-far-ticks)
#:struct dual-axis)
(defproc (default-x-ticks [x-min real?] [x-max real?]) (listof tick?)
(define-parameter-group plot-axes (plot-x-axis plot-y-axis plot-z-axis plot-d-axis plot-r-axis)
#:struct list)
(defproc (default-x-ticks [x-min real?] [x-max real?]) (listof tick?) #:document-body
((plot-x-ticks) x-min x-max (plot-x-max-ticks)))
(defproc (default-y-ticks [y-min real?] [y-max real?]) (listof tick?)
(defproc (default-y-ticks [y-min real?] [y-max real?]) (listof tick?) #:document-body
((plot-y-ticks) y-min y-max (plot-y-max-ticks)))
(defproc (default-z-ticks [z-min real?] [z-max real?]) (listof tick?)
(defproc (default-z-ticks [z-min real?] [z-max real?]) (listof tick?) #:document-body
((plot-z-ticks) z-min z-max (plot-z-max-ticks)))
(defproc (default-x-far-ticks [x-min real?] [x-max real?]) (listof tick?)
(defproc (default-d-ticks [d-min real?] [d-max real?]) (listof tick?) #:document-body
((plot-d-ticks) d-min d-max (plot-d-max-ticks)))
(defproc (default-r-ticks [r-min real?] [r-max real?]) (listof tick?) #:document-body
((plot-r-ticks) r-min r-max (plot-r-max-ticks)))
(defproc (default-x-far-ticks [x-min real?] [x-max real?]) (listof tick?) #:document-body
((plot-x-far-ticks) x-min x-max (plot-x-far-max-ticks)))
(defproc (default-y-far-ticks [y-min real?] [y-max real?]) (listof tick?)
(defproc (default-y-far-ticks [y-min real?] [y-max real?]) (listof tick?) #:document-body
((plot-y-far-ticks) y-min y-max (plot-y-far-max-ticks)))
(defproc (default-z-far-ticks [z-min real?] [z-max real?]) (listof tick?)
(defproc (default-z-far-ticks [z-min real?] [z-max real?]) (listof tick?) #:document-body
((plot-z-far-ticks) z-min z-max (plot-z-far-max-ticks)))
;; ===================================================================================================
@ -231,11 +242,11 @@
;; Contours
(defproc (default-contour-colors [zs (listof real?)]) (listof plot-color/c)
(defproc (default-contour-colors [zs (listof real?)]) (listof plot-color/c) #:document-body
(color-seq* (list (->pen-color 5) (->pen-color 0) (->pen-color 1))
(length zs)))
(defproc (default-contour-fill-colors [zs (listof real?)]) (listof plot-color/c)
(defproc (default-contour-fill-colors [zs (listof real?)]) (listof plot-color/c) #:document-body
(color-seq* (list (->brush-color 5) (->brush-color 0) (->brush-color 1))
(sub1 (length zs))))
@ -265,10 +276,12 @@
(defparam x-axis-ticks? boolean? #t)
(defparam y-axis-ticks? boolean? #t)
(defparam z-axis-ticks? boolean? #t)
(defparam polar-axes-ticks? boolean? #t)
(defparam x-axis-labels? boolean? #f)
(defparam y-axis-labels? boolean? #f)
(defparam z-axis-labels? boolean? #f)
(defparam polar-axes-labels? boolean? #t)
(defparam x-axis-far? boolean? #f)
(defparam y-axis-far? boolean? #f)
@ -277,10 +290,9 @@
(defparam x-axis-alpha (real-in 0 1) 1)
(defparam y-axis-alpha (real-in 0 1) 1)
(defparam z-axis-alpha (real-in 0 1) 1)
(defparam polar-axes-alpha (real-in 0 1) 1/2)
(defparam polar-axes-number exact-positive-integer? 12)
(defparam polar-axes-ticks? boolean? #t)
(defparam polar-axes-max-ticks exact-positive-integer? 8)
(defparam label-anchor anchor/c 'left)
(defparam label-angle real? 0)
@ -304,11 +316,11 @@
;; Isosurfaces
(defproc (default-isosurface-colors [zs (listof real?)]) (listof plot-color/c)
(defproc (default-isosurface-colors [zs (listof real?)]) (listof plot-color/c) #:document-body
(color-seq* (list (->brush-color 5) (->brush-color 0) (->brush-color 1))
(length zs)))
(defproc (default-isosurface-line-colors [zs (listof real?)]) (listof plot-color/c)
(defproc (default-isosurface-line-colors [zs (listof real?)]) (listof plot-color/c) #:document-body
(color-seq* (list (->pen-color 5) (->pen-color 0) (->pen-color 1))
(length zs)))

98
collects/plot/common/plot-element.rkt
View File

@ -2,6 +2,7 @@
(require racket/list racket/contract racket/match
"math.rkt"
"ticks.rkt"
"contract.rkt"
"contract-doc.rkt"
"parameters.rkt"
@ -14,58 +15,69 @@
(struct renderer2d plot-element (render-proc) #:transparent)
(struct renderer3d plot-element (render-proc) #:transparent)
(defcontract bounds-fun/c ((vectorof ivl?) . -> . (vectorof ivl?)))
(defcontract ticks-fun/c ((vectorof ivl?) . -> . any))
;; ===================================================================================================
;; Common field values
(define (default-ticks-fun r)
(match r
[(vector (ivl xa xb) (ivl ya yb))
(values (default-x-ticks xa xb) (default-x-far-ticks xa xb)
(default-y-ticks ya yb) (default-y-far-ticks ya yb))]
[(vector (ivl xa xb) (ivl ya yb) (ivl za zb))
(values (default-x-ticks xa xb) (default-x-far-ticks xa xb)
(default-y-ticks ya yb) (default-y-far-ticks ya yb)
(defthing default-ticks-fun ticks-fun/c
(λ (r)
(match r
[(vector (ivl xa xb) (ivl ya yb))
(values (default-x-ticks xa xb) (default-x-far-ticks xa xb)
(default-y-ticks ya yb) (default-y-far-ticks ya yb))]
[(vector (ivl xa xb) (ivl ya yb) (ivl za zb))
(values (default-x-ticks xa xb) (default-x-far-ticks xa xb)
(default-y-ticks ya yb) (default-y-far-ticks ya yb)
(default-z-ticks za zb) (default-z-far-ticks za zb))]
[_ (raise-type-error 'default-ticks-fun "2- or 3-vector of ivl" r)]))
[_ (raise-type-error 'default-ticks-fun "2- or 3-vector of ivl" r)])))
(define ((function-bounds-fun f samples) r)
(match-define (vector xi yi) r)
(cond [(ivl-known? xi)
(match-define (ivl x-min x-max) xi)
(match-define (list xs ys) (f x-min x-max samples))
(define rys (filter regular? ys))
(cond [(not (empty? rys)) (vector xi (ivl (apply min* rys) (apply max* rys)))]
[else r])]
[else r]))
(defproc (function-bounds-fun [f sampler/c] [samples exact-nonnegative-integer?]) bounds-fun/c
(λ (r)
(match-define (vector xi yi) r)
(cond [(ivl-known? xi)
(match-define (ivl x-min x-max) xi)
(match-define (list xs ys) (f x-min x-max samples))
(define rys (filter regular? ys))
(cond [(not (empty? rys)) (vector xi (ivl (apply min* rys) (apply max* rys)))]
[else r])]
[else r])))
(define ((inverse-bounds-fun f samples) r)
(match-define (vector xi yi) r)
(cond [(ivl-known? yi)
(match-define (ivl y-min y-max) yi)
(match-define (list ys xs) (f y-min y-max samples))
(define rxs (filter regular? xs))
(cond [(not (empty? rxs)) (vector (ivl (apply min* rxs) (apply max* rxs)) yi)]
[else r])]
[else r]))
(defproc (inverse-bounds-fun [f sampler/c] [samples exact-nonnegative-integer?]) bounds-fun/c
(λ (r)
(match-define (vector xi yi) r)
(cond [(ivl-known? yi)
(match-define (ivl y-min y-max) yi)
(match-define (list ys xs) (f y-min y-max samples))
(define rxs (filter regular? xs))
(cond [(not (empty? rxs)) (vector (ivl (apply min* rxs) (apply max* rxs)) yi)]
[else r])]
[else r])))
(define ((function-interval-bounds-fun f1 f2 samples) r)
(rect-join ((function-bounds-fun f1 samples) r)
((function-bounds-fun f2 samples) r)))
(defproc (function-interval-bounds-fun [f1 sampler/c] [f2 sampler/c]
[samples exact-nonnegative-integer?]) bounds-fun/c
(λ (r)
(rect-join ((function-bounds-fun f1 samples) r)
((function-bounds-fun f2 samples) r))))
(define ((inverse-interval-bounds-fun f1 f2 samples) r)
(rect-join ((inverse-bounds-fun f1 samples) r)
((inverse-bounds-fun f2 samples) r)))
(defproc (inverse-interval-bounds-fun [f1 sampler/c] [f2 sampler/c]
[samples exact-nonnegative-integer?]) bounds-fun/c
(λ (r)
(rect-join ((inverse-bounds-fun f1 samples) r)
((inverse-bounds-fun f2 samples) r))))
(define ((surface3d-bounds-fun f samples) r)
(match-define (vector xi yi zi) r)
(cond [(and (ivl-known? xi) (ivl-known? yi))
(match-define (ivl x-min x-max) xi)
(match-define (ivl y-min y-max) yi)
(match-define (list xs ys zss) (f x-min x-max samples y-min y-max samples))
(define zs (filter regular? (2d-sample->list zss)))
(cond [(not (empty? zs)) (vector xi yi (ivl (apply min* zs) (apply max* zs)))]
[else r])]
[else r]))
(defproc (surface3d-bounds-fun [f 2d-sampler/c] [samples exact-nonnegative-integer?]) bounds-fun/c
(λ (r)
(match-define (vector xi yi zi) r)
(cond [(and (ivl-known? xi) (ivl-known? yi))
(match-define (ivl x-min x-max) xi)
(match-define (ivl y-min y-max) yi)
(match-define (list xs ys zss) (f x-min x-max samples y-min y-max samples))
(define zs (filter regular? (2d-sample->list zss)))
(cond [(not (empty? zs)) (vector xi yi (ivl (apply min* zs) (apply max* zs)))]
[else r])]
[else r])))
;; ===================================================================================================
;; Fixpoint computation of bounding rectangles

140
collects/plot/common/sample.rkt
View File

@ -9,7 +9,7 @@
(provide (all-defined-out))
(define (build-linear-seq start step num)
(defproc (build-linear-seq [start real?] [step real?] [num exact-nonnegative-integer?]) (listof real?)
(for/list ([n (in-range num)])
(+ start (* n step))))
@ -49,6 +49,13 @@
(blend (vector-ref pts (add1 i)) (vector-ref pts i) f)))
int-parts frac-parts)))
(defproc (nonlinear-seq [start real?] [end real?] [num exact-nonnegative-integer?]
[transform axis-transform/c]
[#:start? start? boolean? #t]
[#:end? end? boolean? #t]) (listof real?)
(match-define (invertible-function _ finv) (apply-transform transform start end))
(map finv (linear-seq start end num #:start? start? #:end? end?)))
(struct mapped-function (f fmap) #:transparent
#:property prop:procedure
(λ (g x) ((mapped-function-f g) x)))
@ -60,85 +67,80 @@
[(? mapped-function?) ((mapped-function-fmap f) xs)]
[_ (map f xs)]))
(defproc (nonlinear-seq [start real?] [end real?] [num exact-nonnegative-integer?]
[transform axis-transform/c]
[#:start? start? boolean? #t]
[#:end? end? boolean? #t]) (listof real?)
(match-define (invertible-function _ finv) (apply-transform transform start end))
(map finv (linear-seq start end num #:start? start? #:end? end?)))
;; ===================================================================================================
;; Making memoized samplers
(define 2pi (* 2 pi))
(defcontract sample/c (list/c (listof real?) (listof real?)))
(defcontract sampler/c (real? real? exact-nonnegative-integer? . -> . sample/c))
(define ((2d-polar->3d-function f) x y z)
(let ([x (exact->inexact x)]
[y (exact->inexact y)]
[z (exact->inexact z)])
(define-values (θ ρ)
(cond [(and (fl= x 0.0) (fl= y 0.0)) (values 0.0 0.0)]
[else (values (flmodulo (flatan2 y x) 2pi)
(flatan (fl/ z (distance x y))))]))
(define r (exact->inexact (f θ ρ)))
(fl- r (distance x y z))))
(defcontract 2d-sample/c (list/c (listof real?) (listof real?)
(vectorof (vectorof real?))))
(defcontract 2d-sampler/c (real? real? exact-nonnegative-integer?
real? real? exact-nonnegative-integer?
. -> . 2d-sample/c))
(define (sample-parametric f t-min t-max samples)
(map* f (linear-seq t-min t-max samples)))
(defcontract 3d-sample/c (list/c (listof real?) (listof real?) (listof real?)
(vectorof (vectorof (vectorof real?)))))
(defcontract 3d-sampler/c (real? real? exact-nonnegative-integer?
real? real? exact-nonnegative-integer?
real? real? exact-nonnegative-integer?
. -> . 3d-sample/c))
(define (sample-polar f θ-min θ-max samples)
(define θs (linear-seq θ-min θ-max samples))
(define rs (map* f θs))
(map polar->cartesian θs rs))
(defproc (make-function->sampler [transform-thnk (-> axis-transform/c)]
) ((real? . -> . real?) . -> . sampler/c)
(λ (f)
(define memo (make-hash))
(λ (x-min x-max x-samples)
(define tx (transform-thnk))
(hash-ref! memo (vector x-min x-max x-samples tx)
(λ ()
(define xs (nonlinear-seq x-min x-max x-samples tx))
(list xs (map* f xs)))))))
(define (sample-2d-polar f θ-min θ-max θ-samples ρ-min ρ-max ρ-samples)
(for*/list ([θ (in-list (linear-seq θ-min θ-max θ-samples))]
[ρ (in-list (linear-seq ρ-min ρ-max ρ-samples))])
(3d-polar->3d-cartesian θ ρ (f θ ρ))))
(defproc (make-2d-function->sampler [transform-x-thnk (-> axis-transform/c)]
[transform-y-thnk (-> axis-transform/c)]
) ((real? real? . -> . real?) . -> . 2d-sampler/c)
(λ (f)
(define memo (make-hash))
(λ (x-min x-max x-samples y-min y-max y-samples)
(define tx (transform-x-thnk))
(define ty (transform-y-thnk))
(hash-ref! memo (vector x-min x-max x-samples tx y-min y-max y-samples ty)
(λ ()
(define xs (nonlinear-seq x-min x-max x-samples tx))
(define ys (nonlinear-seq y-min y-max y-samples ty))
(list xs ys (for/vector #:length y-samples ([y (in-list ys)])
(for/vector #:length x-samples ([x (in-list xs)])
(f x y)))))))))
(define ((make-function->sampler transform-thnk) f)
(define memo (make-hash))
(λ (x-min x-max x-samples)
(define tx (transform-thnk))
(hash-ref! memo (vector x-min x-max x-samples tx)
(λ ()
(define xs (nonlinear-seq x-min x-max x-samples tx))
(list xs (map* f xs))))))
(defproc (make-3d-function->sampler [transform-x-thnk (-> axis-transform/c)]
[transform-y-thnk (-> axis-transform/c)]
[transform-z-thnk (-> axis-transform/c)]
) ((real? real? real? . -> . real?) . -> . 3d-sampler/c)
(λ (f)
(define memo (make-hash))
(λ (x-min x-max x-samples y-min y-max y-samples z-min z-max z-samples)
(define tx (transform-x-thnk))
(define ty (transform-y-thnk))
(define tz (transform-z-thnk))
(hash-ref! memo (vector x-min x-max x-samples tx
y-min y-max y-samples ty
z-min z-max z-samples tz)
(λ ()
(define xs (nonlinear-seq x-min x-max x-samples tx))
(define ys (nonlinear-seq y-min y-max y-samples ty))
(define zs (nonlinear-seq z-min z-max z-samples tz))
(list xs ys zs (for/vector #:length z-samples ([z (in-list zs)])
(for/vector #:length y-samples ([y (in-list ys)])
(for/vector #:length x-samples ([x (in-list xs)])
(f x y z))))))))))
(define ((make-2d-function->sampler transform-x-thnk transform-y-thnk) f)
(define memo (make-hash))
(λ (x-min x-max x-samples y-min y-max y-samples)
(define tx (transform-x-thnk))
(define ty (transform-y-thnk))
(hash-ref! memo (vector x-min x-max x-samples tx y-min y-max y-samples ty)
(λ ()
(define xs (nonlinear-seq x-min x-max x-samples tx))
(define ys (nonlinear-seq y-min y-max y-samples ty))
(list xs ys (for/vector #:length y-samples ([y (in-list ys)])
(for/vector #:length x-samples ([x (in-list xs)])
(f x y))))))))
(define ((make-3d-function->sampler transform-x-thnk transform-y-thnk transform-z-thnk) f)
(define memo (make-hash))
(λ (x-min x-max x-samples y-min y-max y-samples z-min z-max z-samples)
(define tx (transform-x-thnk))
(define ty (transform-y-thnk))
(define tz (transform-z-thnk))
(hash-ref! memo (vector x-min x-max x-samples tx
y-min y-max y-samples ty
z-min z-max z-samples tz)
(λ ()
(define xs (nonlinear-seq x-min x-max x-samples tx))
(define ys (nonlinear-seq y-min y-max y-samples ty))
(define zs (nonlinear-seq z-min z-max z-samples tz))
(list xs ys zs (for/vector #:length z-samples ([z (in-list zs)])
(for/vector #:length y-samples ([y (in-list ys)])
(for/vector #:length x-samples ([x (in-list xs)])
(f x y z)))))))))
(define (2d-sample->list zss)
(defproc (2d-sample->list [zss (vectorof (vectorof real?))]) (listof real?)
(for*/list ([zs (in-vector zss)]
[z (in-vector zs)])
z))
(define (3d-sample->list dsss)
(defproc (3d-sample->list [dsss (vectorof (vectorof (vectorof real?)))]) (listof real?)
(for*/list ([dss (in-vector dsss)]
[ds (in-vector dss)]
[d (in-vector ds)])

56
collects/plot/custom.rkt → collects/plot/common/samplers.rkt
View File

@ -1,48 +1,26 @@
#lang racket/base
(require racket/contract racket/match racket/list
"common/contract-doc.rkt"
"common/format.rkt"
;"common/math.rkt"
;"common/contract.rkt"
;"common/format.rkt"
;"common/plot-element.rkt"
;"common/area.rkt"
;"common/axis-transform.rkt"
;"common/utils.rkt"
;"common/marching-squares.rkt"
;"common/marching-cubes.rkt"
;"plot2d/clip.rkt"
;"plot3d/clip.rkt"
)
;; Functions that sample from functions, and functions that create memoized samplers.
(require "common/ticks.rkt")
(provide (all-from-out "common/ticks.rkt"))
(require "common/parameters.rkt")
(provide (all-from-out "common/parameters.rkt"))
(require "common/sample.rkt")
(provide (all-from-out "common/sample.rkt"))
(require "common/draw.rkt")
(provide maybe-apply/list)
(require "common/legend.rkt")
(provide (all-from-out "common/legend.rkt"))
(require "common/plot-element.rkt")
(provide (all-from-out "common/plot-element.rkt"))
(require "common/marching-squares.rkt")
(provide (all-from-out "common/marching-squares.rkt"))
(require racket/match racket/flonum racket/math racket/contract racket/list
"parameters.rkt"
"sample.rkt"
"ticks.rkt"
"format.rkt"
"contract-doc.rkt")
(provide (all-defined-out))
(define function->sampler (make-function->sampler plot-x-transform))
(define inverse->sampler (make-function->sampler plot-y-transform))
(define 2d-function->sampler (make-2d-function->sampler plot-x-transform plot-y-transform))
(define 3d-function->sampler
(defthing function->sampler ((real? . -> . real?) . -> . sampler/c)
(make-function->sampler plot-x-transform))
(defthing inverse->sampler ((real? . -> . real?) . -> . sampler/c)
(make-function->sampler plot-y-transform))
(defthing 2d-function->sampler ((real? real? . -> . real?) . -> . 2d-sampler/c)
(make-2d-function->sampler plot-x-transform plot-y-transform))
(defthing 3d-function->sampler ((real? real? real? . -> . real?) . -> . 3d-sampler/c)
(make-3d-function->sampler plot-x-transform plot-y-transform plot-z-transform))
(defproc (contour-ticks [z-min real?] [z-max real?]

62
collects/plot/common/ticks.rkt
View File

@ -13,31 +13,7 @@
"date-time.rkt"
"currency.rkt")
(provide ;(struct-out pre-tick) (struct-out tick) (struct-out ticks)
ticks-layout/c ticks-format/c
;; No ticks
no-ticks-layout no-ticks
;; Linear ticks
linear-ticks-layout linear-ticks-format linear-ticks
;; Log-scale ticks
log-ticks-layout log-ticks-format log-ticks
;; Date ticks
date-ticks-formats 24h-descending-date-ticks-formats 12h-descending-date-ticks-formats
date-ticks-layout date-ticks-format date-ticks
;; Time ticks
time-ticks-formats descending-time-ticks-formats
time-ticks-layout time-ticks-format time-ticks
;; Bit/byte ticks
bit/byte-ticks-format bit/byte-ticks
;; Currency ticks and formats
currency-ticks-scales us-currency-scales uk-currency-scales eu-currency-scales
currency-ticks-formats us-currency-formats uk-currency-formats eu-currency-formats
currency-ticks-layout currency-ticks-format currency-ticks
;; Fractions
fraction-ticks-format fraction-ticks
;; Combinators
ticks-mimic ticks-scale ticks-add linear-scale
)
(provide (all-defined-out))
(struct pre-tick (value major?) #:transparent)
(struct tick pre-tick (label) #:transparent)
@ -56,10 +32,6 @@
(defcontract ticks-format/c
(real? real? (listof pre-tick?) . -> . (listof string?)))
(provide (contract-out (struct pre-tick ([value real?] [major? boolean?]))
(struct (tick pre-tick) ([value real?] [major? boolean?] [label string?]))
(struct ticks ([layout ticks-layout/c] [format ticks-format/c]))))
;; ===================================================================================================
;; Helpers
@ -223,39 +195,43 @@
(break step)))
#f)))
(define (count-unchanging-fields formatter fmt-list xs)
(define (count-changing-fields formatter fmt-list xs)
(let ([fmt-list (filter symbol? fmt-list)])
(define formatted-dates (for/list ([x (in-list xs)])
(apply-formatter formatter fmt-list x)))
(count equal?* (transpose formatted-dates))))
(count (λ (fields) (not (apply equal?* fields)))
(transpose formatted-dates))))
;; Find the shortest format string that has the maximum number of changing fields
(define (choose-format-list formatter fmt-lists xs)
(let ([fmt-lists (sort fmt-lists >
(let ([fmt-lists (sort fmt-lists <
#:key (λ (fmt-list) (count symbol? fmt-list))
#:cache-keys? #t)])
(argmin (λ (fmt-list) (count-unchanging-fields formatter fmt-list xs))
(argmax (λ (fmt-list) (count-changing-fields formatter fmt-list xs))
fmt-lists)))
;; ===================================================================================================
;; Date ticks
(define 12h-descending-date-ticks-formats
'("~Y-~m-~d ~I:~M:~f~p"
"~Y-~m-~d ~I:~M~p"
"~Y-~m-~d ~I~p"
'("~Y-~m-~d ~I:~M:~f ~p"
"~Y-~m-~d ~I:~M ~p"
"~Y-~m-~d ~I ~p"
"~Y-~m-~d"
"~Y-~m"
"~Y"
"~m-~d ~I:~M:~f~p"
"~m-~d ~I:~M~p"
"~m-~d ~I~p"
"~m-~d ~I:~M:~f ~p"
"~m-~d ~I:~M ~p"
"~m-~d ~I ~p"
"~m-~d"
"~I:~M:~f~p"
"~I:~M~p"
"~I:~M:~f ~p"
"~I:~M ~p"
"~I ~p"
"~M:~fs"
"~Mm"
"~fs"))
@ -274,8 +250,10 @@
"~H:~M:~f"
"~H:~M"
"~Hh"
"~M:~fs"
"~Mm"
"~fs"))
@ -375,7 +353,7 @@
"~H:~M"
"~Hh"
"~M:~f"
"~M:~fs"
"~Mm"
"~fs"))

21
collects/plot/compat.rkt
View File

@ -3,6 +3,7 @@
;; A compatibility module for the old 'plot'.
(require racket/contract racket/class racket/snip racket/draw racket/vector
unstable/latent-contract
;; Plotting
"common/contract.rkt"
"common/contract-doc.rkt"
@ -22,12 +23,14 @@
;; Miscellaneous
"deprecated/math.rkt")
(provide mix plot-color?
plot plot3d
points vector-field error-bars
line
contour shade
surface
(provide mix
(activate-contract-out plot-color?
plot plot3d
points vector-field error-bars
line
contour shade
surface)
(only-doc-out (all-defined-out))
;; Curve fitting
(rename-out [fit-int fit])
(struct-out fit-result)
@ -81,7 +84,8 @@
[new.plot-background bgcolor])
(define bm (make-bitmap (ceiling width) (ceiling height)))
(define dc (make-object bitmap-dc% bm))
(define area (make-object 2d-plot-area% x-ticks y-ticks x-min x-max y-min y-max
(define area (make-object 2d-plot-area% x-ticks x-ticks y-ticks y-ticks
x-min x-max y-min y-max
dc 0 0 width height))
(send area start-plot)
@ -124,7 +128,8 @@
(define bm (make-bitmap (ceiling width) (ceiling height)))
(define dc (make-object bitmap-dc% bm))
(define area
(make-object 3d-plot-area% x-ticks y-ticks z-ticks x-min x-max y-min y-max z-min z-max
(make-object 3d-plot-area% x-ticks x-ticks y-ticks y-ticks z-ticks z-ticks
x-min x-max y-min y-max z-min z-max
dc 0 0 width height))
(send area start-plot)

20
collects/plot/contracted/axis-transform.rkt Normal file
View File

@ -0,0 +1,20 @@
#lang racket/base
(require racket/contract unstable/latent-contract)
(require "../common/axis-transform.rkt")
(provide (contract-out (struct invertible-function ([f (real? . -> . real?)]
[g (real? . -> . real?)])))
(activate-contract-out id-function
axis-transform/c
id-transform
apply-transform
make-axis-transform
axis-transform-compose
axis-transform-append
axis-transform-bound
log-transform
cbrt-transform
hand-drawn-transform
stretch-transform
collapse-transform))

11
collects/plot/contracted/date-time.rkt Normal file
View File

@ -0,0 +1,11 @@
#lang racket/base
(require racket/contract unstable/latent-contract)
(require "../common/date-time.rkt")
(provide (contract-out (struct plot-time ([second (and/c (>=/c 0) (</c 60))]
[minute (integer-in 0 59)]
[hour (integer-in 0 23)]
[day exact-integer?])))
(activate-contract-out plot-time->seconds seconds->plot-time
datetime->real))

9
collects/plot/contracted/draw.rkt Normal file
View File

@ -0,0 +1,9 @@
#lang racket/base
(require unstable/latent-contract)
(require "../common/draw.rkt")
(provide (activate-contract-out ->color ->pen-color ->brush-color ->pen-style ->brush-style
color-seq color-seq*
alpha-expt
maybe-apply/list))

11
collects/plot/contracted/format.rkt Normal file
View File

@ -0,0 +1,11 @@
#lang racket/base
(require unstable/latent-contract)
(require "../common/format.rkt")
(provide (activate-contract-out
integer->superscript
digits-for-range
real->decimal-string* real->string/trunc
real->plot-label ->plot-label
parse-format-string apply-formatter))

16
collects/plot/contracted/legend.rkt Normal file
View File

@ -0,0 +1,16 @@
#lang racket/base
(require racket/contract unstable/latent-contract racket/class)
(require "../common/legend.rkt"
"../common/area.rkt")
(provide (contract-out
(struct legend-entry ([label string?]
[draw ((is-a?/c plot-area%) real? real? real? real? . -> . void?)])))
(activate-contract-out
line-legend-entry line-legend-entries
rectangle-legend-entry rectangle-legend-entries
interval-legend-entry interval-legend-entries
contour-intervals-legend-entries
point-legend-entry
vector-field-legend-entry))

33
collects/plot/contracted/math.rkt Normal file
View File

@ -0,0 +1,33 @@
#lang racket/base
(require racket/contract unstable/latent-contract)
(require "../common/math.rkt")
(provide equal?*
;; Flonums
nan? infinite? special?
flblend flatan2 flsum flmodulo fldistance
;; Reals
regular?
min* max* degrees->radians radians->degrees blend atan2 sum real-modulo distance
floor-log/base ceiling-log/base
polar->cartesian 3d-polar->3d-cartesian
;; Vectors
vcross v+ v- vneg v* v/ vmag^2 vmag vnormalize vdot vregular? v= vcenter)
;; Intervals
(provide (contract-out (struct ivl ([min (or/c real? #f)] [max (or/c real? #f)]))
[ivl-meet (->* () () #:rest (listof ivl?) ivl?)]
[ivl-join (->* () () #:rest (listof ivl?) ivl?)])
empty-ivl unknown-ivl
(activate-contract-out
ivl-empty? ivl-known? ivl-regular? ivl-singular? ivl-zero-length?
ivl-inexact->exact ivl-contains? bounds->intervals))
;; Rectangles
(provide (contract-out [rect-meet (->* () () #:rest (listof (vectorof ivl?)) (vectorof ivl?))]
[rect-join (->* () () #:rest (listof (vectorof ivl?)) (vectorof ivl?))])
(activate-contract-out
empty-rect unknown-rect bounding-rect
rect-empty? rect-known? rect-regular? rect-zero-area? rect-singular?
rect-inexact->exact rect-contains?))

79
collects/plot/contracted/parameters.rkt Normal file
View File

@ -0,0 +1,79 @@
#lang racket/base
(require unstable/latent-contract)
(require "../common/parameters.rkt")
(provide
(activate-contract-out
plot-deprecation-warnings?
;; General plot parameters
plot-x-axis? plot-y-axis? plot-z-axis?
plot-x-far-axis? plot-y-far-axis? plot-z-far-axis?
plot-x-max-ticks plot-y-max-ticks plot-z-max-ticks plot-d-max-ticks plot-r-max-ticks
plot-x-far-max-ticks plot-y-far-max-ticks plot-z-far-max-ticks
plot-width plot-height
plot-foreground plot-foreground-alpha
plot-background plot-background-alpha
plot-line-width plot-tick-size
plot-font-size plot-font-family
plot-legend-anchor plot-legend-box-alpha
plot-decorations?
plot-animating?
plot3d-samples
plot3d-angle plot3d-altitude
plot3d-ambient-light plot3d-diffuse-light? plot3d-specular-light?
plot-new-window? plot-jpeg-quality plot-ps/pdf-interactive?
plot-title
plot-x-label plot-y-label plot-z-label
plot-x-far-label plot-y-far-label plot-z-far-label
plot-x-transform plot-x-ticks plot-x-far-ticks
plot-y-transform plot-y-ticks plot-y-far-ticks
plot-z-transform plot-z-ticks plot-z-far-ticks
plot-d-transform plot-d-ticks
plot-r-transform plot-r-ticks
;; Renderer parameters
line-samples line-color line-width line-style line-alpha
interval-color interval-style
interval-line1-color interval-line1-width interval-line1-style
interval-line2-color interval-line2-width interval-line2-style
interval-alpha
point-sym point-color point-size point-line-width point-alpha
vector-field-samples
vector-field-color vector-field-line-width vector-field-line-style
vector-field-scale
vector-field-alpha
error-bar-width error-bar-color error-bar-line-width error-bar-line-style error-bar-alpha
contour-samples contour-levels contour-colors contour-widths contour-styles contour-alphas
contour-interval-colors contour-interval-styles contour-interval-alphas
rectangle-color rectangle-style
rectangle-line-color rectangle-line-width rectangle-line-style
rectangle-alpha
discrete-histogram-gap
rectangle3d-line-width
x-axis-ticks? y-axis-ticks? z-axis-ticks?
x-axis-labels? y-axis-labels? z-axis-labels?
x-axis-far? y-axis-far? z-axis-far?
x-axis-alpha y-axis-alpha z-axis-alpha
polar-axes-number polar-axes-ticks? polar-axes-labels? polar-axes-alpha
label-anchor label-angle label-alpha label-point-size
surface-color surface-style surface-line-color surface-line-width surface-line-style surface-alpha
contour-interval-line-colors contour-interval-line-widths contour-interval-line-styles
isosurface-levels
isosurface-colors isosurface-line-colors isosurface-line-widths isosurface-line-styles
isosurface-alphas
;; Functions
pen-gap
animated-samples
default-x-ticks default-y-ticks default-z-ticks default-d-ticks default-r-ticks
default-x-far-ticks default-y-far-ticks default-z-far-ticks
default-contour-colors default-contour-fill-colors
default-isosurface-colors default-isosurface-line-colors)
;; Parameter groups
plot-parameters
plot-axes?
plot-max-ticks
plot-appearance
plot3d-appearance
plot-output
plot-labels
plot-axes plot-x-axis plot-y-axis plot-z-axis)

36
collects/plot/contracted/plot-element.rkt Normal file
View File

@ -0,0 +1,36 @@
#lang racket/base
(require racket/contract unstable/latent-contract racket/class)
(require "../common/contract.rkt"
"../common/plot-element.rkt"
"../common/math.rkt"
"../common/legend.rkt"
"../plot2d/area.rkt"
"../plot3d/area.rkt")
(provide
(contract-out
(struct plot-element
([bounds-rect (or/c (vectorof ivl?) #f)]
[bounds-fun (or/c bounds-fun/c #f)]
[ticks-fun (or/c ticks-fun/c #f)]))
(struct (non-renderer plot-element)
([bounds-rect (or/c (vectorof ivl?) #f)]
[bounds-fun (or/c bounds-fun/c #f)]
[ticks-fun (or/c ticks-fun/c #f)]))
(struct (renderer2d plot-element)
([bounds-rect (or/c (vectorof ivl?) #f)]
[bounds-fun (or/c bounds-fun/c #f)]
[ticks-fun (or/c ticks-fun/c #f)]
[render-proc (or/c ((is-a?/c 2d-plot-area%) . -> . (treeof legend-entry?)) #f)]))
(struct (renderer3d plot-element)
([bounds-rect (or/c (vectorof ivl?) #f)]
[bounds-fun (or/c bounds-fun/c #f)]
[ticks-fun (or/c ticks-fun/c #f)]
[render-proc (or/c ((is-a?/c 3d-plot-area%) . -> . (treeof legend-entry?)) #f)])))
bounds-fun/c ticks-fun/c
(activate-contract-out default-ticks-fun
function-bounds-fun function-interval-bounds-fun
inverse-bounds-fun inverse-interval-bounds-fun
surface3d-bounds-fun))

16
collects/plot/contracted/sample.rkt Normal file
View File

@ -0,0 +1,16 @@
#lang racket/base
(require racket/contract unstable/latent-contract)
(require "../common/sample.rkt")
(provide (activate-contract-out build-linear-seq linear-seq linear-seq* nonlinear-seq
sample/c sampler/c
2d-sample/c 2d-sampler/c
3d-sample/c 3d-sampler/c
make-function->sampler
make-2d-function->sampler
make-3d-function->sampler
2d-sample->list 3d-sample->list)
(contract-out (struct mapped-function ([f (any/c . -> . any/c)]
[fmap ((listof any/c) . -> . (listof any/c))])))
map*)

10
collects/plot/contracted/samplers.rkt Normal file
View File

@ -0,0 +1,10 @@
#lang racket/base
(require unstable/latent-contract)
(require "../common/samplers.rkt")
(provide (activate-contract-out contour-ticks
function->sampler
inverse->sampler
2d-function->sampler
3d-function->sampler))

24
collects/plot/contracted/ticks.rkt Normal file
View File

@ -0,0 +1,24 @@
#lang racket/base
(require racket/contract unstable/latent-contract)
(require "../common/ticks.rkt")
(provide
(contract-out (struct pre-tick ([value real?] [major? boolean?]))
(struct (tick pre-tick) ([value real?] [major? boolean?] [label string?]))
(struct ticks ([layout ticks-layout/c] [format ticks-format/c])))
24h-descending-date-ticks-formats 12h-descending-date-ticks-formats
descending-time-ticks-formats
us-currency-scales uk-currency-scales eu-currency-scales
us-currency-formats uk-currency-formats eu-currency-formats
ticks-layout/c ticks-format/c
(activate-contract-out ticks-mimic ticks-scale ticks-add linear-scale
no-ticks-layout no-ticks
linear-ticks-layout linear-ticks-format linear-ticks
log-ticks-layout log-ticks-format log-ticks
date-ticks-formats date-ticks-layout date-ticks-format date-ticks
time-ticks-formats time-ticks-layout time-ticks-format time-ticks
bit/byte-ticks-format bit/byte-ticks
currency-ticks-scales currency-ticks-formats
currency-ticks-layout currency-ticks-format currency-ticks
fraction-ticks-format fraction-ticks))

17
collects/plot/deprecated.rkt → collects/plot/deprecated/deprecated.rkt
View File

@ -1,18 +1,11 @@
#lang racket/base
(require racket/contract racket/match racket/class racket/snip racket/draw racket/string
;; Plotting
"common/deprecation-warning.rkt"
"common/contract.rkt"
"common/contract-doc.rkt"
"common/plot-element.rkt"
"plot2d/line.rkt"
"plot2d/contour.rkt"
"plot3d/surface.rkt"
"deprecated/renderers.rkt"
"utils.rkt")
(require racket/contract plot/utils
"../common/deprecation-warning.rkt"
"../common/contract-doc.rkt"
"renderers.rkt")
(provide mix line contour shade surface)
(provide (all-defined-out))
(define (mix . renderers)
(deprecation-warning "mix" "list")

5
collects/plot/deprecated/renderers.rkt
View File

@ -2,11 +2,10 @@
;; Functions that create renderers for backward-compatible functions 'line', 'contour', etc.
(require racket/match
(require racket/match plot/utils
"../plot2d/line.rkt"
"../plot2d/contour.rkt"
"../plot3d/surface.rkt"
"../utils.rkt")
"../plot3d/surface.rkt")
(provide line-renderer
contour-renderer

79
collects/plot/doc.rkt Normal file
View File

@ -0,0 +1,79 @@
#lang racket/base
(require "common/contract-doc.rkt")
;; ===================================================================================================
;; Common exports
(require "common/parameters.rkt"
"common/contract.rkt"
"common/axis-transform.rkt"
"common/ticks.rkt"
"common/math.rkt"
"common/plot-element.rkt"
"common/non-renderer.rkt"
"common/format.rkt"
"common/sample.rkt"
"common/draw.rkt"
"common/date-time.rkt")
(provide (only-doc-out
(combine-out (all-from-out "common/parameters.rkt")
(all-from-out "common/contract.rkt")
(all-from-out "common/axis-transform.rkt")
(all-from-out "common/ticks.rkt")
(all-from-out "common/math.rkt")
(all-from-out "common/plot-element.rkt")
(all-from-out "common/non-renderer.rkt")
(all-from-out "common/format.rkt")
(all-from-out "common/sample.rkt")
(all-from-out "common/draw.rkt")
(all-from-out "common/date-time.rkt"))))
;; ===================================================================================================
;; 2D exports
(require "plot2d/plot.rkt"
"plot2d/point.rkt"
"plot2d/line.rkt"
"plot2d/interval.rkt"
"plot2d/contour.rkt"
"plot2d/rectangle.rkt"
"plot2d/decoration.rkt"
"plot2d/kde.rkt")
(provide (only-doc-out
(combine-out (all-from-out "plot2d/plot.rkt")
(all-from-out "plot2d/point.rkt")
(all-from-out "plot2d/line.rkt")
(all-from-out "plot2d/interval.rkt")
(all-from-out "plot2d/contour.rkt")
(all-from-out "plot2d/rectangle.rkt")
(all-from-out "plot2d/decoration.rkt")
(all-from-out "plot2d/kde.rkt"))))
;; ===================================================================================================
;; 3D exports
(require "plot3d/plot.rkt"
"plot3d/surface.rkt"
"plot3d/contour.rkt"
"plot3d/line.rkt"
"plot3d/point.rkt"
"plot3d/isosurface.rkt"
"plot3d/rectangle.rkt")
(provide (only-doc-out
(combine-out (all-from-out "plot3d/plot.rkt")
(all-from-out "plot3d/surface.rkt")
(all-from-out "plot3d/contour.rkt")
(all-from-out "plot3d/line.rkt")
(all-from-out "plot3d/point.rkt")
(all-from-out "plot3d/isosurface.rkt")
(all-from-out "plot3d/rectangle.rkt"))))
;; ===================================================================================================
;; Deprecated functions
(require "deprecated/deprecated.rkt")
(provide (only-doc-out (all-from-out "deprecated/deprecated.rkt")))

115
collects/plot/main.rkt
View File

@ -1,73 +1,90 @@
#lang racket/base
(require racket/contract)
(require racket/contract unstable/latent-contract)
;; ===================================================================================================
;; Common exports
;; General exports
(require "common/parameters.rkt"
"common/contract.rkt")
(require "contracted/parameters.rkt")
(provide (all-from-out "contracted/parameters.rkt"))
(provide (all-from-out "common/parameters.rkt")
(all-from-out "common/contract.rkt"))
(require "common/axis-transform.rkt")
(provide (all-from-out "common/axis-transform.rkt"))
(require "common/ticks.rkt")
(provide (all-from-out "common/ticks.rkt"))
(require "common/math.rkt")
(require "contracted/math.rkt")
(provide (struct-out ivl))
(require "common/plot-element.rkt")
(provide plot-element? non-renderer? renderer2d? renderer3d?)
(require "contracted/axis-transform.rkt")
(provide axis-transform-compose axis-transform-append axis-transform-bound
id-transform log-transform cbrt-transform hand-drawn-transform
stretch-transform collapse-transform)
(require "contracted/ticks.rkt")
(provide (all-from-out "contracted/ticks.rkt"))
(require "contracted/date-time.rkt")
(provide (struct-out plot-time)
plot-time->seconds seconds->plot-time
datetime->real)
(require "common/non-renderer.rkt")
(provide (all-from-out "common/non-renderer.rkt"))
(provide (activate-contract-out x-ticks y-ticks z-ticks invisible-box invisible-box3d))
;; ===================================================================================================
;; 2D exports
(require "plot2d/plot.rkt"
"plot2d/point.rkt"
"plot2d/line.rkt"
"plot2d/interval.rkt"
"plot2d/contour.rkt"
"plot2d/rectangle.rkt"
"plot2d/decoration.rkt"
"plot2d/kde.rkt")
(require "plot2d/plot.rkt")
(provide (activate-contract-out plot/dc plot plot-bitmap plot-pict plot-snip plot-frame plot-file))
(provide (all-from-out "plot2d/plot.rkt")
(all-from-out "plot2d/point.rkt")
(all-from-out "plot2d/line.rkt")
(all-from-out "plot2d/interval.rkt")
(all-from-out "plot2d/contour.rkt")
(all-from-out "plot2d/rectangle.rkt")
(all-from-out "plot2d/decoration.rkt")
density)
(require "plot2d/point.rkt")
(provide (activate-contract-out points vector-field error-bars))
(require "plot2d/line.rkt")
(provide (activate-contract-out lines parametric polar function inverse))
(require "plot2d/interval.rkt")
(provide (activate-contract-out
lines-interval parametric-interval polar-interval function-interval inverse-interval))
(require "plot2d/contour.rkt")
(provide (activate-contract-out contours contour-intervals))
(require "plot2d/rectangle.rkt")
(provide (activate-contract-out rectangles area-histogram discrete-histogram))
(require "plot2d/decoration.rkt")
(provide (activate-contract-out
x-axis y-axis axes polar-axes
x-tick-lines y-tick-lines tick-grid
point-label parametric-label polar-label function-label inverse-label))
(require "plot2d/kde.rkt")
(provide (activate-contract-out density))
;; ===================================================================================================
;; 3D exports
(require "plot3d/plot.rkt"
"plot3d/surface.rkt"
"plot3d/contour.rkt"
"plot3d/line.rkt"
"plot3d/point.rkt"
"plot3d/isosurface.rkt"
"plot3d/rectangle.rkt")
(require "plot3d/plot.rkt")
(provide (activate-contract-out
plot3d/dc plot3d plot3d-bitmap plot3d-pict plot3d-snip plot3d-frame plot3d-file))
(provide (all-from-out "plot3d/plot.rkt")
(all-from-out "plot3d/surface.rkt")
(all-from-out "plot3d/contour.rkt")
(all-from-out "plot3d/line.rkt")
(all-from-out "plot3d/point.rkt")
(all-from-out "plot3d/isosurface.rkt")
(all-from-out "plot3d/rectangle.rkt"))
(require "plot3d/surface.rkt")
(provide (activate-contract-out surface3d))
(require "plot3d/contour.rkt")
(provide (activate-contract-out contours3d contour-intervals3d))
(require "plot3d/line.rkt")
(provide (activate-contract-out lines3d parametric3d))
(require "plot3d/point.rkt")
(provide (activate-contract-out points3d))
(require "plot3d/isosurface.rkt")
(provide (activate-contract-out isosurface3d isosurfaces3d polar3d))
(require "plot3d/rectangle.rkt")
(provide (activate-contract-out rectangles3d discrete-histogram3d))
;; ===================================================================================================
;; Deprecated functions
(require "deprecated.rkt")
(provide (all-from-out "deprecated.rkt"))
(require "deprecated/deprecated.rkt")
(provide mix (activate-contract-out line contour shade surface))

6
collects/plot/plot2d/area.rkt
View File

@ -200,7 +200,8 @@
(define offset (vector 0 (+ max-x-tick-offset
max-x-tick-label-height
(* 1/2 char-height))))
(list (plot-x-label) (v+ (view->dc (vector (* 1/2 (+ x-min x-max)) y-min)) offset) 'top))
(list (plot-x-label) (v+ (view->dc (vector (* 1/2 (+ x-min x-max)) y-min)) offset)
'top))
(define (get-y-label-params)
(define offset (vector (+ max-y-tick-offset
@ -214,7 +215,8 @@
(define offset (vector 0 (+ max-x-far-tick-offset
max-x-far-tick-label-height
(* 1/2 char-height))))
(list (plot-x-far-label) (v- (view->dc (vector (* 1/2 (+ x-min x-max)) y-max)) offset) 'bottom))
(list (plot-x-far-label) (v- (view->dc (vector (* 1/2 (+ x-min x-max)) y-max)) offset)
'bottom))
(define (get-y-far-label-params)
(define offset (vector (+ max-y-far-tick-offset

4
collects/plot/plot2d/contour.rkt
View File

@ -3,10 +3,10 @@
;; Renderers for contour lines and contour intervals
(require racket/contract racket/class racket/match racket/list racket/flonum racket/vector
plot/custom plot/utils
plot/utils
"../common/contract-doc.rkt")
(provide contours contour-intervals)
(provide (all-defined-out))
;; ===================================================================================================
;; Contour lines

54
collects/plot/plot2d/decoration.rkt
View File

@ -3,7 +3,7 @@
;; Renderers for plot decorations: axes, grids, labeled points, etc.
(require racket/contract racket/class racket/match racket/math racket/list
plot/custom plot/utils
plot/utils
"../common/contract-doc.rkt"
"area.rkt"
"line.rkt"
@ -12,14 +12,7 @@
"contour.rkt"
"clip.rkt")
(provide x-axis y-axis axes
polar-axes
x-tick-lines y-tick-lines tick-grid
point-label
parametric-label
polar-label
function-label
inverse-label)
(provide (all-defined-out))
;; ===================================================================================================
;; X and Y axes
@ -94,9 +87,11 @@
[#:x-ticks? x-ticks? boolean? (x-axis-ticks?)]
[#:y-ticks? y-ticks? boolean? (y-axis-ticks?)]
[#:x-labels? x-labels? boolean? (x-axis-labels?)]
[#:y-labels? y-labels? boolean? (y-axis-labels?)]) (listof renderer2d?)
(list (x-axis y #:ticks? x-ticks? #:labels? x-labels?)
(y-axis x #:ticks? y-ticks? #:labels? y-labels?)))
[#:y-labels? y-labels? boolean? (y-axis-labels?)]
[#:x-alpha x-alpha (real-in 0 1) (x-axis-alpha)]
[#:y-alpha y-alpha (real-in 0 1) (y-axis-alpha)]) (listof renderer2d?)
(list (x-axis y #:ticks? x-ticks? #:labels? x-labels? #:alpha x-alpha)
(y-axis x #:ticks? y-ticks? #:labels? y-labels? #:alpha y-alpha)))
;; ===================================================================================================
;; Polar axes
@ -117,63 +112,58 @@
#:when (and r-min r-max (not (= r-min r-max))))
(values θ r-min r-max)))
(define (draw-polar-axis-ticks num area)
(define (draw-polar-axis-ticks num labels? area)
(define-values (x-min x-max y-min y-max) (send area get-bounds))
(define-values (θs r-mins r-maxs) (build-polar-axes num x-min x-max y-min y-max
(* 1/2 (/ (* 2 pi) num))))
(define corner-rs
(list (vmag (vector x-min y-min)) (vmag (vector x-min y-max))
(vmag (vector x-max y-max)) (vmag (vector x-max y-min))))
(define r-min (if (and (<= x-min 0 x-max) (<= y-min 0 y-max)) 0 (apply min corner-rs)))
(define r-max (apply max corner-rs))
(define ts (filter (λ (t) (not (zero? (pre-tick-value t))))
((linear-ticks) r-min r-max (polar-axes-max-ticks))))
(send area set-alpha 1/2)
(default-r-ticks r-min r-max)))
;; Draw the tick lines
(for ([t (in-list ts)])
(match-define (tick r major? label) t)
(if major? (send area set-major-pen) (send area set-minor-pen 'long-dash))
(define pts (for/list ([θ (in-list (linear-seq 0 (* 2 pi) 500))])
(vector (* r (cos θ)) (* r (sin θ)))))
(send area put-lines pts))
(when (not (empty? θs))
;; find the longest axis
;; Draw the labels
(when (and labels? (not (empty? θs)))
;; Find the longest half-axis, rounded to drown out floating-point error
(define mag (expt 10 (- (digits-for-range r-min r-max))))
(match-define (list mθ mr-min mr-max)
;; find the longest, rounded to drown out floating-point error
(argmax (λ (lst) (* (round (/ (- (third lst) (second lst)) mag)) mag))
(map list θs r-mins r-maxs)))
(send area set-alpha 1)
;; Actually draw the labels
(for ([t (in-list ts)])
(match-define (tick r major? label) t)
(when (and major? (<= mr-min r mr-max))
(send area put-text label (vector (* r (cos mθ)) (* r (sin mθ)))
'center 0 #:outline? #t)))))
(define ((polar-axes-render-proc num ticks?) area)
(define ((polar-axes-render-proc num ticks? labels? alpha) area)
(define-values (x-min x-max y-min y-max) (send area get-bounds))
(define-values (θs r-mins r-maxs) (build-polar-axes num x-min x-max y-min y-max))
;; Draw the axes
(send area set-alpha 1/2)
(send area set-alpha alpha)
(send area set-major-pen)
(for ([θ (in-list θs)] [r-min (in-list r-mins)] [r-max (in-list r-maxs)])
(send area put-line
(vector (* r-min (cos θ)) (* r-min (sin θ)))
(vector (* r-max (cos θ)) (* r-max (sin θ)))))
(when ticks? (draw-polar-axis-ticks num area))
;; Draw the ticks
(when ticks? (draw-polar-axis-ticks num labels? area))
;; No legend
empty)
(defproc (polar-axes [#:number num exact-positive-integer? (polar-axes-number)]
[#:ticks? ticks? boolean? (polar-axes-ticks?)]
) renderer2d?
(renderer2d #f #f #f (polar-axes-render-proc num ticks?)))
[#:labels? labels? boolean? (polar-axes-labels?)]
[#:alpha alpha (real-in 0 1) (polar-axes-alpha)]) renderer2d?
(renderer2d #f #f #f (polar-axes-render-proc num ticks? labels? alpha)))
;; ===================================================================================================
;; Grid

15
collects/plot/plot2d/interval.rkt
View File

@ -3,10 +3,10 @@
;; Renderers for intervals between functions.
(require racket/contract racket/class racket/match racket/math racket/list
"../common/contract-doc.rkt"
plot/custom plot/utils)
plot/utils
"../common/contract-doc.rkt")
(provide lines-interval parametric-interval polar-interval function-interval inverse-interval)
(provide (all-defined-out))
;; ===================================================================================================
;; Lines, parametric, polar
@ -82,8 +82,8 @@
[#:label label (or/c string? #f) #f]
) renderer2d?
(lines-interval
(sample-parametric f1 t-min t-max samples)
(sample-parametric f2 t-min t-max samples)
(map f1 (linear-seq t-min t-max samples))
(map f2 (linear-seq t-min t-max samples))
#:x-min x-min #:x-max x-max #:y-min y-min #:y-max y-max
#:color color #:style style
#:line1-color line1-color #:line1-width line1-width #:line1-style line1-style
@ -107,9 +107,10 @@
[#:alpha alpha (real-in 0 1) (interval-alpha)]
[#:label label (or/c string? #f) #f]
) renderer2d?
(define θs (linear-seq θ-min θ-max samples))
(lines-interval
(sample-polar f1 θ-min θ-max samples)
(sample-polar f2 θ-min θ-max samples)
(map polar->cartesian θs (map* f1 θs))
(map polar->cartesian θs (map* f2 θs))
#:x-min x-min #:x-max x-max #:y-min y-min #:y-max y-max
#:color color #:style style
#:line1-color line1-color #:line1-width line1-width #:line1-style line1-style

4
collects/plot/plot2d/kde.rkt
View File

@ -1,12 +1,12 @@
#lang racket/base
(require racket/flonum racket/list racket/promise racket/math racket/contract
plot/custom plot/utils
plot/utils
"../common/contract-doc.rkt"
"../common/utils.rkt"
"line.rkt")
(provide kde density)
(provide (all-defined-out))
(define (factorial n)
(if (zero? n) 1 (* n (factorial (sub1 n)))))

9
collects/plot/plot2d/line.rkt
View File

@ -3,10 +3,10 @@
;; Line renderers.
(require racket/contract racket/class racket/match racket/math racket/list
plot/custom plot/utils
plot/utils
"../common/contract-doc.rkt")
(provide lines parametric polar function inverse)
(provide (all-defined-out))
;; ===================================================================================================
;; Lines, parametric, polar
@ -50,7 +50,7 @@
[#:alpha alpha (real-in 0 1) (line-alpha)]
[#:label label (or/c string? #f) #f]
) renderer2d?
(lines (sample-parametric f t-min t-max samples)
(lines (map f (linear-seq t-min t-max samples))
#:x-min x-min #:x-max x-max #:y-min y-min #:y-max y-max
#:color color #:width width #:style style #:alpha alpha
#:label label))
@ -66,7 +66,8 @@
[#:alpha alpha (real-in 0 1) (line-alpha)]
[#:label label (or/c string? #f) #f]
) renderer2d?
(lines (sample-polar f θ-min θ-max samples)
(lines (let ([θs (linear-seq θ-min θ-max samples)])
(map polar->cartesian θs (map* f θs)))
#:x-min x-min #:x-max x-max #:y-min y-min #:y-max y-max
#:color color #:width width #:style style #:alpha alpha
#:label label))

13
collects/plot/plot2d/plot.rkt
View File

@ -6,21 +6,20 @@
slideshow/pict
unstable/parameter-group
unstable/lazy-require
(for-syntax racket/base
syntax/strip-context
racket/syntax)
plot/custom plot/utils
"../common/contract-doc.rkt"
"../common/contract.rkt"
"../common/math.rkt"
"../common/parameters.rkt"
"../common/plot-element.rkt"
"../common/file-type.rkt"
"../common/deprecation-warning.rkt"
"../common/utils.rkt"
"../common/contract-doc.rkt"
"area.rkt")
;; Require lazily: without this, Racket complains while generating documentation:
;; cannot instantiate `racket/gui/base' a second time in the same process
(lazy-require ["../common/gui.rkt" (make-snip-frame)])
(provide plot/dc plot plot-bitmap plot-pict plot-snip plot-frame plot-file)
(provide (except-out (all-defined-out) make-snip-frame))
;; ===================================================================================================
;; Plot to a given device context

4
collects/plot/plot2d/point.rkt
View File

@ -3,11 +3,11 @@
;; Renderers for points and other point-like things.
(require racket/contract racket/class racket/match racket/math racket/list
plot/custom plot/utils
plot/utils
"../common/contract-doc.rkt"
"clip.rkt")
(provide points vector-field error-bars)
(provide (all-defined-out))
;; ===================================================================================================
;; Points (scatter plots)

4
collects/plot/plot2d/rectangle.rkt
View File

@ -3,11 +3,11 @@
;; The histogram renderer.
(require racket/match racket/contract racket/class racket/list
plot/custom plot/utils
plot/utils
"../common/contract-doc.rkt"
"../common/utils.rkt")
(provide rectangles area-histogram discrete-histogram)
(provide (all-defined-out))
;; ===================================================================================================
;; Rectangles

4
collects/plot/plot3d/contour.rkt
View File

@ -1,10 +1,10 @@
#lang racket/base
(require racket/class racket/match racket/list racket/flonum racket/contract
plot/custom plot/utils
plot/utils
"../common/contract-doc.rkt")
(provide contours3d contour-intervals3d)
(provide (all-defined-out))
;; ===================================================================================================
;; Contour lines in 3D (using marching squares)

22
collects/plot/plot3d/isosurface.rkt
View File

@ -1,11 +1,11 @@
#lang racket/base
(require racket/class racket/match racket/list racket/flonum racket/contract racket/math
plot/custom plot/utils
plot/utils
"../common/marching-cubes.rkt"
"../common/contract-doc.rkt")
(provide isosurface3d isosurfaces3d polar3d)
(provide (all-defined-out))
;; ===================================================================================================
;; Surfaces of constant value (isosurfaces)
@ -235,6 +235,18 @@
label color 'solid line-color line-width line-style)]
[else empty]))
(define 2pi (* 2 pi))
(define ((2d-polar->3d-function f) x y z)
(let ([x (exact->inexact x)]
[y (exact->inexact y)]
[z (exact->inexact z)])
(define-values (θ ρ)
(cond [(and (fl= x 0.0) (fl= y 0.0)) (values 0.0 0.0)]
[else (values (flmodulo (flatan2 y x) 2pi)
(flatan (fl/ z (distance x y))))]))
(fl- (exact->inexact (f θ ρ)) (distance x y z))))
(defproc (polar3d [f (real? real? . -> . real?)]
[#:x-min x-min (or/c real? #f) #f] [#:x-max x-max (or/c real? #f) #f]
[#:y-min y-min (or/c real? #f) #f] [#:y-max y-max (or/c real? #f) #f]
@ -247,8 +259,10 @@
[#:alpha alpha (real-in 0 1) (surface-alpha)]
[#:label label (or/c string? #f) #f]
) renderer3d?
(define rvs (filter vregular? (sample-2d-polar f 0 2pi (* 2 samples)
(* -1/2 pi) (* 1/2 pi) samples)))
(define vs (for*/list ([θ (in-list (linear-seq 0 2pi (* 4 samples)))]
[ρ (in-list (linear-seq (* -1/2 pi) (* 1/2 pi) (* 2 samples)))])
(3d-polar->3d-cartesian θ ρ (f θ ρ))))
(define rvs (filter vregular? vs))
(cond [(empty? rvs) (renderer3d #f #f #f #f)]
[else
(match-define (list (vector rxs rys rzs) ...) rvs)

6
collects/plot/plot3d/line.rkt
View File

@ -1,10 +1,10 @@
#lang racket/base
(require racket/class racket/match racket/list racket/contract
plot/custom plot/utils
plot/utils
"../common/contract-doc.rkt")
(provide lines3d parametric3d)
(provide (all-defined-out))
;; ===================================================================================================
@ -58,5 +58,5 @@
[#:alpha alpha (real-in 0 1) (line-alpha)]
[#:label label (or/c string? #f) #f]
) renderer3d?
(lines3d-renderer (λ () (sample-parametric f t-min t-max (animated-samples samples)))
(lines3d-renderer (λ () (map f (linear-seq t-min t-max (animated-samples samples))))
x-min x-max y-min y-max z-min z-max color width style alpha label))

16
collects/plot/plot3d/plot.rkt
View File

@ -1,20 +1,18 @@
#lang racket/base
;; Procedures that plot 3D renderers.
(require racket/draw racket/snip racket/match racket/list racket/class racket/contract
slideshow/pict
unstable/parameter-group
unstable/lazy-require
(for-syntax racket/base)
"../common/math.rkt"
"../common/file-type.rkt"
"../common/area.rkt"
"../common/contract.rkt"
"../common/contract-doc.rkt"
"../common/math.rkt"
"../common/parameters.rkt"
"../common/deprecation-warning.rkt"
"../common/plot-element.rkt"
"../common/non-renderer.rkt"
"../common/utils.rkt"
"../common/file-type.rkt"
"../common/deprecation-warning.rkt"
"../common/contract-doc.rkt"
"area.rkt")
;; Require lazily: without this, Racket complains while generating documentation:
@ -22,7 +20,7 @@
(lazy-require ["snip.rkt" (make-3d-plot-snip)]
["../common/gui.rkt" (make-snip-frame)])
(provide plot3d/dc plot3d plot3d-bitmap plot3d-pict plot3d-snip plot3d-frame plot3d-file)
(provide (except-out (all-defined-out) make-3d-plot-snip make-snip-frame))
;; ===================================================================================================
;; Plot to a given device context

4
collects/plot/plot3d/point.rkt
View File

@ -1,10 +1,10 @@
#lang racket/base
(require racket/class racket/list racket/match racket/contract
plot/custom plot/utils
plot/utils
"../common/contract-doc.rkt")
(provide points3d)
(provide (all-defined-out))
;; ===================================================================================================

4
collects/plot/plot3d/rectangle.rkt
View File

@ -3,10 +3,10 @@
;; Functions to create renderers for 3D histograms
(require racket/match racket/list racket/contract racket/class
plot/custom plot/utils
plot/utils
"../common/contract-doc.rkt")
(provide rectangles3d discrete-histogram3d)
(provide (all-defined-out))
;; ===================================================================================================
;; Rectangles

4
collects/plot/plot3d/surface.rkt
View File

@ -1,10 +1,10 @@
#lang racket/base
(require racket/class racket/match racket/list racket/flonum racket/contract
plot/custom plot/utils
plot/utils
"../common/contract-doc.rkt")
(provide surface3d)
(provide (all-defined-out))
;; ===================================================================================================
;; Surface plots of R R -> R functions

2
collects/plot/scribblings/common.rkt
View File

@ -8,6 +8,7 @@
plot/utils)
plot
plot/utils
plot/doc
plot/common/contract-doc)
(provide (all-defined-out)
@ -18,6 +19,7 @@
plot
plot/utils))
(all-from-out plot)
(all-from-out plot/doc)
(all-from-out plot/utils)
doc-apply)

4
collects/plot/scribblings/contracts.scrbl
View File

@ -2,7 +2,7 @@
@(require "common.rkt")
@declare-exporting[plot]
@declare-exporting[plot/utils]
@title[#:tag "contracts"]{Plot Contracts}
@ -43,7 +43,7 @@ Identifies legal font family values. See @(racket plot-font-family).
The contract for the @(racket #:sym) arguments in @(racket points) and @(racket points3d), and the parameter @(racket point-sym).
}
@defthing[known-point-symbols (listof symbol?)]{
@doc-apply[known-point-symbols]{
A list containing the symbols that are valid @(racket points) symbols.
@interaction[#:eval plot-eval

12
collects/plot/scribblings/plot2d.scrbl
View File

@ -7,7 +7,7 @@
@title[#:tag "plot2d"]{2D Plot Procedures}
@defproc[(plot [renderer-tree (treeof renderer2d?)]
@defproc[(plot [renderer-tree (treeof (or/c renderer2d? non-renderer?))]
[#:x-min x-min (or/c real? #f) #f] [#:x-max x-max (or/c real? #f) #f]
[#:y-min y-min (or/c real? #f) #f] [#:y-max y-max (or/c real? #f) #f]
[#:width width exact-positive-integer? (plot-width)]
@ -50,14 +50,14 @@ The @(racket #:lncolor) keyword argument is also accepted for backward compatibi
}
@deftogether[
(@defproc[(plot-file [renderer-tree (treeof renderer2d?)]
(@defproc[(plot-file [renderer-tree (treeof (or/c renderer2d? non-renderer?))]
[output (or/c path-string? output-port?)]
[kind (one-of/c 'auto 'png 'jpeg 'xmb 'xpm 'bmp 'ps 'pdf 'svg) 'auto]
[#:<plot-keyword> <plot-keyword> <plot-keyword-contract>] ...) void?]
@defproc[(plot-pict [renderer-tree (treeof renderer2d?)] ...) pict?]
@defproc[(plot-bitmap [renderer-tree (treeof renderer2d?)] ...) (is-a?/c bitmap%)]
@defproc[(plot-snip [renderer-tree (treeof renderer2d?)] ...) (is-a?/c image-snip%)]
@defproc[(plot-frame [renderer-tree (treeof renderer2d?)] ...) (is-a?/c frame%)])]{
@defproc[(plot-pict [renderer-tree (treeof (or/c renderer2d? non-renderer?))] ...) pict?]
@defproc[(plot-bitmap [renderer-tree (treeof (or/c renderer2d? non-renderer?))] ...) (is-a?/c bitmap%)]
@defproc[(plot-snip [renderer-tree (treeof (or/c renderer2d? non-renderer?))] ...) (is-a?/c image-snip%)]
@defproc[(plot-frame [renderer-tree (treeof (or/c renderer2d? non-renderer?))] ...) (is-a?/c frame%)])]{
Plot to different backends. Each of these procedures has the same keyword arguments as @(racket plot), except for deprecated keywords.
Use @(racket plot-file) to save a plot to a file.

12
collects/plot/scribblings/plot3d.scrbl
View File

@ -8,7 +8,7 @@
Each 3D plot procedure corresponds with a @(secref "plot2d") procedure. Each behaves the same way as its corresponding 2D procedure, but takes the additional keyword arguments @(racket #:z-min), @(racket #:z-max), @(racket #:angle), @(racket #:altitude) and @(racket #:z-label).
@defproc[(plot3d [renderer-tree (treeof renderer3d?)]
@defproc[(plot3d [renderer-tree (treeof (or/c renderer3d? non-renderer?))]
[#:x-min x-min (or/c real? #f) #f] [#:x-max x-max (or/c real? #f) #f]
[#:y-min y-min (or/c real? #f) #f] [#:y-max y-max (or/c real? #f) #f]
[#:z-min z-min (or/c real? #f) #f] [#:z-max z-max (or/c real? #f) #f]
@ -40,14 +40,14 @@ The @(racket #:az) and @(racket #:alt) keyword arguments are backward-compatible
}
@deftogether[
(@defproc[(plot3d-file [renderer-tree (treeof renderer3d?)]
(@defproc[(plot3d-file [renderer-tree (treeof (or/c renderer3d? non-renderer?))]
[output (or/c path-string? output-port?)]
[kind (one-of/c 'auto 'png 'jpeg 'xmb 'xpm 'bmp 'ps 'pdf 'svg) 'auto]
[#:<plot-keyword> <plot-keyword> <plot-keyword-contract>] ...) void?]
@defproc[(plot3d-pict [renderer-tree (treeof renderer3d?)] ...) pict?]
@defproc[(plot3d-bitmap [renderer-tree (treeof renderer3d?)] ...) (is-a?/c bitmap%)]
@defproc[(plot3d-snip [renderer-tree (treeof renderer3d?)] ...) (is-a?/c image-snip%)]
@defproc[(plot3d-frame [renderer-tree (treeof renderer3d?)] ...) (is-a?/c frame%)])]{
@defproc[(plot3d-pict [renderer-tree (treeof (or/c renderer3d? non-renderer?))] ...) pict?]
@defproc[(plot3d-bitmap [renderer-tree (treeof (or/c renderer3d? non-renderer?))] ...) (is-a?/c bitmap%)]
@defproc[(plot3d-snip [renderer-tree (treeof (or/c renderer3d? non-renderer?))] ...) (is-a?/c image-snip%)]
@defproc[(plot3d-frame [renderer-tree (treeof (or/c renderer3d? non-renderer?))] ...) (is-a?/c frame%)])]{
Plot to different backends. Each of these procedures has the same keyword arguments as @(racket plot3d), except for deprecated keywords.
These procedures correspond with @(racket plot-file), @(racket plot-pict), @(racket plot-bitmap), @(racket plot-snip) and @(racket plot-frame).

1
collects/plot/tests/axis-transform-tests.rkt
View File

@ -5,7 +5,6 @@
plot/utils
plot/common/contract
plot/common/contract-doc
;plot/common/axis-transform
)
(x-axis-ticks? #f)

29
collects/plot/tests/low-level-tests.rkt
View File

@ -2,9 +2,19 @@
(require rackunit racket/date
plot plot/utils
plot/common/date-time
plot/common/vector
plot/common/utils)
plot/common/utils
(only-in plot/common/math
vector-andmap
vector-ormap)
(only-in plot/common/date-time
utc-seconds-round-year
utc-seconds-round-month
seconds-per-minute
seconds-per-hour
seconds-per-day
seconds-per-week)
(only-in plot/common/format
int-str->e-str frac-str->e-str))
(check-equal? (linear-seq 0 1 2 #:start? #t #:end? #t) '(0 1))
(check-equal? (linear-seq 0 1 2 #:start? #t #:end? #f) '(0 2/3))
@ -15,6 +25,19 @@
(λ () (vector-field (λ (v [z 0]) v) -4 4 -4 4))
"Exception should be 'two of the clauses in the or/c might both match' or similar")
;; ===================================================================================================
;; Formatting
(check-equal? (int-str->e-str "") "0")
(check-equal? (int-str->e-str "0") "0")
(check-equal? (int-str->e-str "10") "1×10\u00b9")
(check-equal? (frac-str->e-str "") "0")
(check-equal? (frac-str->e-str "0") "0")
(check-equal? (frac-str->e-str "00") "0")
(check-equal? (frac-str->e-str "1") "1×10\u207b\u00b9")
(check-equal? (frac-str->e-str "01") "1×10\u207b\u00b2")
;; ===================================================================================================
;; Date rounding

2
collects/plot/tests/pen-brush-hsv.rkt
View File

@ -2,8 +2,6 @@
(require plot plot/utils)
(define (real-modulo x y) (- x (* y (floor (/ x y)))))
(define (rgb->hsv rgb)
(match-define (list r g b) (map (λ (x) (/ x 255)) rgb))
(define mx (max r g b))

4
collects/plot/tests/tick-tests.rkt
View File

@ -1,6 +1,6 @@
#lang racket
(require plot (only-in plot/common/math floor-log/base real-modulo))
(require plot plot/utils)
(plot-font-family 'swiss)
@ -99,7 +99,7 @@
(y-ticks (list (tick 1/4 #t "1/4") (tick -1/4 #f "")))))
(parameterize ([plot-z-max-ticks 5])
(plot3d (list (surface3d (λ (x y) (* 2 (+ (sin x) (cos y)))) -4 4 -4 4)
(plot3d (list (surface3d (λ (x y) (* 2 (+ (sin x) (cos y)))) -4 4 -4 4 #:alpha 1/2)
(x-ticks (list (tick 1.5 #t "3/2") (tick 3 #t "Three")))
(y-ticks (list (tick 1/3 #t "1/3") (tick -1/3 #f "1/3")))
(z-ticks (list (tick pi #f "π") (tick (- pi) #t "-π"))))))

50
collects/plot/utils.rkt
View File

@ -1,27 +1,29 @@
#lang racket/base
(require "common/math.rkt")
(provide (all-from-out "common/math.rkt"))
(require "common/contract.rkt"
"common/marching-squares.rkt"
"contracted/parameters.rkt"
"contracted/math.rkt"
"contracted/axis-transform.rkt"
"contracted/ticks.rkt"
"contracted/format.rkt"
"contracted/draw.rkt"
"contracted/sample.rkt"
"contracted/samplers.rkt"
"contracted/legend.rkt"
"contracted/plot-element.rkt"
"contracted/date-time.rkt")
(require "common/format.rkt")
(provide digits-for-range
real->plot-label
->plot-label
real->string/trunc)
(require "common/draw.rkt")
(provide color-seq color-seq*
->color
->pen-color ->brush-color
->pen-style ->brush-style
alpha-expt)
(require "common/axis-transform.rkt")
(provide (struct-out invertible-function))
(require "common/sample.rkt")
(provide linear-seq linear-seq* nonlinear-seq
(struct-out mapped-function))
(require "common/contract.rkt")
(provide (all-from-out "common/contract.rkt"))
(provide (all-from-out "common/contract.rkt")
(all-from-out "common/marching-squares.rkt")
(all-from-out "contracted/parameters.rkt")
(all-from-out "contracted/math.rkt")
(all-from-out "contracted/axis-transform.rkt")
(all-from-out "contracted/ticks.rkt")
(all-from-out "contracted/format.rkt")
(all-from-out "contracted/draw.rkt")
(all-from-out "contracted/sample.rkt")
(all-from-out "contracted/samplers.rkt")
(all-from-out "contracted/legend.rkt")
(all-from-out "contracted/plot-element.rkt")
(all-from-out "contracted/date-time.rkt"))

33
collects/tests/unstable/latent-contract.rkt Normal file
View File

@ -0,0 +1,33 @@
#lang racket/load
(require rackunit)
(module module0 racket/base
(require racket/contract unstable/latent-contract)
(provide identity listify)
(define/latent-contract (identity x) (real? . -> . real?)
x)
(define/latent-contract (listify x) (parametric->/c [a] (a . -> . (listof a)))
(list x)))
(module module1 racket/base
(require 'module0 unstable/latent-contract)
(provide (activate-contract-out identity listify)))
(require 'module0)
(check-true (procedure? identity))
(check-true (procedure? listify))
(check-equal? (identity 1) 1)
(check-equal? (identity 'x) 'x)
(check-equal? (listify 1) (list 1))
(require 'module1)
(check-true (procedure? identity))
(check-true (procedure? listify))
(check-equal? (identity 1) 1)
(check-exn exn:fail:contract? (λ () (identity 'x)))
(check-equal? (listify 1) (list 1))

74
collects/unstable/latent-contract.rkt Normal file
View File

@ -0,0 +1,74 @@
#lang racket/base
(require (for-syntax racket/base
racket/syntax
syntax/parse
racket/provide-transform
syntax/define)
racket/contract)
(provide define/latent-contract activate-contract-out)
(begin-for-syntax
(struct value/latent-contract (value contract)
#:property prop:procedure
(λ (v/lc stx)
(define value (value/latent-contract-value v/lc))
(syntax-case stx ()
[(_ . args) (quasisyntax/loc stx (#,value . args))]
[_ (quasisyntax/loc stx #,value)]))))
(define-syntax (define/latent-contract stx)
(syntax-parse stx
[(_ (head . args) contract:expr body:expr ...+)
(define-values (name value)
(normalize-definition (syntax/loc stx (define (head . args) body ...)) #'lambda #t #t))
(syntax-protect
(quasisyntax/loc stx
(define/latent-contract #,name contract #,value)))]
[(_ name:id contract:expr value:expr)
(with-syntax ([value-name (format-id #f "~a" #'name)]
[contract-name (format-id #f "~a-contract" #'name)])
(syntax-protect
(syntax/loc stx
(begin (define value-name value)
(define contract-name contract)
(define-syntax name
(value/latent-contract #'value-name #'contract-name))))))]))
(define-for-syntax (activate->contract-out stx id)
(let* ([err (λ () (raise-syntax-error 'activate-contract-out "no latent contract" id))]
[v/lc (syntax-local-value id err)])
(when (not (value/latent-contract? v/lc)) (err))
(with-syntax ([contract (value/latent-contract-contract v/lc)])
(quasisyntax/loc stx [#,id contract]))))
(define-syntax activate-contract-out/end
(make-provide-pre-transformer
(λ (stx modes)
(syntax-case stx ()
[(_ id ...) (with-syntax ([(item ...) (for/list ([id (in-list (syntax->list #'(id ...)))])
(activate->contract-out stx id))])
(pre-expand-export
(syntax-protect
(syntax/loc stx (contract-out item ...)))
modes))]))))
(define-for-syntax (modes->abs-modes modes)
(map (λ (mode) (and mode (+ mode (syntax-local-phase-level))))
(if (null? modes) '(0) modes)))
(define-for-syntax (make-lifting-provide-pre-transformer target-id)
(make-provide-pre-transformer
(λ (stx modes)
(syntax-case stx ()
[(_ args ...) (let ()
(for ([mode (in-list (modes->abs-modes modes))])
(syntax-local-lift-module-end-declaration
(syntax-protect
(quasisyntax/loc stx
(provide (for-meta #,mode (#,target-id args ...)))))))
(syntax/loc stx (combine-out)))]))))
(define-syntax activate-contract-out
(make-lifting-provide-pre-transformer #'activate-contract-out/end))