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

Parameter lists

Browse Source 
Some tick changes
Allow #f in renderer fields
This commit is contained in:
Neil Toronto 2011-10-20 11:40:31 -06:00
parent 27538e1214
commit afadbbf0d1
22 changed files with 498 additions and 242 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

89
collects/plot/common/parameter-list.rkt Normal file
View File

@ -0,0 +1,89 @@
#lang racket/base
;; Provides a way to treat a list of parameters as a parameter itself
(require racket/match racket/list
(for-syntax racket/base)
;; Can't make parameter lists first-class values without these:
(only-in '#%paramz parameterization-key extend-parameterization))
(provide parameter-list parameter-list? parameter-list* parameter-list-append
parameterize/list parameterize*/list)
(define (check-values! name n v)
(unless (and (list? v) (= n (length v)))
(raise-type-error name (format "list of ~a values" n) v)))
;; A wrapper for a list of parameters that acts like a parameter-procedure
(struct parameter-list-procedure (params)
#:property prop:procedure
(case-lambda
[(p) (map (λ (param) (param)) (parameter-list-procedure-params p))]
[(p v) (define params (parameter-list-procedure-params p))
(define n (length params))
(check-values! 'parameter-list-procedure n v)
(for ([param (in-list params)] [val (in-list v)])
(param val))]))
(define parameter-list? parameter-list-procedure?)
;; Raises a type error when one of 'params' isn't a parameter or parameter list
(define (check-parameters! name params)
(for ([param (in-list params)] [i (in-naturals)])
(unless (or (parameter? param) (parameter-list? param))
(apply raise-type-error name "parameter or parameter-list" i params))))
;; Main constructor for a parameter list
(define (parameter-list . params)
(check-parameters! 'parameter-list params)
(parameter-list-procedure params))
;; Corresponds to list*
(define (parameter-list* fst . rst)
(match-define (list params ... p) (cons fst rst))
(check-parameters! 'parameter-list params)
(unless (parameter-list? p) (raise-type-error 'parameter-list* "parameter-list" p))
(parameter-list-procedure (append params (parameter-list-procedure-params p))))
;; Corresponds to append
(define (parameter-list-append . ps)
(for ([p (in-list ps)] [i (in-naturals)])
(unless (parameter-list? p)
(apply raise-type-error 'parameter-list-append "parameter-list" i ps)))
(parameter-list-procedure (append* (map parameter-list-procedure-params ps))))
;; Given the left and right side of a 'parameterize' binding, returns a list of alternating
;; parameters and parameter values
(define (extract-parameterization p v)
(cond [(parameter? p) (list p v)]
[(parameter-list? p) (define params (parameter-list-procedure-params p))
(define n (length params))
(check-values! 'parameterize n v)
(append* (map extract-parameterization params v))]
[else (raise-type-error 'parameterize/list "parameter or parameter-list" p)]))
;; Corresponds to parameterize
(define-syntax (parameterize/list stx)
(syntax-case stx ()
[(_ () expr1 expr ...)
(syntax-protect (syntax/loc stx (let () expr1 expr ...)))]
[(_ ([p v] ...) expr1 expr ...)
(syntax-protect
(syntax/loc stx
(with-continuation-mark parameterization-key
(apply extend-parameterization
(continuation-mark-set-first #f parameterization-key)
(append (extract-parameterization p v) ...))
(let () expr1 expr ...))))]))
;; Corresponds to parameterize*
(define-syntax parameterize*/list
(syntax-rules ()
[(_ () body1 body ...)
(let () body1 body ...)]
[(_ ([lhs1 rhs1] [lhs rhs] ...) body1 body ...)
(parameterize/list
([lhs1 rhs1])
(parameterize*/list
([lhs rhs] ...)
body1 body ...))]))

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

@ -3,10 +3,12 @@
;; Parameters that control the look and behavior of plots.
(require racket/contract
"contract.rkt" "contract-doc.rkt"
"contract.rkt"
"contract-doc.rkt"
"draw.rkt"
"axis-transform.rkt"
"ticks.rkt")
"ticks.rkt"
"parameter-list.rkt")
(provide (all-defined-out))
@ -214,3 +216,43 @@
;; Histograms
(defparam rectangle3d-line-width (>=/c 0) 1/3)
;; ===================================================================================================
(define plot-parameters
(parameter-list plot-deprecation-warnings?
plot-width
plot-height
plot-new-window?
plot-jpeg-quality
plot-ps/pdf-interactive?
plot-foreground
plot-background
plot-foreground-alpha
plot-background-alpha
plot-font-size
plot-font-family
plot-line-width
plot-legend-anchor
plot-legend-box-alpha
plot-tick-size
plot-title
plot-x-label
plot-y-label
plot-z-label
plot-animating?
plot-x-transform
plot-y-transform
plot-z-transform
plot-x-max-ticks
plot-y-max-ticks
plot-z-max-ticks
plot-x-ticks
plot-y-ticks
plot-z-ticks
plot3d-samples
plot3d-angle
plot3d-altitude
plot3d-ambient-light
plot3d-diffuse-light?
plot3d-specular-light?))

12
collects/plot/common/renderer.rkt
View File

@ -17,13 +17,6 @@
;; ===================================================================================================
;; Common field values
(define (null-bounds-fun r) r)
(define (null-ticks-fun r) (apply values (make-list (vector-length r) empty)))
(define (null-render-proc area) empty)
(define null-renderer2d (renderer2d (unknown-rect 2) null-bounds-fun null-ticks-fun null-render-proc))
(define null-renderer3d (renderer3d (unknown-rect 3) null-bounds-fun null-ticks-fun null-render-proc))
(define (default-ticks-fun r)
(apply values (for/list ([i (in-vector r)]
[f (in-list (list default-x-ticks default-y-ticks default-z-ticks))])
@ -105,4 +98,7 @@
;; bounds will you try to draw in?
(define (renderer-apply-bounds rend bounds-rect)
(match-define (renderer rend-bounds-rect rend-bounds-fun _) rend)
(rend-bounds-fun (rect-meet bounds-rect rend-bounds-rect)))
(let ([rend-bounds-rect (cond [rend-bounds-rect (rect-meet bounds-rect rend-bounds-rect)]
[else bounds-rect])])
(cond [rend-bounds-fun (rend-bounds-fun rend-bounds-rect)]
[else rend-bounds-rect])))

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

@ -14,14 +14,12 @@
(provide (struct-out pre-tick) (struct-out tick) (struct-out ticks)
;; No ticks
no-ticks-layout no-ticks-format no-ticks
no-ticks-layout no-ticks
;; Linear ticks
linear-ticks-base linear-ticks-divisors
linear-ticks-layout linear-ticks-format linear-ticks
;; Uniform ticks
uniform-ticks-layout uniform-ticks
;; Log-scale ticks
log-ticks-base
log-ticks-layout log-ticks-format log-ticks
;; Date ticks
date-ticks-formats 24h-descending-date-ticks-formats 12h-descending-date-ticks-formats
@ -32,13 +30,13 @@
;; Bit/byte ticks
bit/byte-ticks-format bit/byte-ticks
;; Currency ticks and formats
currency-scale-suffixes
us-currency-scale-suffixes uk-currency-scale-suffixes eu-currency-scale-suffixes
currency-format-strings
us-currency-format-strings uk-currency-format-strings eu-currency-format-strings
currency-ticks-format currency-ticks
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-scale ticks-add linear-scale
)
(define-struct/contract pre-tick ([value real?] [major? boolean?]) #:transparent)
@ -94,26 +92,9 @@
(define minor-ts (map (λ (x) (pre-tick x #f)) minor-xs))
(sort (append major-ts minor-ts) < #:key pre-tick-value))
;; ===================================================================================================
;; No ticks
(defthing no-ticks-layout ticks-layout/c
(λ (x-min x-max max-ticks transform)
empty))
(defthing no-ticks-format ticks-format/c
(λ (x-min x-max ts)
empty))
(defthing no-ticks ticks?
(ticks no-ticks-layout no-ticks-format))
;; ===================================================================================================
;; Linear ticks (default tick function, evenly spaced)
(defparam linear-ticks-base (and/c exact-integer? (>=/c 2)) 10)
(defparam linear-ticks-divisors (listof exact-positive-integer?) '(1 2 5))
(defproc (linear-tick-step+divisor [x-min real?] [x-max real?]
[max-ticks exact-positive-integer?]
[base (and/c exact-integer? (>=/c 2))]
@ -151,9 +132,8 @@
(define minor-xs (linear-minor-values/step major-xs step (- n 1)))
(values major-xs (filter (λ (x) (<= x-min x x-max)) minor-xs))))
(defproc (linear-ticks-layout [#:base base (and/c exact-integer? (>=/c 2)) (linear-ticks-base)]
[#:divisors divisors (listof exact-positive-integer?)
(linear-ticks-divisors)]
(defproc (linear-ticks-layout [#:base base (and/c exact-integer? (>=/c 2)) 10]
[#:divisors divisors (listof exact-positive-integer?) '(1 2 5)]
) ticks-layout/c
(λ (x-min x-max max-ticks transform)
(define-values (major-xs minor-xs) (linear-tick-values x-min x-max max-ticks base divisors))
@ -167,12 +147,20 @@
(for/list ([t (in-list ts)])
(real->plot-label (pre-tick-value t) digits)))))
(defproc (linear-ticks [#:base base (and/c exact-integer? (>=/c 2)) (linear-ticks-base)]
[#:divisors divisors (listof exact-positive-integer?) (linear-ticks-divisors)]
) ticks?
(defproc (linear-ticks [#:base base (and/c exact-integer? (>=/c 2)) 10]
[#:divisors divisors (listof exact-positive-integer?) '(1 2 5)]) ticks?
(ticks (linear-ticks-layout #:base base #:divisors divisors)
(linear-ticks-format)))
;; ===================================================================================================
;; No ticks
(defproc (no-ticks-layout) ticks-layout/c
(λ (x-min x-max max-ticks transform) empty))
(defproc (no-ticks) ticks?
(ticks (no-ticks-layout) (linear-ticks-format)))
;; ===================================================================================================
;; Uniform spacing ticks
@ -191,10 +179,7 @@
;; ===================================================================================================
;; Exponential ticks (use for log scale)
(defparam log-ticks-base (and/c exact-integer? (>=/c 2)) 10)
(defproc (log-ticks-layout [#:base base (and/c exact-integer? (>=/c 2)) (log-ticks-base)]
) ticks-layout/c
(defproc (log-ticks-layout [#:base base (and/c exact-integer? (>=/c 2)) 10]) ticks-layout/c
(λ (x-min x-max max-ticks transform)
(with-exact-bounds
x-min x-max
@ -215,8 +200,7 @@
[else (list (cond [(zero? m) (pre-tick x #t)]
[else (pre-tick x #f)]))])))))))
(defproc (log-ticks-format [#:base base (and/c exact-integer? (>=/c 2)) (log-ticks-base)]
) ticks-format/c
(defproc (log-ticks-format [#:base base (and/c exact-integer? (>=/c 2)) 10]) ticks-format/c
(define base-str (number->string base))
(λ (x-min x-max ts)
(with-exact-bounds
@ -233,7 +217,7 @@
(real->plot-label (/ x (expt base log-x)) base-digits)
major-str)])))))
(defproc (log-ticks [#:base base (and/c exact-integer? (>=/c 2)) (log-ticks-base)]) ticks?
(defproc (log-ticks [#:base base (and/c exact-integer? (>=/c 2)) 10]) ticks?
(ticks (log-ticks-layout #:base base)
(log-ticks-format #:base base)))
@ -516,24 +500,24 @@
;; Currency
;; US "short scale" suffixes
(define us-currency-scale-suffixes '("" "K" "M" "B" "T"))
(define us-currency-scales '("" "K" "M" "B" "T"))
;; The UK officially uses the short scale now
;; Million is abbreviated "m" instead of "mn" because "mn" stands for minutes; also, the Daily
;; Telegraph Style Guide totally says to use "m"
(define uk-currency-scale-suffixes '("" "k" "m" "bn" "tr"))
(define uk-currency-scales '("" "k" "m" "bn" "tr"))
;; European countries use the long scale: million, milliard, billion
(define eu-currency-scale-suffixes '("" "K" "M" "Md" "B"))
(define eu-currency-scales '("" "K" "M" "Md" "B"))
;; The larger the scale suffixes get, the less standardized they are; so we stop at trillion (short)
;; US negative amounts are in parenthesis:
(define us-currency-format-strings '("~$~w.~f~s" "(~$~w.~f~s)" "~$0"))
(define us-currency-formats '("~$~w.~f~s" "(~$~w.~f~s)" "~$0"))
;; The UK is more reasonable, using a negative sign for negative amounts:
(define uk-currency-format-strings '("~$~w.~f ~s" "-~$~w.~f ~s" "~$0"))
(define uk-currency-formats '("~$~w.~f ~s" "-~$~w.~f ~s" "~$0"))
;; The more common EU format (e.g. France, Germany, Italy, Spain):
(define eu-currency-format-strings '("~w,~f ~s~$" "-~w,~f ~s~$" "0 ~$"))
(define eu-currency-formats '("~w,~f ~s~$" "-~w,~f ~s~$" "0 ~$"))
(defparam currency-scale-suffixes (listof string?) us-currency-scale-suffixes)
(defparam currency-format-strings (list/c string? string? string?) us-currency-format-strings)
(defparam currency-ticks-scales (listof string?) us-currency-scales)
(defparam currency-ticks-formats (list/c string? string? string?) us-currency-formats)
(struct amount-data (sign whole fractional unit suffix) #:transparent)
@ -550,18 +534,21 @@
[(~s) (amount-data-suffix data)]
[else #f])))
(defproc (currency-ticks-format [#:kind kind (or/c string? symbol?) 'USD]) ticks-format/c
(defproc (currency-ticks-format [#:kind kind (or/c string? symbol?) 'USD]
[#:scales scales (listof string?) (currency-ticks-scales)]
[#:formats formats (list/c string? string? string?)
(currency-ticks-formats)]
) ticks-format/c
(match-define (list positive-format-string negative-format-string zero-format-string) formats)
(define positive-format-list (parse-format-string positive-format-string))
(define negative-format-list (parse-format-string negative-format-string))
(define zero-format-list (parse-format-string zero-format-string))
(define suffixes (list->vector scales))
(define n (vector-length suffixes))
(λ (x-min x-max ts)
(with-exact-bounds
x-min x-max
(define formatter (currency-formatter x-min x-max))
(match-define (list positive-format-string negative-format-string zero-format-string)
(currency-format-strings))
(define positive-format-list (parse-format-string positive-format-string))
(define negative-format-list (parse-format-string negative-format-string))
(define zero-format-list (parse-format-string zero-format-string))
(define suffixes (list->vector (currency-scale-suffixes)))
(define n (vector-length suffixes))
(define sign (cond [(string? kind) kind]
[else (hash-ref currency-code->sign kind (λ () (symbol->string kind)))]))
(define x-largest (max* (abs x-min) (abs x-max)))
@ -586,9 +573,12 @@
(defproc (currency-ticks-layout) ticks-layout/c
(linear-ticks-layout #:base 10 #:divisors '(1 2 4 5)))
(defproc (currency-ticks [#:kind kind (or/c string? symbol?) 'USD]) ticks?
(defproc (currency-ticks [#:kind kind (or/c string? symbol?) 'USD]
[#:scales scales (listof string?) (currency-ticks-scales)]
[#:formats formats (list/c string? string? string?) (currency-ticks-formats)]
) ticks?
(ticks (currency-ticks-layout)
(currency-ticks-format #:kind kind)))
(currency-ticks-format #:kind kind #:scales scales #:formats formats)))
;; ===================================================================================================
;; Fractions
@ -619,3 +609,32 @@
(fraction-ticks-divisors)]) ticks?
(ticks (linear-ticks #:base base #:divisors divisors)
(fraction-ticks-format)))
;; ===================================================================================================
;; Tick combinators
(defproc (ticks-scale [t ticks?] [fun invertible-function?]) ticks?
(match-define (invertible-function f g) fun)
(match-define (ticks layout format) t)
(ticks (λ (x-min x-max max-ticks transform)
(define ts (layout (f x-min) (f x-max) max-ticks transform))
(for/list ([t (in-list ts)])
(match-define (pre-tick x major?) t)
(pre-tick (g x) major?)))
(λ (x-min x-max ts)
(format (f x-min) (f x-max) (map (λ (t)
(match-define (pre-tick x major?) t)
(pre-tick (f x) major?))
ts)))))
(defproc (ticks-add [t ticks?] [xs (listof real?)] [major? boolean? #t]) ticks?
(match-define (ticks layout format) t)
(ticks (λ (x-min x-max max-ticks transform)
(append (layout x-min x-max max-ticks transform)
(for/list ([x (in-list xs)])
(pre-tick x major?))))
format))
(defproc (linear-scale [m real?] [b real? 0]) invertible-function?
(invertible-function (λ (x) (+ (* m x) b))
(λ (y) (/ (- y b) m))))

50
collects/plot/common/utils.rkt
View File

@ -2,7 +2,7 @@
;; Extra functions that can't be easily categorized (i.e. math, vector).
(require racket/sequence racket/list)
(require racket/sequence racket/list racket/match)
(provide (all-defined-out))
@ -13,10 +13,18 @@
e))
(define (list-index v lst [equal? equal?])
(let loop ([lst lst] [idx 0])
(cond [(null? lst) -1]
[(equal? v (car lst)) idx]
[else (loop (cdr lst) (add1 idx))])))
(for/first ([e (in-list lst)] [i (in-naturals)] #:when (equal? e v))
i))
(define (list-duplicate-index lst)
(let loop ([lst lst] [j 0])
(cond [(empty? lst) #f]
[else
(define fst (first lst))
(define idx
(for/first ([e (in-list (rest lst))] [i (in-naturals)] #:when (equal? e fst))
(+ i j 1)))
(if idx idx (loop (rest lst) (+ j 1)))])))
(define (assoc-cons hash key new-value)
(let loop ([hash hash])
@ -28,8 +36,7 @@
[else (cons (first hash) (loop (rest hash)))])])))
(define (vector-find-index pred? xs [start 0] [end (vector-length xs)])
(for/first ([i (in-range start end)]
#:when (pred? (vector-ref xs i)))
(for/first ([i (in-range start end)] #:when (pred? (vector-ref xs i)))
i))
(define ((sorted-apply sort f) lst)
@ -58,6 +65,7 @@
[(andmap (λ (e2) (equiv? e e2)) (first res)) (cons (cons e (first res)) (rest res))]
[else (list* (list e) res)]))]))))
#;
(define (parameterize-procedure t)
(define parameterization (current-parameterization))
(make-keyword-procedure
@ -65,3 +73,31 @@
(call-with-parameterization
parameterization
(λ () (keyword-apply t kws kw-args rest))))))
;; f : any -> any
;; Returns a wrapper for 'f' that preserves most of the parameter values
;; in the dynamic extent where 'parameterize-procedure' is applied.
(define (parameterize-procedure f)
(struct apply-thread (channel thread) #:transparent)
(struct apply-command (kws kw-values rest) #:transparent)
(struct exception-response (exception) #:transparent)
(struct values-response (values) #:transparent)
;; A synchronous channel for commands and responses
(define ch (make-channel))
;; The command loop
(define (command-loop)
(match-define (apply-command kws kw-values rest) (channel-get ch))
(with-handlers ([(λ (e) #t) (λ (e) (channel-put ch (exception-response e)))])
(channel-put ch (call-with-values (λ () (keyword-apply f kws kw-values rest))
(λ vals (values-response vals)))))
(command-loop))
;; Save the thread in a struct so it'll get closed over
(define th (apply-thread ch (thread command-loop)))
;; Return the wrapper
(make-keyword-procedure
(lambda (kws kw-args . rest)
(match-define (apply-thread ch _) th)
(channel-put ch (apply-command kws kw-args rest))
(match (channel-get ch)
[(exception-response e) (raise e)]
[(values-response vals) (apply values vals)]))))

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

@ -78,9 +78,7 @@
[#:label label (or/c string? #f) #f]
) renderer2d?
(define g (2d-function->sampler f))
(renderer2d (vector (ivl x-min x-max) (ivl y-min y-max))
null-bounds-fun
default-ticks-fun
(renderer2d (vector (ivl x-min x-max) (ivl y-min y-max)) #f default-ticks-fun
(contours-render-proc g levels samples colors widths styles alphas label)))
;; ===================================================================================================
@ -175,9 +173,7 @@
[#:label label (or/c string? #f) #f]
) renderer2d?
(define g (2d-function->sampler f))
(renderer2d (vector (ivl x-min x-max) (ivl y-min y-max))
null-bounds-fun
default-ticks-fun
(renderer2d (vector (ivl x-min x-max) (ivl y-min y-max)) #f default-ticks-fun
(contour-intervals-render-proc g levels samples colors styles
contour-colors contour-widths contour-styles
alphas label)))

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

@ -23,6 +23,7 @@
"clip.rkt")
(provide x-axis y-axis axes
x-ticks y-ticks
polar-axes
x-tick-lines y-tick-lines tick-grid
point-label
@ -52,17 +53,8 @@
empty)
(define ((x-axis-ticks-fun y) r)
(match-define (vector _ (ivl y-min y-max)) r)
(define digits (digits-for-range y-min y-max))
(values empty (list (tick y #t (real->plot-label y digits)))))
(defproc (x-axis [y real? 0] [add-y-tick? boolean? #f]
[#:ticks? ticks? boolean? (x-axis-ticks?)]) renderer2d?
(renderer2d (empty-rect 2)
null-bounds-fun
(if add-y-tick? (x-axis-ticks-fun y) null-ticks-fun)
(x-axis-render-proc y ticks?)))
(defproc (x-axis [y real? 0] [#:ticks? ticks? boolean? (x-axis-ticks?)]) renderer2d?
(renderer2d #f #f #f (x-axis-render-proc y ticks?)))
(define ((y-axis-render-proc x ticks?) area)
(define y-min (send area get-y-min))
@ -82,24 +74,24 @@
empty)
(define ((y-axis-ticks-fun x) r)
(match-define (vector (ivl x-min x-max) _) r)
(define digits (digits-for-range x-min x-max))
(values (list (tick x #t (real->plot-label x digits))) empty))
(defproc (y-axis [x real? 0] [#:ticks? ticks? boolean? (y-axis-ticks?)]) renderer2d?
(renderer2d #f #f #f (y-axis-render-proc x ticks?)))
(defproc (y-axis [x real? 0] [add-x-tick? boolean? #f]
[#:ticks? ticks? boolean? (y-axis-ticks?)]) renderer2d?
(renderer2d (empty-rect 2)
null-bounds-fun
(if add-x-tick? (y-axis-ticks-fun x) null-ticks-fun)
(y-axis-render-proc x ticks?)))
(defproc (axes [x real? 0] [y real? 0] [add-x-tick? boolean? #f] [add-y-tick? boolean? #f]
(defproc (axes [x real? 0] [y real? 0]
[#:x-ticks? x-ticks? boolean? (x-axis-ticks?)]
[#:y-ticks? y-ticks? boolean? (y-axis-ticks?)]
) (listof renderer2d?)
(list (x-axis y add-y-tick? #:ticks? x-ticks?)
(y-axis x add-x-tick? #:ticks? y-ticks?)))
(list (x-axis y #:ticks? x-ticks?)
(y-axis x #:ticks? y-ticks?)))
;; ===================================================================================================
;; Ticks
(defproc (x-ticks [ts (listof tick?)]) renderer2d?
(renderer2d #f #f (λ (r) (values ts empty)) #f))
(defproc (y-ticks [ts (listof tick?)]) renderer2d?
(renderer2d #f #f (λ (r) (values empty ts)) #f))
;; ===================================================================================================
;; Polar axes
@ -172,10 +164,7 @@
(defproc (polar-axes [#:number num exact-positive-integer? (polar-axes-number)]
[#:ticks? ticks? boolean? (polar-axes-ticks?)]
) renderer2d?
(renderer2d (empty-rect 2)
null-bounds-fun
null-ticks-fun
(polar-axes-render-proc num ticks?)))
(renderer2d #f #f #f (polar-axes-render-proc num ticks?)))
;; ===================================================================================================
;; Grid
@ -207,10 +196,10 @@
empty)
(defproc (x-tick-lines) renderer2d?
(renderer2d (empty-rect 2) null-bounds-fun null-ticks-fun (x-tick-lines-render-proc)))
(renderer2d #f #f #f (x-tick-lines-render-proc)))
(defproc (y-tick-lines) renderer2d?
(renderer2d (empty-rect 2) null-bounds-fun null-ticks-fun (y-tick-lines-render-proc)))
(renderer2d #f #f #f (y-tick-lines-render-proc)))
(defproc (tick-grid) (listof renderer2d?)
(list (x-tick-lines) (y-tick-lines)))
@ -255,9 +244,7 @@
[#:alpha alpha (real-in 0 1) (label-alpha)]
) renderer2d?
(match-define (vector x y) v)
(renderer2d (vector (ivl x x) (ivl y y))
null-bounds-fun
null-ticks-fun
(renderer2d (vector (ivl x x) (ivl y y)) #f #f
(label-render-proc label v color size anchor angle point-size alpha)))
(defproc (parametric-label

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

@ -57,16 +57,14 @@
) renderer2d?
(define rvs (filter vregular? (append v1s v2s)))
(cond
[(empty? rvs) null-renderer2d]
[(empty? rvs) (renderer2d #f #f #f #f)]
[else
(match-define (list (vector rxs rys) ...) rvs)
(let ([x-min (if x-min x-min (apply min* rxs))]
[x-max (if x-max x-max (apply max* rxs))]
[y-min (if y-min y-min (apply min* rys))]
[y-max (if y-max y-max (apply max* rys))])
(renderer2d (vector (ivl x-min x-max) (ivl y-min y-max))
null-bounds-fun
default-ticks-fun
(renderer2d (vector (ivl x-min x-max) (ivl y-min y-max)) #f default-ticks-fun
(lines-interval-render-proc v1s v2s color style
line1-color line1-width line1-style
line2-color line2-width line2-style

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

@ -36,16 +36,14 @@
[#:label label (or/c string? #f) #f]
) renderer2d?
(define rvs (filter vregular? vs))
(cond [(empty? rvs) null-renderer2d]
(cond [(empty? rvs) (renderer2d #f #f #f #f)]
[else
(match-define (list (vector rxs rys) ...) rvs)
(let ([x-min (if x-min x-min (apply min* rxs))]
[x-max (if x-max x-max (apply max* rxs))]
[y-min (if y-min y-min (apply min* rys))]
[y-max (if y-max y-max (apply max* rys))])
(renderer2d (vector (ivl x-min x-max) (ivl y-min y-max))
null-bounds-fun
default-ticks-fun
(renderer2d (vector (ivl x-min x-max) (ivl y-min y-max)) #f default-ticks-fun
(lines-render-proc vs color width style alpha label)))]))
(defproc (parametric [f (real? . -> . (vector/c real? real?))]

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

@ -19,6 +19,7 @@
"../common/deprecation-warning.rkt"
"../common/renderer.rkt"
"../common/utils.rkt"
"../common/parameter-list.rkt"
"area.rkt")
;; Require lazily: without this, Racket complains while generating documentation:
@ -56,7 +57,9 @@
(define-values (all-x-ticks all-y-ticks)
(for/lists (all-x-ticks all-y-ticks) ([r (in-list rs)])
((renderer-ticks-fun r) bounds-rect)))
(define ticks-fun (renderer-ticks-fun r))
(cond [ticks-fun (ticks-fun bounds-rect)]
[else (values empty empty)])))
(define x-ticks (remove-duplicates (append* all-x-ticks)))
(define y-ticks (remove-duplicates (append* all-y-ticks)))
@ -72,11 +75,11 @@
(define legend-entries
(flatten (for/list ([rend (in-list rs)])
(match-define (renderer2d (vector (ivl rx-min rx-max) (ivl ry-min ry-max))
_bf _tf render-proc)
rend)
(match-define (renderer2d rend-bounds-rect _bf _tf render-proc) rend)
(match-define (vector (ivl rx-min rx-max) (ivl ry-min ry-max))
(if rend-bounds-rect rend-bounds-rect (empty-rect 2)))
(send area start-renderer rx-min rx-max ry-min ry-max)
(render-proc area))))
(if render-proc (render-proc area) empty))))
(send area end-plot)
@ -116,8 +119,10 @@
[#:y-label y-label (or/c string? #f) (plot-y-label)]
[#:legend-anchor legend-anchor anchor/c (plot-legend-anchor)]
) pict?
(dc (parameterize-procedure
(λ (dc x y)
(define saved-parameters (plot-parameters))
(dc (λ (dc x y)
(parameterize/list
([plot-parameters saved-parameters])
(plot/dc renderer-tree dc x y width height
#:x-min x-min #:x-max x-max #:y-min y-min #:y-max y-max
#:title title #:x-label x-label #:y-label y-label #:legend-anchor legend-anchor)))

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

@ -37,15 +37,13 @@
) renderer2d?
(let ([vs (filter vregular? vs)])
(cond
[(empty? vs) null-renderer2d]
[(empty? vs) (renderer2d #f #f #f #f)]
[else (match-define (list (vector xs ys) ...) vs)
(let ([x-min (if x-min x-min (apply min* xs))]
[x-max (if x-max x-max (apply max* xs))]
[y-min (if y-min y-min (apply min* ys))]
[y-max (if y-max y-max (apply max* ys))])
(renderer2d (vector (ivl x-min x-max) (ivl y-min y-max))
null-bounds-fun
default-ticks-fun
(renderer2d (vector (ivl x-min x-max) (ivl y-min y-max)) #f default-ticks-fun
(points-render-fun vs sym color size line-width alpha label)))])))
;; ===================================================================================================
@ -107,9 +105,7 @@
) renderer2d?
(let ([f (cond [(procedure-arity-includes? f 2 #t) f]
[else (λ (x y) (f (vector x y)))])])
(renderer2d (vector (ivl x-min x-max) (ivl y-min y-max))
null-bounds-fun
default-ticks-fun
(renderer2d (vector (ivl x-min x-max) (ivl y-min y-max)) #f default-ticks-fun
(vector-field-render-fun f samples scale color line-width line-style alpha label))))
;; ===================================================================================================
@ -150,15 +146,13 @@
[#:alpha alpha (real-in 0 1) (error-bar-alpha)]
) renderer2d?
(let ([bars (filter vregular? bars)])
(cond [(empty? bars) null-renderer2d]
(cond [(empty? bars) (renderer2d #f #f #f #f)]
[else
(match-define (list (vector xs ys hs) ...) bars)
(let ([x-min (if x-min x-min (apply min* xs))]
[x-max (if x-max x-max (apply max* xs))]
[y-min (if y-min y-min (apply min* (map - ys hs)))]
[y-max (if y-max y-max (apply max* (map + ys hs)))])
(renderer2d
(vector (ivl x-min x-max) (ivl y-min y-max))
null-bounds-fun
default-ticks-fun
(error-bars-render-fun xs ys hs color line-width line-style width alpha)))])))
(renderer2d (vector (ivl x-min x-max) (ivl y-min y-max)) #f default-ticks-fun
(error-bars-render-fun xs ys hs
color line-width line-style width alpha)))])))

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

@ -46,17 +46,15 @@
(define rxs (filter regular? (append x1s x2s)))
(define rys (filter regular? (append y1s y2s)))
(cond
[(or (empty? rxs) (empty? rys)) null-renderer2d]
[(or (empty? rxs) (empty? rys)) (renderer2d #f #f #f #f)]
[else
(let ([x-min (if x-min x-min (apply min* rxs))]
[x-max (if x-max x-max (apply max* rxs))]
[y-min (if y-min y-min (apply min* rys))]
[y-max (if y-max y-max (apply max* rys))])
(renderer2d
(vector (ivl x-min x-max) (ivl y-min y-max))
null-bounds-fun
default-ticks-fun
(rectangles-render-proc rects color style line-color line-width line-style alpha label)))]))
(renderer2d (vector (ivl x-min x-max) (ivl y-min y-max)) #f default-ticks-fun
(rectangles-render-proc rects color style line-color line-width line-style alpha
label)))]))
;; ===================================================================================================
;; Real histograms (or histograms on the real line)
@ -78,7 +76,7 @@
(let* ([bin-bounds (filter regular? bin-bounds)]
[bin-bounds (sort bin-bounds <)])
(cond
[((length bin-bounds) . < . 2) null-renderer2d]
[((length bin-bounds) . < . 2) (renderer2d #f #f #f #f)]
[else
(define xs (linear-seq (apply min* bin-bounds) (apply max* bin-bounds) samples
#:start? #f #:end? #f))
@ -121,7 +119,7 @@
(match-define (list (vector cats ys) ...) cat-vals)
(define rys (filter regular? ys))
(cond
[(empty? rys) null-renderer2d]
[(empty? rys) (renderer2d #f #f #f #f)]
[else
(define n (length cats))
(let* ([x-min (if x-min x-min 0)]
@ -134,8 +132,7 @@
(ivl (+ x1 1/2-gap-size) (- x2 1/2-gap-size))))
(define tick-xs (linear-seq x-min x-max n #:start? #f #:end? #f))
(renderer2d
(vector (ivl x-min x-max) (ivl y-min y-max))
null-bounds-fun
(vector (ivl x-min x-max) (ivl y-min y-max)) #f
(discrete-histogram-ticks-fun cats tick-xs)
(rectangles-render-proc (map (λ (x-ivl y) (vector x-ivl (ivl 0 y))) x-ivls ys)
color style line-color line-width line-style alpha label)))]))

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

@ -83,11 +83,8 @@
[#:label label (or/c string? #f) #f]
) renderer3d?
(define g (3d-function->sampler f))
(renderer3d (vector (ivl x-min x-max) (ivl y-min y-max) (ivl z-min z-max))
null-bounds-fun
default-ticks-fun
(isosurface3d-render-proc g d samples color
line-color line-width line-style alpha
(renderer3d (vector (ivl x-min x-max) (ivl y-min y-max) (ivl z-min z-max)) #f default-ticks-fun
(isosurface3d-render-proc g d samples color line-color line-width line-style alpha
label)))
;; ===================================================================================================
@ -177,9 +174,7 @@
[#:label label (or/c string? #f) #f]
) renderer3d?
(define g (3d-function->sampler f))
(renderer3d (vector (ivl x-min x-max) (ivl y-min y-max) (ivl z-min z-max))
null-bounds-fun
default-ticks-fun
(renderer3d (vector (ivl x-min x-max) (ivl y-min y-max) (ivl z-min z-max)) #f default-ticks-fun
(isosurfaces3d-render-proc g d-min d-max levels samples colors
line-colors line-widths line-styles alphas
label)))
@ -262,7 +257,7 @@
[#:label label (or/c string? #f) #f]
) renderer3d?
(define rvs (filter vregular? (sample-2d-polar f 0 2pi (* 2 samples) -1/2pi 1/2pi samples)))
(cond [(empty? rvs) null-renderer3d]
(cond [(empty? rvs) (renderer3d #f #f #f #f)]
[else
(match-define (list (vector rxs rys rzs) ...) rvs)
(let ([x-min (if x-min x-min (apply min* rxs))]
@ -273,8 +268,7 @@
[z-max (if z-max z-max (apply max* rzs))])
(define new-f (2d-polar->3d-function f))
(define g (3d-function->sampler new-f))
(renderer3d (vector (ivl x-min x-max) (ivl y-min y-max) (ivl z-min z-max))
null-bounds-fun
(renderer3d (vector (ivl x-min x-max) (ivl y-min y-max) (ivl z-min z-max)) #f
default-ticks-fun
(polar3d-render-proc new-f g samples color
line-color line-width line-style alpha label)))]))

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

@ -25,7 +25,7 @@
(define (lines3d-renderer
vs-thnk x-min x-max y-min y-max z-min z-max color width style alpha label)
(define rvs (filter vregular? (vs-thnk)))
(cond [(empty? rvs) null-renderer3d]
(cond [(empty? rvs) (renderer3d #f #f #f #f)]
[else
(match-define (list (vector rxs rys rzs) ...) rvs)
(let ([x-min (if x-min x-min (apply min* rxs))]
@ -34,8 +34,7 @@
[y-max (if y-max y-max (apply max* rys))]
[z-min (if z-min z-min (apply min* rzs))]
[z-max (if z-max z-max (apply max* rzs))])
(renderer3d (vector (ivl x-min x-max) (ivl y-min y-max) (ivl z-min z-max))
null-bounds-fun
(renderer3d (vector (ivl x-min x-max) (ivl y-min y-max) (ivl z-min z-max)) #f
default-ticks-fun
(lines3d-render-proc vs-thnk color width style alpha label)))]))

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

@ -13,6 +13,7 @@
"../common/deprecation-warning.rkt"
"../common/renderer.rkt"
"../common/utils.rkt"
"../common/parameter-list.rkt"
"area.rkt")
;; Require lazily: without this, Racket complains while generating documentation:
@ -52,7 +53,9 @@
(define-values (all-x-ticks all-y-ticks all-z-ticks)
(for/lists (all-x-ticks all-y-ticks all-z-ticks) ([r (in-list rs)])
((renderer-ticks-fun r) bounds-rect)))
(define ticks-fun (renderer-ticks-fun r))
(cond [ticks-fun (ticks-fun bounds-rect)]
[else (values empty empty empty)])))
(define x-ticks (remove-duplicates (append* all-x-ticks)))
(define y-ticks (remove-duplicates (append* all-y-ticks)))
@ -73,12 +76,11 @@
(define legend-entries
(flatten (for/list ([rend (in-list rs)])
(match-define (renderer3d
(vector (ivl rx-min rx-max) (ivl ry-min ry-max) (ivl rz-min rz-max))
_bf _tf render-proc)
rend)
(match-define (renderer3d rend-bounds-rect _bf _tf render-proc) rend)
(match-define (vector (ivl rx-min rx-max) (ivl ry-min ry-max) (ivl rz-min rz-max))
(if rend-bounds-rect rend-bounds-rect (empty-rect 3)))
(send area start-renderer rx-min rx-max ry-min ry-max rz-min rz-max)
(render-proc area))))
(if render-proc (render-proc area) empty))))
(send area end-plot)
@ -131,8 +133,10 @@
[#:z-label z-label (or/c string? #f) (plot-z-label)]
[#:legend-anchor legend-anchor anchor/c (plot-legend-anchor)]
) pict?
(dc (parameterize-procedure
(λ (dc x y)
(define saved-parameters (plot-parameters))
(dc (λ (dc x y)
(parameterize/list
([plot-parameters saved-parameters])
(plot3d/dc renderer-tree dc x y width height
#:x-min x-min #:x-max x-max #:y-min y-min #:y-max y-max #:z-min z-min
#:z-max z-max #:angle angle #:altitude altitude #:title title #:x-label x-label

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

@ -34,7 +34,7 @@
[#:label label (or/c string? #f) #f]
) renderer3d?
(let ([vs (filter vregular? vs)])
(cond [(empty? vs) null-renderer3d]
(cond [(empty? vs) (renderer3d #f #f #f #f)]
[else
(match-define (list (vector xs ys zs) ...) vs)
(let ([x-min (if x-min x-min (apply min* xs))]
@ -43,7 +43,6 @@
[y-max (if y-max y-max (apply max* ys))]
[z-min (if z-min z-min (apply min* zs))]
[z-max (if z-max z-max (apply max* zs))])
(renderer3d (vector (ivl x-min x-max) (ivl y-min y-max) (ivl z-min z-max))
null-bounds-fun
(renderer3d (vector (ivl x-min x-max) (ivl y-min y-max) (ivl z-min z-max)) #f
default-ticks-fun
(points3d-render-proc vs sym color size line-width alpha label)))])))

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

@ -48,7 +48,7 @@
(define rys (filter regular? (append y1s y2s)))
(define rzs (filter regular? (append z1s z2s)))
(cond
[(or (empty? rxs) (empty? rys) (empty? rzs)) null-renderer3d]
[(or (empty? rxs) (empty? rys) (empty? rzs)) (renderer3d #f #f #f #f)]
[else
(let ([x-min (if x-min x-min (apply min* rxs))]
[x-max (if x-max x-max (apply max* rxs))]
@ -56,8 +56,7 @@
[y-max (if y-max y-max (apply max* rys))]
[z-min (if z-min z-min (apply min* rzs))]
[z-max (if z-max z-max (apply max* rzs))])
(renderer3d (vector (ivl x-min x-max) (ivl y-min y-max) (ivl z-min z-max))
null-bounds-fun
(renderer3d (vector (ivl x-min x-max) (ivl y-min y-max) (ivl z-min z-max)) #f
default-ticks-fun
(rectangles3d-render-proc rects color style line-color line-width line-style
alpha label)))]))
@ -97,7 +96,7 @@
(match-define (list (vector cat1s cat2s zs) ...) cat-vals)
(define rzs (filter regular? zs))
(cond
[(empty? rzs) null-renderer3d]
[(empty? rzs) (renderer3d #f #f #f #f)]
[else
(define c1s (remove-duplicates cat1s))
(define c2s (remove-duplicates cat2s))
@ -129,8 +128,7 @@
(adjust/gap (ivl y1 y2) gap)
(ivl 0 z)))
x1s x2s y1s y2s all-zs))
(renderer3d (vector (ivl x-min x-max) (ivl y-min y-max) (ivl z-min z-max))
null-bounds-fun
(renderer3d (vector (ivl x-min x-max) (ivl y-min y-max) (ivl z-min z-max)) #f
(discrete-histogram3d-ticks-fun c1s c2s tick-xs tick-ys)
(rectangles3d-render-proc rects color style line-color line-width line-style
alpha label)))]))

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

@ -78,14 +78,16 @@
(define t1 (stretch-transform -2 -1 4))
(define t2 (stretch-transform 1 2 4))
(values
(parameterize ([plot-x-transform (axis-transform-compose t1 t2)])
(plot (list (y-axis -2) (y-axis -1 #t)
(y-axis 1 #t) (y-axis 2)
(parameterize ([plot-x-transform (axis-transform-compose t1 t2)]
[plot-x-ticks (ticks-add (plot-x-ticks) '(-1 1))])
(plot (list (y-axis -2) (y-axis -1)
(y-axis 1) (y-axis 2)
(function values -3 3)
(function cos -3 3 #:color 3))))
(parameterize ([plot-x-transform (axis-transform-compose t2 t1)])
(plot (list (y-axis -2) (y-axis -1 #t)
(y-axis 1 #t) (y-axis 2)
(parameterize ([plot-x-transform (axis-transform-compose t2 t1)]
[plot-x-ticks (ticks-add (plot-x-ticks) '(-1 1))])
(plot (list (y-axis -2) (y-axis -1)
(y-axis 1) (y-axis 2)
(function values -3 3)
(function cos -3 3 #:color 3))))
(parameterize ([plot-x-transform (axis-transform-compose t2 t1)]
@ -280,8 +282,8 @@
(parameterize ([plot-x-transform (axis-transform-compose (collapse-transform 2 6)
log-transform)]
[plot-x-ticks (log-ticks)])
(plot (list (y-axis 2 #t) (y-axis 6 #t)
[plot-x-ticks (ticks-add (log-ticks) '(2 6))])
(plot (list (y-axis 2) (y-axis 6)
(function values 1 10))))
(let ()

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

@ -5,7 +5,11 @@ exec gracket "$0" "$@"
#lang racket
(require rackunit racket/date
plot plot/utils plot/common/date-time plot/common/vector)
plot plot/utils
plot/common/date-time
plot/common/vector
plot/common/utils
plot/common/parameter-list)
(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))
@ -299,3 +303,117 @@ exec gracket "$0" "$@"
(check-false (vector-ormap (λ (x y) (and (= x 1) (= y 2)))
#(0 0 1 0)
#(0 2 0 0)))
;; ===================================================================================================
;; Parameter lists
(define p1 (make-parameter 1))
(define p2 (make-parameter 2))
(define ps1 (parameter-list p1 p2))
(check-equal? (ps1) (list 1 2))
(check-equal? (parameterize/list () (ps1)) (ps1))
(check-equal? (parameterize*/list () (ps1)) (ps1))
(check-equal? (parameterize/list ([ps1 (list 10 20)]) (ps1))
(list 10 20))
(check-equal? (parameterize/list ([p1 10] [p2 20]) (ps1))
(list 10 20))
(check-equal? (parameterize/list ([ps1 (list 10 20)]) (list (p1) (p2)))
(list 10 20))
(check-equal? (ps1) (list 1 2))
(check-exn exn:fail:contract? (λ () (ps1 (list 1 2 3))))
(check-exn exn:fail:contract? (λ () (parameterize ([ps1 (list 1 2 3)]) (ps1))))
(check-exn exn:fail:contract? (λ () (parameter-list 0)))
(check-exn exn:fail:contract? (λ () (parameter-list* 0 ps1)))
(check-exn exn:fail:contract? (λ () (parameter-list* p1 0)))
(check-exn exn:fail:contract? (λ () (parameter-list-append 0 ps1)))
(check-exn exn:fail:contract? (λ () (parameter-list-append ps1 0)))
(ps1 (list 10 20))
(check-equal? (ps1) (list 10 20))
(check-equal? (parameterize/list ([ps1 (list 1 2)]) (ps1))
(list 1 2))
(check-equal? (parameterize/list ([p1 1] [p2 2]) (ps1))
(list 1 2))
(check-equal? (parameterize/list ([ps1 (list 1 2)]) (list (p1) (p2)))
(list 1 2))
(check-equal? (ps1) (list 10 20))
(p1 1)
(p2 2)
(define p3 (make-parameter 3))
(define ps2 (parameter-list* p3 ps1))
(check-equal? (ps2) (list 3 1 2))
(check-equal? (parameterize/list ([ps2 (list 30 10 20)]) (ps2))
(list 30 10 20))
(check-equal? (parameterize/list ([p3 30] [p1 10] [p2 20]) (ps2))
(list 30 10 20))
(check-equal? (parameterize/list ([ps2 (list 30 10 20)]) (list (p3) (p1) (p2)))
(list 30 10 20))
(check-equal? (ps2) (list 3 1 2))
(ps2 (list 30 10 20))
(check-equal? (ps2) (list 30 10 20))
(check-equal? (parameterize/list ([ps2 (list 3 1 2)]) (ps2))
(list 3 1 2))
(check-equal? (parameterize/list ([p3 3] [p1 1] [p2 2]) (ps2))
(list 3 1 2))
(check-equal? (parameterize/list ([ps2 (list 3 1 2)]) (list (p3) (p1) (p2)))
(list 3 1 2))
(check-equal? (ps2) (list 30 10 20))
(p1 1)
(p2 2)
(p3 3)
(define ps3 (parameter-list-append ps1 (parameter-list p3)))
(check-equal? (ps3) (list 1 2 3))
(check-equal? (parameterize/list ([ps3 (list 10 20 30)]) (ps3))
(list 10 20 30))
(check-equal? (parameterize/list ([p1 10] [p2 20] [p3 30]) (ps3))
(list 10 20 30))
(check-equal? (parameterize/list ([ps3 (list 10 20 30)]) (list (p1) (p2) (p3)))
(list 10 20 30))
(check-equal? (ps3) (list 1 2 3))
(ps3 (list 10 20 30))
(check-equal? (ps3) (list 10 20 30))
(check-equal? (parameterize/list ([ps3 (list 1 2 3)]) (ps3))
(list 1 2 3))
(check-equal? (parameterize/list ([p1 1] [p2 2] [p3 3]) (ps3))
(list 1 2 3))
(check-equal? (parameterize/list ([ps3 (list 1 2 3)]) (list (p1) (p2) (p3)))
(list 1 2 3))
(check-equal? (ps3) (list 10 20 30))
(ps3 (list 1 2 3))
(define p4 (make-parameter 4))
(define p5 (make-parameter 5))
(define ps4 (parameter-list p4 p5))
(define ps5 (parameter-list ps3 ps4))
(check-equal? (ps5) (list (list 1 2 3) (list 4 5)))
(check-equal? (parameterize/list ([ps5 (list (list 10 20 30) (list 40 50))]) (ps5))
(list (list 10 20 30) (list 40 50)))
(check-equal? (parameterize/list ([p1 10] [p2 20] [p3 30] [p4 40] [p5 50]) (ps5))
(list (list 10 20 30) (list 40 50)))
(check-equal? (parameterize/list ([ps5 (list (list 10 20 30) (list 40 50))])
(list (p1) (p2) (p3) (p4) (p5)))
(list 10 20 30 40 50))
(check-equal? (parameterize/list ([ps3 (list 10 20 30)] [ps4 (list 40 50)]) (ps5))
(list (list 10 20 30) (list 40 50)))
(check-equal? (parameterize/list ([ps3 (list 10 20 30)] [ps4 (list (p1) (p2))]) (ps5))
(list (list 10 20 30) (list 1 2)))
(check-equal? (parameterize*/list ([ps3 (list 10 20 30)] [ps4 (list (p1) (p2))]) (ps5))
(list (list 10 20 30) (list 10 20)))
(check-equal? (ps5) (list (list 1 2 3) (list 4 5)))

11
collects/plot/tests/plot2d-tests.rkt
View File

@ -8,9 +8,13 @@
(define xs (build-list 10000 (λ _ (random))))
(plot (density xs 1/2)))
(plot empty #:x-min -1 #:x-max 1 #:y-min -1 #:y-max 1)
(time
(plot empty #:x-min -1 #:x-max 1 #:y-min -1 #:y-max 1))
(plot (list (function values -4 4) (axes 1 2 #t #t)))
(time
(plot (points empty) #:x-min -1 #:x-max 1 #:y-min -1 #:y-max 1))
(plot (list (function values -4 4) (axes 1 2)))
(time (plot (function values 0 1000)))
@ -418,8 +422,9 @@
(time
(define (f x) (/ (sin x) x))
(parameterize ([plot-x-transform (stretch-transform -1 1 10)]
[plot-x-ticks (ticks-add (plot-x-ticks) '(-1 1))]
[plot-y-ticks (fraction-ticks)])
(plot (list (y-axis -1 #t #:ticks? #f) (y-axis 1 #t #:ticks? #f)
(plot (list (y-axis -1 #:ticks? #f) (y-axis 1 #:ticks? #f)
(function f -1 1 #:width 2 #:color 4)
(function f -14 -1 #:color 4 #:label "y = sin(x)/x")
(function f 1 14 #:color 4)

3
collects/plot/tests/plot3d-tests.rkt
View File

@ -7,6 +7,9 @@
(time
(plot3d empty #:x-min -1 #:x-max 1 #:y-min -1 #:y-max 1 #:z-min -1 #:z-max 1))
(time
(plot3d (points3d empty) #:x-min -1 #:x-max 1 #:y-min -1 #:y-max 1 #:z-min -1 #:z-max 1))
(parameterize ([plot-background "black"]
[plot-foreground "white"]
[plot-background-alpha 1/2]

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

@ -4,47 +4,6 @@
(plot-font-family 'swiss)
(define (ticks-scale fun t)
(match-define (invertible-function f g) fun)
(match-define (ticks layout format) t)
(ticks (λ (x-min x-max max-ticks transform)
(define ts (layout (f x-min) (f x-max) max-ticks transform))
(for/list ([t (in-list ts)])
(match-define (pre-tick x major?) t)
(pre-tick (g x) major?)))
(λ (x-min x-max ts)
(format (f x-min) (f x-max) (map (λ (t)
(match-define (pre-tick x major?) t)
(pre-tick (f x) major?))
ts)))))
(define (linear-scale m [b 0])
(invertible-function (λ (x) (+ (* m x) b))
(λ (y) (/ (- y b) m))))
(define exp-scale
(invertible-function exp log))
(parameterize ([plot-y-ticks (ticks-scale (linear-scale 2 1) (plot-y-ticks))])
(plot (list (function sqr -2 2)
(function sin -4 4))))
(parameterize ([plot-y-ticks (ticks-scale exp-scale (log-ticks))])
(plot (list (function sqr -2 2)
(function sin -4 4))))
(parameterize ([plot-y-ticks (ticks-scale exp-scale (log-ticks))])
(plot (function values -10 10)))
(parameterize ([plot-y-transform log-transform]
[plot-y-ticks (log-ticks)])
(plot (function exp -10 10)))
(parameterize ([plot-y-ticks (ticks-append (plot-y-ticks)
(ticks-scale (linear-scale 2 1) (currency-ticks)))])
(plot (function values -4 4)))
#|
(plot (function (λ (x) (count pre-tick-major? ((linear-ticks) 0 x 8 id-transform)))
0.1 10))
@ -66,22 +25,24 @@
[plot-y-ticks (currency-ticks)])
(plot (function values -1 1)))
(currency-ticks-formats uk-currency-formats)
(currency-ticks-scales uk-currency-scales)
(parameterize ([plot-x-ticks (date-ticks)]
[currency-format-strings uk-currency-format-strings]
[currency-scale-suffixes uk-currency-scale-suffixes]
[plot-y-ticks (currency-ticks #:kind 'GBP)])
(plot (function values 101232512 2321236192)))
(parameterize ([currency-format-strings eu-currency-format-strings]
[currency-scale-suffixes eu-currency-scale-suffixes]
[plot-x-ticks (currency-ticks #:kind 'EUR)]
(currency-ticks-formats eu-currency-formats)
(currency-ticks-scales eu-currency-scales)
(parameterize ([plot-x-ticks (currency-ticks #:kind 'EUR)]
[plot-y-ticks (currency-ticks)])
(plot (function (λ (x) (* x 1.377)) 8000000 10000000)
#:title "EUR-USD Conversion, 2011-10-13"
#:x-label "Euros"
#:y-label "Dollars"))
(parameterize ([plot-x-ticks no-ticks])
(parameterize ([plot-x-ticks (no-ticks)])
(plot (function sin -1 4)))
(parameterize ([plot-x-transform log-transform]
@ -121,4 +82,20 @@
(plot (contours (λ (x y) (* 1/2 (+ (sqr x) (sqr y)))) -1 1 -1 1 #:label "z"))
(plot3d (contours3d (λ (x y) (* 1/2 (+ (sqr x) (sqr y)))) -1 1 -1 1 #:label "z"))
|#
(parameterize ([plot-y-ticks (ticks-scale (plot-y-ticks) (linear-scale 2 1))])
(plot (list (function sqr -2 2)
(function sin -4 4))))
(define exp-scale (invertible-function exp log))
(parameterize ([plot-y-ticks (ticks-scale (log-ticks) exp-scale)])
(plot (function values -10 10)))
(parameterize ([plot-y-ticks (ticks-add (no-ticks) '(1/3 2/3))])
(plot (function sin -4 4)))
(plot (list (function sin -4 4)
(points '(#(-3.75 -1/4)) #:size 10)
(x-ticks (list (tick 1.5 #t "3/2") (tick 3 #t "Three")))
(y-ticks (list (tick 1/4 #t "1/4") (tick -1/4 #f "")))))