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

2D stacked histograms, grouped histograms, collapse indistinguishable ticks, doc tests, fixes

Browse Source
This commit is contained in:
Neil Toronto 2011-11-07 15:47:46 -07:00
parent 56f70fb4f2
commit 5bd8481aa7
28 changed files with 719 additions and 484 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -26,8 +26,8 @@
(defproc (apply-axis-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
(defproc (make-axis-transform [f axis-transform/c] [g axis-transform/c]) axis-transform/c
;; Turns any total, surjective, monotone real function and its inverse into an axis transform
(defproc (make-axis-transform [f (real? . -> . real?)] [g (real? . -> . real?)]) 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)))

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

@ -22,9 +22,11 @@
;; A define-with-value form for scribble documentation
(define (def/value def val . pre-flows)
(apply s.nested (s.tabular #:style def/value-table-style
(list (list (s.nested def) 'cont)
(list "=" val)))
(apply s.nested
(s.tabular #:style (s.style 'boxed '())
(list (list (s.nested def))
(list (s.tabular #:style def/value-table-style
(list (list "=" val))))))
pre-flows))
(define def/value-table-style

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

@ -1,16 +1,28 @@
#lang racket/base
(require racket/contract racket/draw racket/class unstable/latent-contract
(require racket/contract racket/draw racket/class unstable/latent-contract unstable/contract
"contract-doc.rkt")
(provide (except-out (all-defined-out) treeof)
(activate-contract-out treeof))
(provide (except-out (all-defined-out)
treeof
maybe-function/c maybe-apply
plot-colors/c pen-widths/c plot-pen-styles/c plot-brush-styles/c alphas/c
labels/c)
(activate-contract-out
treeof
maybe-function/c maybe-apply
plot-colors/c pen-widths/c plot-pen-styles/c plot-brush-styles/c alphas/c
labels/c)
nat/c pos/c truth/c)
;; ===================================================================================================
;; Convenience
(defcontract (treeof [ct (or/c contract? (any/c . -> . any/c))])
(or/c ct (listof (recursive-contract (treeof ct)))))
(defcontract contract/c (or/c contract? (any/c . -> . any/c)))
(defcontract (treeof [elem-contract contract/c])
(or/c elem-contract
(listof (recursive-contract (treeof elem-contract)))))
;; ===================================================================================================
;; Plot-specific contracts
@ -61,17 +73,28 @@
(defcontract point-sym/c (or/c char? string? integer? (apply one-of/c known-point-symbols)))
(defcontract plot-colors/c (or/c (listof plot-color/c)
((listof real?) . -> . (listof plot-color/c))))
(defcontract (maybe-function/c [in-contract contract/c] [out-contract contract/c])
(or/c out-contract (in-contract . -> . out-contract)))
(defcontract pen-widths/c (or/c (listof (>=/c 0))
((listof real?) . -> . (listof (>=/c 0)))))
(defproc (maybe-apply [f (maybe-function/c any/c any/c)]
[arg any/c]) any/c
(cond [(procedure? f) (f arg)]
[else f]))
(defcontract plot-pen-styles/c (or/c (listof plot-pen-style/c)
((listof real?) . -> . (listof plot-pen-style/c))))
(defcontract (plot-colors/c [in-contract contract/c])
(maybe-function/c in-contract (listof plot-color/c)))
(defcontract plot-brush-styles/c (or/c (listof plot-brush-style/c)
((listof real?) . -> . (listof plot-brush-style/c))))
(defcontract (pen-widths/c [in-contract contract/c])
(maybe-function/c in-contract (listof (>=/c 0))))
(defcontract alphas/c (or/c (listof (real-in 0 1))
((listof real?) . -> . (listof (real-in 0 1)))))
(defcontract (plot-pen-styles/c [in-contract contract/c])
(maybe-function/c in-contract (listof plot-pen-style/c)))
(defcontract (plot-brush-styles/c [in-contract contract/c])
(maybe-function/c in-contract (listof plot-brush-style/c)))
(defcontract (alphas/c [in-contract contract/c])
(maybe-function/c in-contract (listof (real-in 0 1))))
(defcontract (labels/c [in-contract contract/c])
(maybe-function/c in-contract (listof (or/c string? #f))))

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

@ -202,11 +202,6 @@
(defproc (alpha-expt [a (real-in 0 1)] [n (>/c 0)]) real?
(- 1 (expt (- 1 a) n)))
(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]))
;; ===================================================================================================
;; Subdividing nonlinearly transformed shapes

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

@ -28,14 +28,16 @@
(send pd draw-line (vector x-min y) (vector x-max y)))))
(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]
[colors (plot-colors/c (listof real?))]
[widths (pen-widths/c (listof real?))]
[styles (plot-pen-styles/c (listof real?))]
) (listof legend-entry?)
(define hash
(for/fold ([hash empty]) ([z (in-list zs)]
[z-label (in-list z-labels)]
[color (in-cycle (maybe-apply/list colors zs))]
[width (in-cycle (maybe-apply/list widths zs))]
[style (in-cycle (maybe-apply/list styles zs))])
[color (in-cycle (maybe-apply colors zs))]
[width (in-cycle (maybe-apply widths zs))]
[style (in-cycle (maybe-apply styles zs))])
(assoc-cons hash (list color width style) z-label)))
(reverse
@ -50,46 +52,49 @@
;; Rectangle legends
(defproc (rectangle-legend-entry [label string?]
[fill-color plot-color/c] [fill-style plot-brush-style/c]
[color plot-color/c] [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 (λ (pd rect)
(send pd set-brush fill-color fill-style)
(send pd set-brush color style)
(send pd set-pen line-color line-width line-style)
(send pd set-alpha 1)
(send pd draw-rect rect))))
(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?)
[colors (plot-colors/c (listof real?))]
[styles (plot-brush-styles/c (listof real?))]
[line-colors (plot-colors/c (listof real?))]
[line-widths (pen-widths/c (listof real?))]
[line-styles (plot-pen-styles/c (listof real?))]
) (listof legend-entry?)
(define z-min (first zs))
(define z-max (last zs))
(define digits (digits-for-range z-min z-max))
(define hash
(for/fold ([hash empty]) ([z (in-list zs)]
[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))]
[line-width (in-cycle (maybe-apply/list line-widths zs))]
[line-style (in-cycle (maybe-apply/list line-styles zs))])
[color (in-cycle (maybe-apply colors zs))]
[style (in-cycle (maybe-apply styles zs))]
[line-color (in-cycle (maybe-apply line-colors zs))]
[line-width (in-cycle (maybe-apply line-widths zs))]
[line-style (in-cycle (maybe-apply line-styles zs))])
(define entry-label (real->plot-label z digits))
(assoc-cons hash (list fill-color fill-style line-color line-width line-style) entry-label)))
(assoc-cons hash (list color style line-color line-width line-style) entry-label)))
(reverse
(for/list ([entry (in-list hash)])
(match-define (cons (list fill-color fill-style line-color line-width line-style) vs) entry)
(match-define (cons (list color style line-color line-width line-style) vs) entry)
(rectangle-legend-entry (if (= 1 (length vs))
(format "~a = ~a" label (first vs))
(format "~a ∈ {~a}" label (string-join (reverse vs) ",")))
fill-color fill-style line-color line-width line-style))))
color style line-color line-width line-style))))
;; ===================================================================================================
;; Interval legends
(defproc (interval-legend-entry
[label string?]
[fill-color plot-color/c] [fill-style plot-brush-style/c]
[color plot-color/c] [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]
@ -99,7 +104,7 @@
(send pd set-alpha 1)
;; rectangle
(send pd set-pen line-color line-width line-style)
(send pd set-brush fill-color fill-style)
(send pd set-brush color style)
(send pd draw-rect rect)
;; bottom line
(send pd set-pen line1-color line1-width line1-style)
@ -108,69 +113,50 @@
(send pd set-pen line2-color line2-width line2-style)
(send pd draw-line (vector x-min y-min) (vector x-max y-min)))))
(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?)
(defproc (interval-legend-entries [label string?] [ivls (listof ivl?)] [ivl-labels (listof string?)]
[colors (plot-colors/c (listof ivl?))]
[styles (plot-brush-styles/c (listof ivl?))]
[line-colors (plot-colors/c (listof ivl?))]
[line-widths (pen-widths/c (listof ivl?))]
[line-styles (plot-pen-styles/c (listof ivl?))]
[line1-colors (plot-colors/c (listof ivl?))]
[line1-widths (pen-widths/c (listof ivl?))]
[line1-styles (plot-pen-styles/c (listof ivl?))]
[line2-colors (plot-colors/c (listof ivl?))]
[line2-widths (pen-widths/c (listof ivl?))]
[line2-styles (plot-pen-styles/c (listof ivl?))]
) (listof legend-entry?)
(define hash
(for/fold ([hash empty]) ([za (in-list zs)]
[zb (in-list (rest zs))]
[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))]
[line-width (in-cycle (maybe-apply/list line-widths zs))]
[line-style (in-cycle (maybe-apply/list line-styles zs))]
[line1-color (in-cycle (maybe-apply/list line1-colors zs))]
[line1-width (in-cycle (maybe-apply/list line1-widths zs))]
[line1-style (in-cycle (maybe-apply/list line1-styles zs))]
[line2-color (in-cycle (maybe-apply/list line2-colors zs))]
[line2-width (in-cycle (maybe-apply/list line2-widths zs))]
[line2-style (in-cycle (maybe-apply/list line2-styles zs))])
(define entry-label (format "[~a,~a]" la lb))
(for/fold ([hash empty]) ([ivl-label (in-list ivl-labels)]
[color (in-cycle (maybe-apply colors ivls))]
[style (in-cycle (maybe-apply styles ivls))]
[line-color (in-cycle (maybe-apply line-colors ivls))]
[line-width (in-cycle (maybe-apply line-widths ivls))]
[line-style (in-cycle (maybe-apply line-styles ivls))]
[line1-color (in-cycle (maybe-apply line1-colors ivls))]
[line1-width (in-cycle (maybe-apply line1-widths ivls))]
[line1-style (in-cycle (maybe-apply line1-styles ivls))]
[line2-color (in-cycle (maybe-apply line2-colors ivls))]
[line2-width (in-cycle (maybe-apply line2-widths ivls))]
[line2-style (in-cycle (maybe-apply line2-styles ivls))])
(assoc-cons hash
(list fill-color fill-style line-color line-width line-style
(list color style line-color line-width line-style
line1-color line1-width line1-style
line2-color line2-width line2-style)
entry-label)))
ivl-label)))
(reverse
(for/list ([entry (in-list hash)])
(match-define (cons (list fill-color fill-style line-color line-width line-style
(match-define (cons (list color style line-color line-width line-style
line1-color line1-width line1-style
line2-color line2-width line2-style)
vs)
ivl-labels)
entry)
(interval-legend-entry (format "~a ∈ ~a" label (string-join (reverse vs) " ∪ "))
fill-color fill-style line-color line-width line-style
(interval-legend-entry (format "~a ∈ ~a" label (string-join (reverse ivl-labels) " ∪ "))
color style line-color line-width line-style
line1-color line1-width line1-style
line2-color line2-width line2-style))))
(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)
(list 0)))
(define cws (append (list 0)
(sequence-take (in-cycle (maybe-apply/list contour-widths zs)) 0 n)
(list 0)))
(define css (append '(transparent)
(sequence-take (in-cycle (maybe-apply/list contour-styles zs)) 0 n)
'(transparent)))
(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

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

@ -7,7 +7,8 @@
"contract-doc.rkt"
"draw.rkt"
"axis-transform.rkt"
"ticks.rkt")
"ticks.rkt"
"math.rkt")
(provide (all-defined-out))
@ -78,7 +79,7 @@
plot-animating?))
(defproc (pen-gap) real? #:document-body
(* 2 (plot-line-width)))
(max 1 (* 2 (plot-line-width))))
(defproc (animated-samples [samples (and/c exact-integer? (>=/c 2))]
) (and/c exact-integer? (>=/c 2)) #:document-body
@ -222,6 +223,7 @@
(defparam vector-field-line-style plot-pen-style/c 'solid)
(defparam vector-field-scale (or/c real? (one-of/c 'auto 'normalized)) 'auto)
(defparam vector-field-alpha (real-in 0 1) 1)
(defparam vector-field3d-samples exact-positive-integer? 9)
;; Error bars
@ -237,22 +239,22 @@
(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) #:document-body
(defproc (default-contour-fill-colors [z-ivls (listof ivl?)]) (listof plot-color/c) #:document-body
(color-seq* (list (->brush-color 5) (->brush-color 0) (->brush-color 1))
(sub1 (length zs))))
(length z-ivls)))
(defparam contour-samples (and/c exact-integer? (>=/c 2)) 51)
(defparam contour-levels (or/c 'auto exact-positive-integer? (listof real?)) 'auto)
(defparam contour-colors plot-colors/c default-contour-colors)
(defparam contour-widths pen-widths/c '(1))
(defparam contour-styles plot-pen-styles/c '(solid long-dash))
(defparam contour-alphas alphas/c '(1))
(defparam contour-colors (plot-colors/c (listof real?)) default-contour-colors)
(defparam contour-widths (pen-widths/c (listof real?)) '(1))
(defparam contour-styles (plot-pen-styles/c (listof real?)) '(solid long-dash))
(defparam contour-alphas (alphas/c (listof real?)) '(1))
(defparam contour-interval-colors plot-colors/c default-contour-fill-colors)
(defparam contour-interval-styles plot-brush-styles/c '(solid))
(defparam contour-interval-alphas alphas/c '(1))
(defparam contour-interval-colors (plot-colors/c (listof ivl?)) default-contour-fill-colors)
(defparam contour-interval-styles (plot-brush-styles/c (listof ivl?)) '(solid))
(defparam contour-interval-alphas (alphas/c (listof ivl?)) '(1))
;; Histograms
;; Rectangles
(defparam rectangle-color plot-color/c 3)
(defparam rectangle-style plot-brush-style/c 'solid)
@ -260,7 +262,17 @@
(defparam rectangle-line-width (>=/c 0) 1)
(defparam rectangle-line-style plot-pen-style/c 'solid)
(defparam rectangle-alpha (real-in 0 1) 1)
(defparam rectangle3d-line-width (>=/c 0) 1/3)
(defparam discrete-histogram-gap (real-in 0 1) 1/8)
(defparam discrete-histogram-skip (>=/c 0) 1)
(defparam stacked-histogram-colors (plot-colors/c nat/c) (λ (n) (build-list n add1)))
(defparam stacked-histogram-styles (plot-brush-styles/c nat/c) '(solid))
(defparam stacked-histogram-line-colors (plot-colors/c nat/c) (stacked-histogram-colors))
(defparam stacked-histogram-line-widths (pen-widths/c nat/c) '(1))
(defparam stacked-histogram-line-styles (plot-pen-styles/c nat/c) '(solid))
(defparam stacked-histogram-alphas (alphas/c nat/c) '(1))
;; Decorations
@ -301,9 +313,9 @@
;; Contour surfaces
(defparam contour-interval-line-colors plot-colors/c '(0))
(defparam contour-interval-line-widths pen-widths/c '(1/3))
(defparam contour-interval-line-styles plot-pen-styles/c '(solid))
(defparam contour-interval-line-colors (plot-colors/c (listof ivl?)) '(0))
(defparam contour-interval-line-widths (pen-widths/c (listof ivl?)) '(1/3))
(defparam contour-interval-line-styles (plot-pen-styles/c (listof ivl?)) '(solid))
;; Isosurfaces
@ -316,12 +328,9 @@
(length zs)))
(defparam isosurface-levels (or/c 'auto exact-positive-integer? (listof real?)) 'auto)
(defparam isosurface-colors plot-colors/c default-isosurface-colors)
(defparam isosurface-line-colors plot-colors/c default-isosurface-line-colors)
(defparam isosurface-line-widths pen-widths/c '(1/3))
(defparam isosurface-line-styles plot-pen-styles/c '(solid))
(defparam isosurface-alphas alphas/c '(1/2))
;; Histograms
(defparam rectangle3d-line-width (>=/c 0) 1/3)
(defparam isosurface-colors (plot-colors/c (listof real?)) default-isosurface-colors)
(defparam isosurface-styles (plot-brush-styles/c (listof real?)) '(solid))
(defparam isosurface-line-colors (plot-colors/c (listof real?)) default-isosurface-line-colors)
(defparam isosurface-line-widths (pen-widths/c (listof real?)) '(1/3))
(defparam isosurface-line-styles (plot-pen-styles/c (listof real?)) '(solid))
(defparam isosurface-alphas (alphas/c (listof real?)) '(1/2))

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

@ -624,21 +624,28 @@
;; ===================================================================================================
;; Tick utils
(defproc (collapse-nearby-ticks [ts (listof tick?)]
[near? (tick? tick? . -> . boolean?)]
[format-string string? "~a|~a"]) (listof tick?)
(let* ([ts (sort ts < #:key pre-tick-value)])
(define (same-label? t1 t2) (string=? (tick-label t1) (tick-label t2)))
(define (collapse-equiv-ticks ts near-format-string)
(match-define (list (tick xs majors labels) ...) ts)
(define x (/ (apply + xs) (length ts)))
(define major? (ormap values majors))
(define label1 (first labels))
(define label2 (last labels))
(define label
(cond [(string=? label1 label2) label1]
[else (format near-format-string label1 label2)]))
(tick x major? label))
(defproc (collapse-ticks [ts (listof tick?)] [near? (tick? tick? . -> . boolean?)]
[near-format-string string? "~a|~a"]) (listof tick?)
(let ([ts (sort ts < #:key pre-tick-value)])
(append*
(for/list ([ts (in-list (group-neighbors ts near?))])
(for/list ([ts (in-list (group-neighbors
ts (λ (t1 t2) (or (same-label? t1 t2) (near? t1 t2)))))])
(define n (length ts))
(define m (count pre-tick-major? ts))
(cond [(n . <= . 1) ts]
[(m . = . 0) (match-define (list (tick xs _ labels) ...) ts)
(define x (/ (apply + xs) n))
(define label (format format-string (first labels) (last labels)))
(list (tick x #f label))]
[(m . = . 0) (list (collapse-equiv-ticks ts near-format-string))]
[(m . = . 1) (filter pre-tick-major? ts)]
[else (match-define (list (tick xs _ labels) ...) (filter pre-tick-major? ts))
(define x (/ (apply + xs) m))
(define label (format format-string (first labels) (last labels)))
(list (tick x #t label))])))))
[else (list (collapse-equiv-ticks (filter pre-tick-major? ts) near-format-string))])))))

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

@ -1,6 +1,6 @@
#lang racket/base
;; Extra functions that can't be easily categorized (i.e. math, vector).
;; Extra functions that can't be easily categorized
(require racket/sequence racket/list racket/math racket/flonum racket/match)
@ -44,8 +44,10 @@
(make-hash (map cons sorted-lst (f sorted-lst)))))
(map (λ (e) (hash-ref h e)) lst))
(define (transpose lsts)
(apply map list lsts))
(define (transpose xss)
(cond [(andmap empty? xss) empty]
[else (cons (map (λ (xs) (if (empty? xs) #f (first xs))) xss)
(transpose (map (λ (xs) (if (empty? xs) empty (rest xs))) xss)))]))
(define (group-neighbors lst equiv?)
(reverse

3
collects/plot/contracted/draw.rkt
View File

@ -5,5 +5,4 @@
(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))
alpha-expt))

1
collects/plot/contracted/legend.rkt
View File

@ -12,6 +12,5 @@
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))

10
collects/plot/contracted/parameters.rkt
View File

@ -41,14 +41,19 @@
vector-field-color vector-field-line-width vector-field-line-style
vector-field-scale
vector-field-alpha
vector-field3d-samples
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
discrete-histogram-gap
discrete-histogram-skip
stacked-histogram-colors stacked-histogram-styles
stacked-histogram-line-colors stacked-histogram-line-widths stacked-histogram-line-styles
stacked-histogram-alphas
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?
@ -58,7 +63,8 @@
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-colors isosurface-styles
isosurface-line-colors isosurface-line-widths isosurface-line-styles
isosurface-alphas
;; Functions
pen-gap

2
collects/plot/contracted/ticks.rkt
View File

@ -22,4 +22,4 @@
currency-ticks-scales currency-ticks-formats
currency-ticks-layout currency-ticks-format currency-ticks
fraction-ticks-format fraction-ticks
collapse-nearby-ticks))
collapse-ticks))

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

@ -30,7 +30,7 @@
#:samples samples #:width width #:color color)])]))
(define (contour-renderer f samples width color levels)
(isolines f #:samples samples #:levels (if (exact-integer? levels) (sub1 levels) levels)
(contours f #:samples samples #:levels (if (exact-integer? levels) (sub1 levels) levels)
#:colors (list color) #:widths (list width) #:styles '(solid)))
(define (shade-fill-colors zs)

10
collects/plot/main.rkt
View File

@ -44,11 +44,10 @@
lines-interval parametric-interval polar-interval function-interval inverse-interval))
(require "plot2d/contour.rkt")
(provide (activate-contract-out contours contour-intervals
isoline isolines isoline-intervals))
(provide (activate-contract-out isoline contours contour-intervals))
(require "plot2d/rectangle.rkt")
(provide (activate-contract-out rectangles area-histogram discrete-histogram))
(provide (activate-contract-out rectangles area-histogram discrete-histogram stacked-histogram))
(require "plot2d/decoration.rkt")
(provide (activate-contract-out
@ -70,14 +69,13 @@
(provide (activate-contract-out surface3d))
(require "plot3d/contour.rkt")
(provide (activate-contract-out contour3d contours3d contour-intervals3d
isoline3d isolines3d isoline-intervals3d))
(provide (activate-contract-out isoline3d contours3d contour-intervals3d))
(require "plot3d/line.rkt")
(provide (activate-contract-out lines3d parametric3d))
(require "plot3d/point.rkt")
(provide (activate-contract-out points3d))
(provide (activate-contract-out points3d vector-field3d))
(require "plot3d/isosurface.rkt")
(provide (activate-contract-out isosurface3d isosurfaces3d polar3d))

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

@ -4,11 +4,10 @@
(require racket/contract racket/class racket/match racket/list racket/flonum racket/vector racket/math
plot/utils
"../common/contract-doc.rkt")
"../common/contract-doc.rkt"
"../common/utils.rkt")
(provide (all-defined-out)
(rename-out [contours isolines]
[contour-intervals isoline-intervals]))
(provide (all-defined-out))
;; ===================================================================================================
;; One contour line
@ -66,35 +65,34 @@
(match-define (list (tick zs _ labels) ...) (contour-ticks z-min z-max levels #f))
(define cs (maybe-apply/list colors zs))
(define ws (maybe-apply/list widths zs))
(define ss (maybe-apply/list styles zs))
(define as (maybe-apply/list alphas zs))
(for ([z (in-list zs)]
[color (in-cycle cs)]
[width (in-cycle ws)]
[style (in-cycle ss)]
[alpha (in-cycle as)])
(send area put-alpha alpha)
(send area put-pen color width style)
(for ([ya (in-list ys)]
[yb (in-list (rest ys))]
[zs0 (in-vector zss)]
[zs1 (in-vector zss 1)]
#:when #t
[xa (in-list xs)]
[xb (in-list (rest xs))]
[z1 (in-vector zs0)]
[z2 (in-vector zs0 1)]
[z3 (in-vector zs1 1)]
[z4 (in-vector zs1)])
(for/list ([line (in-list (heights->lines xa xb ya yb z z1 z2 z3 z4))])
(match-define (list v1 v2) (map (λ (v) (vector-take v 2)) line))
(send area put-line v1 v2))))
(cond [label (line-legend-entries label zs labels colors widths styles)]
[else empty])))
(let ([colors (maybe-apply colors zs)]
[widths (maybe-apply widths zs)]
[styles (maybe-apply styles zs)]
[alphas (maybe-apply alphas zs)])
(for ([z (in-list zs)]
[color (in-cycle colors)]
[width (in-cycle widths)]
[style (in-cycle styles)]
[alpha (in-cycle alphas)])
(send area put-alpha alpha)
(send area put-pen color width style)
(for ([ya (in-list ys)]
[yb (in-list (rest ys))]
[zs0 (in-vector zss)]
[zs1 (in-vector zss 1)]
#:when #t
[xa (in-list xs)]
[xb (in-list (rest xs))]
[z1 (in-vector zs0)]
[z2 (in-vector zs0 1)]
[z3 (in-vector zs1 1)]
[z4 (in-vector zs1)])
(for/list ([line (in-list (heights->lines xa xb ya yb z z1 z2 z3 z4))])
(match-define (list v1 v2) (map (λ (v) (vector-take v 2)) line))
(send area put-line v1 v2))))
(cond [label (line-legend-entries label zs labels colors widths styles)]
[else empty]))))
(defproc (contours
[f (real? real? . -> . real?)]
@ -102,12 +100,12 @@
[x-max (or/c regular-real? #f) #f]
[y-min (or/c regular-real? #f) #f]
[y-max (or/c regular-real? #f) #f]
[#:levels levels (or/c 'auto exact-positive-integer? (listof real?)) (contour-levels)]
[#:samples samples (and/c exact-integer? (>=/c 2)) (contour-samples)]
[#:colors colors plot-colors/c (contour-colors)]
[#:widths widths pen-widths/c (contour-widths)]
[#:styles styles plot-pen-styles/c (contour-styles)]
[#:alphas alphas alphas/c (contour-alphas)]
[#:levels levels (or/c 'auto exact-positive-integer? (listof real?)) (contour-levels)]
[#:colors colors (plot-colors/c (listof real?)) (contour-colors)]
[#:widths widths (pen-widths/c (listof real?)) (contour-widths)]
[#:styles styles (plot-pen-styles/c (listof real?)) (contour-styles)]
[#:alphas alphas (alphas/c (listof real?)) (contour-alphas)]
[#:label label (or/c string? #f) #f]
) renderer2d?
(define g (2d-function->sampler f))
@ -127,60 +125,79 @@
(match-define (list (tick zs _ labels) ...) (contour-ticks z-min z-max levels #t))
(define cs (map ->brush-color (maybe-apply/list colors zs)))
(define fss (map ->brush-style (maybe-apply/list styles zs)))
(define pss (map (λ (fill-style) (if (eq? fill-style 'solid) 'solid 'transparent)) fss))
(define as (maybe-apply/list alphas zs))
(define-values (z-ivls ivl-labels)
(for/lists (z-ivls ivl-labels) ([za (in-list zs)]
[zb (in-list (rest zs))]
[la (in-list labels)]
[lb (in-list (rest labels))])
(values (ivl za zb) (format "[~a,~a]" la lb))))
(for ([za (in-list zs)]
[zb (in-list (rest zs))]
[color (in-cycle cs)]
[fill-style (in-cycle fss)]
[poly-line-style (in-cycle pss)]
[alpha (in-cycle as)])
(define polys
(append*
(for/list ([ya (in-list ys)]
[yb (in-list (rest ys))]
[zs0 (in-vector zss)]
[zs1 (in-vector zss 1)]
#:when #t
[xa (in-list xs)]
[xb (in-list (rest xs))]
[z1 (in-vector zs0)]
[z2 (in-vector zs0 1)]
[z3 (in-vector zs1 1)]
[z4 (in-vector zs1)])
(for/list ([poly (in-list (heights->polys xa xb ya yb za zb z1 z2 z3 z4))])
(map (λ (v) (vector-take v 2)) poly)))))
(let ([colors (map ->brush-color (maybe-apply colors z-ivls))]
[styles (map ->brush-style (maybe-apply styles z-ivls))]
[alphas (maybe-apply alphas z-ivls)])
(define line-styles (map (λ (style) (if (eq? style 'solid) 'solid 'transparent)) styles))
(define (draw-polys)
(for ([poly (in-list polys)])
(send area put-polygon poly)))
(for ([za (in-list zs)]
[zb (in-list (rest zs))]
[color (in-cycle colors)]
[style (in-cycle styles)]
[alpha (in-cycle alphas)]
[line-style (in-cycle line-styles)])
(define polys
(append*
(for/list ([ya (in-list ys)]
[yb (in-list (rest ys))]
[zs0 (in-vector zss)]
[zs1 (in-vector zss 1)]
#:when #t
[xa (in-list xs)]
[xb (in-list (rest xs))]
[z1 (in-vector zs0)]
[z2 (in-vector zs0 1)]
[z3 (in-vector zs1 1)]
[z4 (in-vector zs1)])
(for/list ([poly (in-list (heights->polys xa xb ya yb za zb z1 z2 z3 z4))])
(map (λ (v) (vector-take v 2)) poly)))))
(define (draw-polys)
(for ([poly (in-list polys)])
(send area put-polygon poly)))
(cond [(= alpha 1)
(send area put-pen color 1 line-style)
(send area put-brush color style)
(send area put-alpha 1)
(draw-polys)]
[else
;; draw the outlines with reduced alpha first
(send area put-pen color 1 line-style)
(send area put-brush color 'transparent)
(send area put-alpha (alpha-expt alpha 1/8))
(draw-polys)
;; now draw the centers
(send area put-pen color 1 'transparent)
(send area put-brush color style)
(send area put-alpha alpha)
(draw-polys)]))
(cond [(= alpha 1)
(send area put-pen color 1 poly-line-style)
(send area put-brush color fill-style)
(send area put-alpha 1)
(draw-polys)]
[else
;; draw the outlines with reduced alpha first
(send area put-pen color 1 poly-line-style)
(send area put-brush color 'transparent)
(send area put-alpha (alpha-expt alpha 1/8))
(draw-polys)
;; now draw the centers
(send area put-pen color 1 'transparent)
(send area put-brush color fill-style)
(send area put-alpha alpha)
(draw-polys)]))
((contours-render-proc g levels samples contour-colors contour-widths contour-styles alphas #f)
area)
(cond [label (contour-intervals-legend-entries
label zs labels cs fss cs '(1) pss contour-colors contour-widths contour-styles)]
[else empty])))
((contours-render-proc g levels samples contour-colors contour-widths contour-styles alphas #f)
area)
(define n (- (length zs) 2))
(define contour-colors*
(append (list 0) (sequence-take (in-cycle (maybe-apply contour-colors zs)) 0 n) (list 0)))
(define contour-widths*
(append (list 0) (sequence-take (in-cycle (maybe-apply contour-widths zs)) 0 n) (list 0)))
(define contour-styles*
(append '(transparent) (sequence-take (in-cycle (maybe-apply contour-styles zs)) 0 n)
'(transparent)))
(cond [label (interval-legend-entries
label z-ivls ivl-labels
colors styles colors '(1) line-styles
contour-colors* contour-widths* contour-styles*
(rest contour-colors*) (rest contour-widths*) (rest contour-styles*))]
[else empty]))))
(defproc (contour-intervals
[f (real? real? . -> . real?)]
@ -188,14 +205,14 @@
[x-max (or/c regular-real? #f) #f]
[y-min (or/c regular-real? #f) #f]
[y-max (or/c regular-real? #f) #f]
[#:levels levels (or/c 'auto exact-positive-integer? (listof real?)) (contour-levels)]
[#:samples samples (and/c exact-integer? (>=/c 2)) (contour-samples)]
[#:colors colors plot-colors/c (contour-interval-colors)]
[#:styles styles plot-brush-styles/c (contour-interval-styles)]
[#:contour-colors contour-colors plot-colors/c (contour-colors)]
[#:contour-widths contour-widths pen-widths/c (contour-widths)]
[#:contour-styles contour-styles plot-pen-styles/c (contour-styles)]
[#:alphas alphas alphas/c (contour-interval-alphas)]
[#:levels levels (or/c 'auto exact-positive-integer? (listof real?)) (contour-levels)]
[#:colors colors (plot-colors/c (listof ivl?)) (contour-interval-colors)]
[#:styles styles (plot-brush-styles/c (listof ivl?)) (contour-interval-styles)]
[#:contour-colors contour-colors (plot-colors/c (listof real?)) (contour-colors)]
[#:contour-widths contour-widths (pen-widths/c (listof real?)) (contour-widths)]
[#:contour-styles contour-styles (plot-pen-styles/c (listof real?)) (contour-styles)]
[#:alphas alphas (alphas/c (listof ivl?)) (contour-interval-alphas)]
[#:label label (or/c string? #f) #f]
) renderer2d?
(define g (2d-function->sampler f))

18
collects/plot/plot2d/plot-area.rkt
View File

@ -140,17 +140,17 @@
(vector x (pre-tick-value t2))))
(define x-ticks
(collapse-nearby-ticks (filter (λ (t) (<= x-min (pre-tick-value t) x-max)) rx-ticks)
(x-tick-near? y-min)))
(collapse-ticks (filter (λ (t) (<= x-min (pre-tick-value t) x-max)) rx-ticks)
(x-tick-near? y-min)))
(define x-far-ticks
(collapse-nearby-ticks (filter (λ (t) (<= x-min (pre-tick-value t) x-max)) rx-far-ticks)
(x-tick-near? y-max)))
(collapse-ticks (filter (λ (t) (<= x-min (pre-tick-value t) x-max)) rx-far-ticks)
(x-tick-near? y-max)))
(define y-ticks
(collapse-nearby-ticks (filter (λ (t) (<= y-min (pre-tick-value t) y-max)) ry-ticks)
(y-tick-near? x-min)))
(collapse-ticks (filter (λ (t) (<= y-min (pre-tick-value t) y-max)) ry-ticks)
(y-tick-near? x-min)))
(define y-far-ticks
(collapse-nearby-ticks (filter (λ (t) (<= y-min (pre-tick-value t) y-max)) ry-far-ticks)
(y-tick-near? x-max)))
(collapse-ticks (filter (λ (t) (<= y-min (pre-tick-value t) y-max)) ry-far-ticks)
(y-tick-near? x-max)))
;; ===============================================================================================
;; Tick and label parameters, and fixpoint margin computation
@ -345,7 +345,7 @@
(define (draw-labels)
(for ([params (in-list (get-all-label-params))])
(send/apply pd draw-text params)))
(send/apply pd draw-text params #:outline? #t)))
;; ===============================================================================================
;; Public drawing control (used by plot/dc)

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

@ -103,12 +103,13 @@
(default-y-ticks y-min y-max) (default-y-far-ticks y-min y-max)))
(defproc (discrete-histogram
[cat-vals (listof (vector/c any/c real?))]
[cat-vals (listof (vector/c any/c (or/c real? ivl? #f)))]
[#:x-min x-min (or/c regular-real? #f) 0]
[#:x-max x-max (or/c regular-real? #f) #f]
[#:y-min y-min (or/c regular-real? #f) 0]
[#:y-max y-max (or/c regular-real? #f) #f]
[#:gap gap (real-in 0 1) (discrete-histogram-gap)]
[#:skip skip (>=/c 0) (discrete-histogram-skip)]
[#:color color plot-color/c (rectangle-color)]
[#:style style plot-brush-style/c (rectangle-style)]
[#:line-color line-color plot-color/c (rectangle-line-color)]
@ -119,22 +120,64 @@
[#:far-ticks? far-ticks? boolean? #f]
) renderer2d?
(match-define (list (vector cats ys) ...) cat-vals)
(define rys (filter regular-real? ys))
(define rys (filter regular-real? (append* (for/list ([y (in-list ys)])
(match y
[(ivl y1 y2) (list y1 y2)]
[_ (list y)])))))
(cond
[(empty? rys) (renderer2d #f #f #f #f)]
[else
(define n (length cats))
(let* ([x-min (if x-min x-min 0)]
[x-max (if x-max x-max (+ x-min n))]
[x-max (if x-max x-max (+ x-min (* n skip)))]
[y-min (if y-min y-min (apply min* rys))]
[y-max (if y-max y-max (apply max* rys))])
(define xs (linear-seq x-min x-max (add1 n)))
(define x-ivls (for/list ([x1 (in-list xs)] [x2 (in-list (rest xs))])
(define 1/2-gap-size (* 1/2 gap (- x2 x1)))
(define 1/2-gap-size (+ (* 1/2 (- skip 1)) (* 1/2 gap (- x2 x1))))
(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)) #f
(discrete-histogram-ticks-fun cats tick-xs far-ticks?)
(rectangles-render-proc (map (λ (x-ivl y) (vector x-ivl (ivl 0 y))) x-ivls ys)
(rectangles-render-proc (map (λ (x-ivl y) (vector x-ivl (if (ivl? y) y (ivl 0 y)))) x-ivls ys)
color style line-color line-width line-style alpha label)))]))
(defproc (stacked-histogram
[cat-vals (listof (vector/c any/c (listof real?)))]
[#:x-min x-min (or/c regular-real? #f) 0]
[#:x-max x-max (or/c regular-real? #f) #f]
[#:y-min y-min (or/c regular-real? #f) 0]
[#:y-max y-max (or/c regular-real? #f) #f]
[#:gap gap (real-in 0 1) (discrete-histogram-gap)]
[#:skip skip (>=/c 0) (discrete-histogram-skip)]
[#:colors colors (plot-colors/c nat/c) (stacked-histogram-colors)]
[#:styles styles (plot-brush-styles/c nat/c) (stacked-histogram-styles)]
[#:line-colors line-colors (plot-colors/c nat/c) (stacked-histogram-line-colors)]
[#:line-widths line-widths (pen-widths/c nat/c) (stacked-histogram-line-widths)]
[#:line-styles line-styles (plot-pen-styles/c nat/c) (stacked-histogram-line-styles)]
[#:alphas alphas (alphas/c nat/c) (stacked-histogram-alphas)]
[#:labels labels (labels/c nat/c) '(#f)]
[#:far-ticks? far-ticks? boolean? #f]
) (listof renderer2d?)
(match-define (list (vector cats ys) ...) cat-vals)
(define yss
(for/list ([y (in-list ys)])
(reverse (foldl (λ (x xs) (cons (+ x (first xs)) xs)) '(0) y))))
(define y-ivlss (for/list ([ys (in-list yss)])
(for/list ([y1 (in-list ys)] [y2 (in-list (rest ys))])
(ivl y1 y2))))
(define max-num (apply max (map length yss)))
(for/list ([y-ivls (in-list (transpose y-ivlss))]
[color (in-cycle (maybe-apply colors max-num))]
[style (in-cycle (maybe-apply styles max-num))]
[line-color (in-cycle (maybe-apply line-colors max-num))]
[line-width (in-cycle (maybe-apply line-widths max-num))]
[line-style (in-cycle (maybe-apply line-styles max-num))]
[alpha (in-cycle (maybe-apply alphas max-num))]
[label (in-cycle (maybe-apply labels max-num))])
(discrete-histogram (for/list ([cat (in-list cats)] [y-ivl (in-list y-ivls)])
(vector cat y-ivl))
#:x-min x-min #:x-max x-max #:y-min y-min #:gap gap #:skip skip
#:color color #:style style #:line-color line-color #:line-width line-width
#:line-style line-style #:alpha alpha #:label label #:far-ticks? far-ticks?)))

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

@ -2,17 +2,15 @@
(require racket/class racket/match racket/list racket/flonum racket/contract
plot/utils
"../common/contract-doc.rkt")
"../common/contract-doc.rkt"
"../common/utils.rkt")
(provide (all-defined-out)
(rename-out [contour3d isoline3d]
[contours3d isolines3d]
[contour-intervals3d isoline-intervals3d]))
(provide (all-defined-out))
;; ===================================================================================================
;; One contour line in 3D (using marching squares)
(define ((contour3d-render-proc f z samples color width style alpha label) area)
(define ((isoline3d-render-proc f z samples color width style alpha label) area)
(match-define (vector (ivl x-min x-max) (ivl y-min y-max) (ivl z-min z-max))
(send area get-bounds-rect))
(match-define (2d-sample xs ys zss fz-min fz-max)
@ -41,7 +39,7 @@
(cond [label (line-legend-entry label color width style)]
[else empty]))
(defproc (contour3d
(defproc (isoline3d
[f (real? real? . -> . real?)] [z real?]
[x-min (or/c regular-real? #f) #f]
[x-max (or/c regular-real? #f) #f]
@ -61,7 +59,7 @@
[z-max (if z-max z-max z)])
(renderer3d (vector (ivl x-min x-max) (ivl y-min y-max) (ivl z-min z-max))
#f default-ticks-fun
(contour3d-render-proc g z samples color width style alpha label))))
(isoline3d-render-proc g z samples color width style alpha label))))
;; ===================================================================================================
;; Contour lines in 3D (using marching squares)
@ -74,37 +72,36 @@
(match-define (list (tick zs _ labels) ...) (contour-ticks z-min z-max levels #f))
(define cs (maybe-apply/list colors zs))
(define ws (maybe-apply/list widths zs))
(define ss (maybe-apply/list styles zs))
(define as (maybe-apply/list alphas zs))
(for ([z (in-list zs)]
[color (in-cycle cs)]
[width (in-cycle ws)]
[style (in-cycle ss)]
[alpha (in-cycle as)])
(send area put-alpha alpha)
(send area put-pen color width style)
(for ([ya (in-list ys)]
[yb (in-list (rest ys))]
[zs0 (in-vector zss)]
[zs1 (in-vector zss 1)]
#:when #t
[xa (in-list xs)]
[xb (in-list (rest xs))]
[z1 (in-vector zs0)]
[z2 (in-vector zs0 1)]
[z3 (in-vector zs1 1)]
[z4 (in-vector zs1)])
(for ([line (in-list (heights->lines xa xb ya yb z z1 z2 z3 z4))])
(match-define (list v1 v2) line)
(define center (vector (* 1/2 (+ xa xb)) (* 1/2 (+ ya yb))
(* 1/2 (+ (min z1 z2 z3 z4) (max z1 z2 z3 z4)))))
(send area put-line v1 v2 center))))
(cond [label (line-legend-entries label zs labels colors widths styles)]
[else empty]))
(let ([colors (maybe-apply colors zs)]
[widths (maybe-apply widths zs)]
[styles (maybe-apply styles zs)]
[alphas (maybe-apply alphas zs)])
(for ([z (in-list zs)]
[color (in-cycle colors)]
[width (in-cycle widths)]
[style (in-cycle styles)]
[alpha (in-cycle alphas)])
(send area put-alpha alpha)
(send area put-pen color width style)
(for ([ya (in-list ys)]
[yb (in-list (rest ys))]
[zs0 (in-vector zss)]
[zs1 (in-vector zss 1)]
#:when #t
[xa (in-list xs)]
[xb (in-list (rest xs))]
[z1 (in-vector zs0)]
[z2 (in-vector zs0 1)]
[z3 (in-vector zs1 1)]
[z4 (in-vector zs1)])
(for ([line (in-list (heights->lines xa xb ya yb z z1 z2 z3 z4))])
(match-define (list v1 v2) line)
(define center (vector (* 1/2 (+ xa xb)) (* 1/2 (+ ya yb))
(* 1/2 (+ (min z1 z2 z3 z4) (max z1 z2 z3 z4)))))
(send area put-line v1 v2 center))))
(cond [label (line-legend-entries label zs labels colors widths styles)]
[else empty])))
(defproc (contours3d
[f (real? real? . -> . real?)]
@ -114,12 +111,12 @@
[y-max (or/c regular-real? #f) #f]
[#:z-min z-min (or/c regular-real? #f) #f]
[#:z-max z-max (or/c regular-real? #f) #f]
[#:levels levels (or/c 'auto exact-positive-integer? (listof real?)) (contour-levels)]
[#:samples samples (and/c exact-integer? (>=/c 2)) (plot3d-samples)]
[#:colors colors plot-colors/c (contour-colors)]
[#:widths widths pen-widths/c (contour-widths)]
[#:styles styles plot-pen-styles/c (contour-styles)]
[#:alphas alphas alphas/c (contour-alphas)]
[#:levels levels (or/c 'auto pos/c (listof real?)) (contour-levels)]
[#:colors colors (plot-colors/c (listof real?)) (contour-colors)]
[#:widths widths (pen-widths/c (listof real?)) (contour-widths)]
[#:styles styles (plot-pen-styles/c (listof real?)) (contour-styles)]
[#:alphas alphas (alphas/c (listof real?)) (contour-alphas)]
[#:label label (or/c string? #f) #f]
) renderer3d?
(define g (2d-function->sampler f))
@ -132,7 +129,7 @@
;; Contour intervals in 3D (using marching squares)
(define ((contour-intervals3d-render-proc
f levels samples colors line-colors line-widths line-styles
f levels samples colors styles line-colors line-widths line-styles
contour-colors contour-widths contour-styles alphas label)
area)
(match-define (vector (ivl x-min x-max) (ivl y-min y-max) (ivl z-min z-max))
@ -142,46 +139,65 @@
(match-define (list (tick zs _ labels) ...) (contour-ticks z-min z-max levels #t))
(define cs (maybe-apply/list colors zs))
(define lcs (maybe-apply/list line-colors zs))
(define lws (maybe-apply/list line-widths zs))
(define lss (maybe-apply/list line-styles zs))
(define as (maybe-apply/list alphas zs))
(define-values (z-ivls ivl-labels)
(for/lists (z-ivls ivl-labels) ([za (in-list zs)]
[zb (in-list (rest zs))]
[la (in-list labels)]
[lb (in-list (rest labels))])
(values (ivl za zb) (format "[~a,~a]" la lb))))
(for ([za (in-list zs)]
[zb (in-list (rest zs))]
[color (in-cycle cs)]
[line-color (in-cycle lcs)]
[line-width (in-cycle lws)]
[line-style (in-cycle lss)]
[alpha (in-cycle as)])
(send area put-alpha alpha)
(send area put-pen line-color line-width line-style)
(send area put-brush color 'solid)
(for ([ya (in-list ys)]
[yb (in-list (rest ys))]
[zs0 (in-vector zss)]
[zs1 (in-vector zss 1)]
#:when #t
[xa (in-list xs)]
[xb (in-list (rest xs))]
[z1 (in-vector zs0)]
[z2 (in-vector zs0 1)]
[z3 (in-vector zs1 1)]
[z4 (in-vector zs1)])
(for ([poly (in-list (heights->polys xa xb ya yb za zb z1 z2 z3 z4))])
(define center (vector (* 1/2 (+ xa xb))
(* 1/2 (+ ya yb))
(* 1/2 (+ (min z1 z2 z3 z4) (max z1 z2 z3 z4)))))
(send area put-polygon poly center))))
((contours3d-render-proc f levels samples contour-colors contour-widths contour-styles alphas #f)
area)
(cond [label (contour-intervals-legend-entries
label zs labels colors '(solid) line-colors line-widths line-styles
contour-colors contour-widths contour-styles)]
[else empty]))
(let ([colors (maybe-apply colors z-ivls)]
[styles (maybe-apply styles z-ivls)]
[alphas (maybe-apply alphas z-ivls)]
[line-colors (maybe-apply line-colors z-ivls)]
[line-widths (maybe-apply line-widths z-ivls)]
[line-styles (maybe-apply line-styles z-ivls)])
(for ([za (in-list zs)]
[zb (in-list (rest zs))]
[color (in-cycle colors)]
[style (in-cycle styles)]
[alpha (in-cycle alphas)]
[line-color (in-cycle line-colors)]
[line-width (in-cycle line-widths)]
[line-style (in-cycle line-styles)])
(send area put-alpha alpha)
(send area put-pen line-color line-width line-style)
(send area put-brush color style)
(for ([ya (in-list ys)]
[yb (in-list (rest ys))]
[zs0 (in-vector zss)]
[zs1 (in-vector zss 1)]
#:when #t
[xa (in-list xs)]
[xb (in-list (rest xs))]
[z1 (in-vector zs0)]
[z2 (in-vector zs0 1)]
[z3 (in-vector zs1 1)]
[z4 (in-vector zs1)])
(for ([poly (in-list (heights->polys xa xb ya yb za zb z1 z2 z3 z4))])
(define center (vector (* 1/2 (+ xa xb))
(* 1/2 (+ ya yb))
(* 1/2 (+ (min z1 z2 z3 z4) (max z1 z2 z3 z4)))))
(send area put-polygon poly center))))
((contours3d-render-proc f levels samples contour-colors contour-widths contour-styles alphas #f)
area)
(define n (- (length zs) 2))
(define contour-colors*
(append (list 0) (sequence-take (in-cycle (maybe-apply contour-colors zs)) 0 n) (list 0)))
(define contour-widths*
(append (list 0) (sequence-take (in-cycle (maybe-apply contour-widths zs)) 0 n) (list 0)))
(define contour-styles*
(append '(transparent) (sequence-take (in-cycle (maybe-apply contour-styles zs)) 0 n)
'(transparent)))
(cond [label (interval-legend-entries
label z-ivls ivl-labels
colors styles line-colors line-widths line-styles
contour-colors* contour-widths* contour-styles*
(rest contour-colors*) (rest contour-widths*) (rest contour-styles*))]
[else empty])))
(defproc (contour-intervals3d
[f (real? real? . -> . real?)]
@ -191,23 +207,24 @@
[y-max (or/c regular-real? #f) #f]
[#:z-min z-min (or/c regular-real? #f) #f]
[#:z-max z-max (or/c regular-real? #f) #f]
[#:levels levels (or/c 'auto exact-positive-integer? (listof real?)) (contour-levels)]
[#:samples samples (and/c exact-integer? (>=/c 2)) (plot3d-samples)]
[#:colors colors plot-colors/c (contour-interval-colors)]
[#:line-colors line-colors plot-colors/c (contour-interval-line-colors)]
[#:line-widths line-widths pen-widths/c (contour-interval-line-widths)]
[#:line-styles line-styles plot-pen-styles/c (contour-interval-line-styles)]
[#:contour-colors contour-colors plot-colors/c (contour-colors)]
[#:contour-widths contour-widths pen-widths/c (contour-widths)]
[#:contour-styles contour-styles plot-pen-styles/c (contour-styles)]
[#:alphas alphas alphas/c (contour-interval-alphas)]
[#:levels levels (or/c 'auto pos/c (listof real?)) (contour-levels)]
[#:colors colors (plot-colors/c (listof ivl?)) (contour-interval-colors)]
[#:styles styles (plot-brush-styles/c (listof ivl?)) (contour-interval-styles)]
[#:line-colors line-colors (plot-colors/c (listof ivl?)) (contour-interval-line-colors)]
[#:line-widths line-widths (pen-widths/c (listof ivl?)) (contour-interval-line-widths)]
[#:line-styles line-styles (plot-pen-styles/c (listof ivl?)) (contour-interval-line-styles)]
[#:contour-colors contour-colors (plot-colors/c (listof real?)) (contour-colors)]
[#:contour-widths contour-widths (pen-widths/c (listof real?)) (contour-widths)]
[#:contour-styles contour-styles (plot-pen-styles/c (listof real?)) (contour-styles)]
[#:alphas alphas (alphas/c (listof ivl?)) (contour-interval-alphas)]
[#:label label (or/c string? #f) #f]
) renderer3d?
(define g (2d-function->sampler f))
(renderer3d (vector (ivl x-min x-max) (ivl y-min y-max) (ivl z-min z-max))
(surface3d-bounds-fun g samples)
default-ticks-fun
(contour-intervals3d-render-proc g levels samples colors
(contour-intervals3d-render-proc g levels samples colors styles
line-colors line-widths line-styles
contour-colors contour-widths contour-styles
alphas label)))

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

@ -9,7 +9,8 @@
;; ===================================================================================================
;; Surfaces of constant value (isosurfaces)
(define ((isosurface3d-render-proc f d samples color line-color line-width line-style alpha label)
(define ((isosurface3d-render-proc
f d samples color style line-color line-width line-style alpha label)
area)
(match-define (vector (ivl x-min x-max) (ivl y-min y-max) (ivl z-min z-max))
(send area get-bounds-rect))
@ -19,7 +20,7 @@
z-min z-max (animated-samples samples)))
(send area put-alpha alpha)
(send area put-brush color 'solid)
(send area put-brush color style)
(send area put-pen line-color line-width line-style)
(for ([za (in-list zs)]
[zb (in-list (rest zs))]
@ -50,7 +51,7 @@
(vector (* 1/2 (+ xa xb)) (* 1/2 (+ ya yb)) (* 1/2 (+ za zb))))))
(cond [label (rectangle-legend-entry
label color 'solid line-color line-width line-style)]
label color style line-color line-width line-style)]
[else empty]))
(defproc (isosurface3d [f (real? real? real? . -> . real?)] [d real?]
@ -62,6 +63,7 @@
[z-max (or/c regular-real? #f) #f]
[#:samples samples (and/c exact-integer? (>=/c 2)) (plot3d-samples)]
[#:color color plot-color/c (surface-color)]
[#:style style plot-brush-style/c (surface-style)]
[#:line-color line-color plot-color/c (surface-line-color)]
[#:line-width line-width (>=/c 0) (surface-line-width)]
[#:line-style line-style plot-pen-style/c (surface-line-style)]
@ -70,14 +72,14 @@
) renderer3d?
(define g (3d-function->sampler f))
(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)))
(isosurface3d-render-proc
g d samples color style line-color line-width line-style alpha label)))
;; ===================================================================================================
;; Nested isosurfaces
(define ((isosurfaces3d-render-proc
f rd-min rd-max levels samples colors line-colors line-widths line-styles alphas label)
(define ((isosurfaces3d-render-proc f rd-min rd-max levels samples colors styles
line-colors line-widths line-styles alphas label)
area)
(match-define (vector (ivl x-min x-max) (ivl y-min y-max) (ivl z-min z-max))
(send area get-bounds-rect))
@ -95,75 +97,80 @@
(match-define (list (tick ds _ labels) ...) (isosurface-ticks d-min d-max levels))
#;(define ds (linear-seq d-min d-max levels #:start? (and rd-min #t) #:end? (and rd-max #t)))
(for ([d (in-list ds)]
[color (in-cycle (maybe-apply/list colors ds))]
[line-color (in-cycle (maybe-apply/list line-colors ds))]
[line-width (in-cycle (maybe-apply/list line-widths ds))]
[line-style (in-cycle (maybe-apply/list line-styles ds))]
[alpha (in-cycle (maybe-apply/list alphas ds))])
(send area put-alpha alpha)
(send area put-brush color 'solid)
(send area put-pen line-color line-width line-style)
(for ([za (in-list zs)]
[zb (in-list (rest zs))]
[dss0 (in-vector dsss)]
[dss1 (in-vector dsss 1)]
#:when #t
[ya (in-list ys)]
[yb (in-list (rest ys))]
[ds00 (in-vector dss0)]
[ds01 (in-vector dss0 1)]
[ds10 (in-vector dss1)]
[ds11 (in-vector dss1 1)]
#:when #t
[xa (in-list xs)]
[xb (in-list (rest xs))]
[d1 (in-vector ds00)]
[d2 (in-vector ds00 1)]
[d3 (in-vector ds01 1)]
[d4 (in-vector ds01)]
[d5 (in-vector ds10)]
[d6 (in-vector ds10 1)]
[d7 (in-vector ds11 1)]
[d8 (in-vector ds11)])
(define polys (heights->cube-polys xa xb ya yb za zb d d1 d2 d3 d4 d5 d6 d7 d8))
(when (not (empty? polys))
(send area put-polygons polys
(vector (* 1/2 (+ xa xb)) (* 1/2 (+ ya yb)) (* 1/2 (+ za zb)))))))
(cond
[label (rectangle-legend-entries
label ds colors '(solid) line-colors line-widths line-styles)]
[else empty])]))
(let ([colors (maybe-apply colors ds)]
[styles (maybe-apply styles ds)]
[alphas (maybe-apply alphas ds)]
[line-colors (maybe-apply line-colors ds)]
[line-widths (maybe-apply line-widths ds)]
[line-styles (maybe-apply line-styles ds)])
(for ([d (in-list ds)]
[color (in-cycle colors)]
[style (in-cycle styles)]
[alpha (in-cycle alphas)]
[line-color (in-cycle line-colors)]
[line-width (in-cycle line-widths)]
[line-style (in-cycle line-styles)])
(send area put-alpha alpha)
(send area put-brush color style)
(send area put-pen line-color line-width line-style)
(for ([za (in-list zs)]
[zb (in-list (rest zs))]
[dss0 (in-vector dsss)]
[dss1 (in-vector dsss 1)]
#:when #t
[ya (in-list ys)]
[yb (in-list (rest ys))]
[ds00 (in-vector dss0)]
[ds01 (in-vector dss0 1)]
[ds10 (in-vector dss1)]
[ds11 (in-vector dss1 1)]
#:when #t
[xa (in-list xs)]
[xb (in-list (rest xs))]
[d1 (in-vector ds00)]
[d2 (in-vector ds00 1)]
[d3 (in-vector ds01 1)]
[d4 (in-vector ds01)]
[d5 (in-vector ds10)]
[d6 (in-vector ds10 1)]
[d7 (in-vector ds11 1)]
[d8 (in-vector ds11)])
(define polys (heights->cube-polys xa xb ya yb za zb d d1 d2 d3 d4 d5 d6 d7 d8))
(when (not (empty? polys))
(send area put-polygons polys
(vector (* 1/2 (+ xa xb)) (* 1/2 (+ ya yb)) (* 1/2 (+ za zb)))))))
(cond
[label (rectangle-legend-entries
label ds colors styles line-colors line-widths line-styles)]
[else empty]))]))
(defproc (isosurfaces3d [f (real? real? real? . -> . real?)]
[x-min (or/c regular-real? #f) #f]
[x-max (or/c regular-real? #f) #f]
[y-min (or/c regular-real? #f) #f]
[y-max (or/c regular-real? #f) #f]
[z-min (or/c regular-real? #f) #f]
[z-max (or/c regular-real? #f) #f]
[#:d-min d-min (or/c regular-real? #f) #f]
[#:d-max d-max (or/c regular-real? #f) #f]
[#:levels levels (or/c 'auto exact-positive-integer? (listof real?))
(isosurface-levels)]
[#:samples samples (and/c exact-integer? (>=/c 2)) (plot3d-samples)]
[#:colors colors plot-colors/c (isosurface-colors)]
[#:line-colors line-colors plot-colors/c (isosurface-line-colors)]
[#:line-widths line-widths pen-widths/c (isosurface-line-widths)]
[#:line-styles line-styles plot-pen-styles/c (isosurface-line-styles)]
[#:alphas alphas alphas/c (isosurface-alphas)]
[#:label label (or/c string? #f) #f]
) renderer3d?
(defproc (isosurfaces3d
[f (real? real? real? . -> . real?)]
[x-min (or/c regular-real? #f) #f] [x-max (or/c regular-real? #f) #f]
[y-min (or/c regular-real? #f) #f] [y-max (or/c regular-real? #f) #f]
[z-min (or/c regular-real? #f) #f] [z-max (or/c regular-real? #f) #f]
[#:d-min d-min (or/c regular-real? #f) #f] [#:d-max d-max (or/c regular-real? #f) #f]
[#:samples samples (and/c exact-integer? (>=/c 2)) (plot3d-samples)]
[#:levels levels (or/c 'auto exact-positive-integer? (listof real?)) (isosurface-levels)]
[#:colors colors (plot-colors/c (listof real?)) (isosurface-colors)]
[#:styles styles (plot-brush-styles/c (listof real?)) (isosurface-styles)]
[#:line-colors line-colors (plot-colors/c (listof real?)) (isosurface-line-colors)]
[#:line-widths line-widths (pen-widths/c (listof real?)) (isosurface-line-widths)]
[#:line-styles line-styles (plot-pen-styles/c (listof real?)) (isosurface-line-styles)]
[#:alphas alphas (alphas/c (listof real?)) (isosurface-alphas)]
[#: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)) #f default-ticks-fun
(isosurfaces3d-render-proc g d-min d-max levels samples colors
(isosurfaces3d-render-proc g d-min d-max levels samples colors styles
line-colors line-widths line-styles alphas
label)))
;; ===================================================================================================
(define ((polar3d-render-proc f g samples color line-color line-width line-style alpha label) area)
(define ((polar3d-render-proc f g samples color style line-color line-width line-style alpha label)
area)
(match-define (vector (ivl x-min x-max) (ivl y-min y-max) (ivl z-min z-max))
(send area get-bounds-rect))
(match-define (3d-sample xs ys zs dsss d-min d-max)
@ -172,7 +179,7 @@
z-min z-max (animated-samples samples)))
(send area put-alpha alpha)
(send area put-brush color 'solid)
(send area put-brush color style)
(send area put-pen line-color line-width line-style)
(for ([za (in-list zs)]
[zb (in-list (rest zs))]
@ -218,7 +225,7 @@
(draw-cube xa xb ya yb za zb d1 d2 d3 d4 d5 d6 d7 d8)]))
(cond [label (rectangle-legend-entry
label color 'solid line-color line-width line-style)]
label color style line-color line-width line-style)]
[else empty]))
(define 2pi (* 2 pi))
@ -233,21 +240,20 @@
(flatan (fl/ z (fldistance x y))))]))
(fl- (exact->inexact (f θ ρ)) (fldistance x y z))))
(defproc (polar3d [f (real? real? . -> . real?)]
[#:x-min x-min (or/c regular-real? #f) #f]
[#:x-max x-max (or/c regular-real? #f) #f]
[#:y-min y-min (or/c regular-real? #f) #f]
[#:y-max y-max (or/c regular-real? #f) #f]
[#:z-min z-min (or/c regular-real? #f) #f]
[#:z-max z-max (or/c regular-real? #f) #f]
[#:samples samples (and/c exact-integer? (>=/c 2)) (plot3d-samples)]
[#:color color plot-color/c (surface-color)]
[#:line-color line-color plot-color/c (surface-line-color)]
[#:line-width line-width (>=/c 0) (surface-line-width)]
[#:line-style line-style plot-pen-style/c (surface-line-style)]
[#:alpha alpha (real-in 0 1) (surface-alpha)]
[#:label label (or/c string? #f) #f]
) renderer3d?
(defproc (polar3d
[f (real? real? . -> . real?)]
[#:x-min x-min (or/c regular-real? #f) #f] [#:x-max x-max (or/c regular-real? #f) #f]
[#:y-min y-min (or/c regular-real? #f) #f] [#:y-max y-max (or/c regular-real? #f) #f]
[#:z-min z-min (or/c regular-real? #f) #f] [#:z-max z-max (or/c regular-real? #f) #f]
[#:samples samples (and/c exact-integer? (>=/c 2)) (plot3d-samples)]
[#:color color plot-color/c (surface-color)]
[#:style style plot-brush-style/c (surface-style)]
[#:line-color line-color plot-color/c (surface-line-color)]
[#:line-width line-width (>=/c 0) (surface-line-width)]
[#:line-style line-style plot-pen-style/c (surface-line-style)]
[#:alpha alpha (real-in 0 1) (surface-alpha)]
[#:label label (or/c string? #f) #f]
) renderer3d?
(define vs (for*/list ([θ (in-list (linear-seq 0.0 2pi (* 4 samples)))]
[ρ (in-list (linear-seq (* -1/2 pi) (* 1/2 pi) (* 2 samples)))])
(3d-polar->3d-cartesian θ ρ (f θ ρ))))
@ -265,5 +271,5 @@
(define g (3d-function->sampler new-f))
(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
(polar3d-render-proc new-f g samples color style
line-color line-width line-style alpha label)))]))

65
collects/plot/plot3d/plot-area.rkt
View File

@ -214,24 +214,24 @@
(vector x y (pre-tick-value t2))))
(define x-ticks
(collapse-nearby-ticks (filter (λ (t) (<= x-min (pre-tick-value t) x-max)) rx-ticks)
(x-ticks-near? x-axis-y)))
(collapse-ticks (filter (λ (t) (<= x-min (pre-tick-value t) x-max)) rx-ticks)
(x-ticks-near? x-axis-y)))
(define y-ticks
(collapse-nearby-ticks (filter (λ (t) (<= y-min (pre-tick-value t) y-max)) ry-ticks)
(y-ticks-near? y-axis-x)))
(collapse-ticks (filter (λ (t) (<= y-min (pre-tick-value t) y-max)) ry-ticks)
(y-ticks-near? y-axis-x)))
(define z-ticks
(collapse-nearby-ticks (filter (λ (t) (<= z-min (pre-tick-value t) z-max)) rz-ticks)
(z-ticks-near? z-axis-x z-axis-y)))
(collapse-ticks (filter (λ (t) (<= z-min (pre-tick-value t) z-max)) rz-ticks)
(z-ticks-near? z-axis-x z-axis-y)))
(define x-far-ticks
(collapse-nearby-ticks (filter (λ (t) (<= x-min (pre-tick-value t) x-max)) rx-far-ticks)
(x-ticks-near? x-far-axis-y)))
(collapse-ticks (filter (λ (t) (<= x-min (pre-tick-value t) x-max)) rx-far-ticks)
(x-ticks-near? x-far-axis-y)))
(define y-far-ticks
(collapse-nearby-ticks (filter (λ (t) (<= y-min (pre-tick-value t) y-max)) ry-far-ticks)
(y-ticks-near? y-far-axis-x)))
(collapse-ticks (filter (λ (t) (<= y-min (pre-tick-value t) y-max)) ry-far-ticks)
(y-ticks-near? y-far-axis-x)))
(define z-far-ticks
(collapse-nearby-ticks (filter (λ (t) (<= z-min (pre-tick-value t) z-max)) rz-far-ticks)
(z-ticks-near? z-far-axis-x z-far-axis-y)))
(collapse-ticks (filter (λ (t) (<= z-min (pre-tick-value t) z-max)) rz-far-ticks)
(z-ticks-near? z-far-axis-x z-far-axis-y)))
;; ===============================================================================================
;; Tick and label parameters, and fixpoint margin computation
@ -321,7 +321,7 @@
(define dist (+ (pen-gap) tick-radius))
(for/list ([t (in-list ticks)] #:when (pre-tick-major? t))
(match-define (tick x _ label) t)
(list #t label (v+ (tick-value->dc x) (v* offset-dir dist)) anchor)))
(list label (v+ (tick-value->dc x) (v* offset-dir dist)) anchor)))
(define (get-x-tick-label-params)
(if (plot-x-axis?)
@ -423,35 +423,35 @@
(define (get-x-label-params)
(define v0 (plot->dc/no-axis-trans (vector x-mid x-axis-y z-min)))
(define dist (+ max-x-tick-offset (max-x-tick-label-diag) half-char-height))
(list #t (plot-x-label) (v+ v0 (v* (y-axis-dir) (if x-axis-y-min? (- dist) dist)))
(list (plot-x-label) (v+ v0 (v* (y-axis-dir) (if x-axis-y-min? (- dist) dist)))
'top (- (if x-axis-y-min? 0 pi) (x-axis-angle))))
(define (get-y-label-params)
(define v0 (plot->dc/no-axis-trans (vector y-axis-x y-mid z-min)))
(define dist (+ max-y-tick-offset (max-y-tick-label-diag) half-char-height))
(list #t (plot-y-label) (v+ v0 (v* (x-axis-dir) (if y-axis-x-min? (- dist) dist)))
(list (plot-y-label) (v+ v0 (v* (x-axis-dir) (if y-axis-x-min? (- dist) dist)))
'top (- (if y-axis-x-min? pi 0) (y-axis-angle))))
(define (get-z-label-params)
(list #t (plot-z-label) (v+ (plot->dc* (vector z-axis-x z-axis-y z-max))
(vector 0 (- half-char-height)))
(list (plot-z-label) (v+ (plot->dc* (vector z-axis-x z-axis-y z-max))
(vector 0 (- half-char-height)))
'bottom-left 0))
(define (get-x-far-label-params)
(define v0 (plot->dc/no-axis-trans (vector x-mid x-far-axis-y z-min)))
(define dist (+ max-x-far-tick-offset (max-x-far-tick-label-diag) half-char-height))
(list #f (plot-x-far-label) (v+ v0 (v* (y-axis-dir) (if x-axis-y-min? dist (- dist))))
(list (plot-x-far-label) (v+ v0 (v* (y-axis-dir) (if x-axis-y-min? dist (- dist))))
'bottom (- (if x-axis-y-min? 0 pi) (x-axis-angle))))
(define (get-y-far-label-params)
(define v0 (plot->dc/no-axis-trans (vector y-far-axis-x y-mid z-min)))
(define dist (+ max-y-far-tick-offset (max-y-far-tick-label-diag) half-char-height))
(list #f (plot-y-far-label) (v+ v0 (v* (x-axis-dir) (if y-axis-x-min? dist (- dist))))
(list (plot-y-far-label) (v+ v0 (v* (x-axis-dir) (if y-axis-x-min? dist (- dist))))
'bottom (- (if y-axis-x-min? pi 0) (y-axis-angle))))
(define (get-z-far-label-params)
(list #t (plot-z-far-label) (v+ (plot->dc* (vector z-far-axis-x z-far-axis-y z-max))
(vector 0 (- half-char-height)))
(list (plot-z-far-label) (v+ (plot->dc* (vector z-far-axis-x z-far-axis-y z-max))
(vector 0 (- half-char-height)))
'bottom-right 0))
;; -----------------------------------------------------------------------------------------------
@ -508,7 +508,7 @@
;(printf "label params = ~v~n" (get-all-label-params))
;(printf "tick params = ~v~n" (get-all-tick-params))
(set! view->dc (make-view->dc left right top bottom))
(append (append* (map (λ (params) (send/apply pd get-text-corners (rest params)))
(append (append* (map (λ (params) (send/apply pd get-text-corners params))
(get-all-label-params)))
(append* (map (λ (params) (send/apply pd get-tick-endpoints (rest params)))
(get-all-tick-params)))))
@ -569,7 +569,7 @@
(define (draw-labels label-params)
(for ([params (in-list label-params)])
(send/apply pd draw-text (rest params) #:outline? (first params))))
(send/apply pd draw-text params #:outline? #t)))
;; ===============================================================================================
;; Delayed drawing
@ -578,7 +578,7 @@
(define (add-shape! shape) (set! render-list (cons shape render-list)))
(define (draw-shapes lst)
(for ([s (in-list (depth-sort lst))])
(for ([s (in-list (depth-sort (reverse lst)))])
(send pd set-alpha (shape-alpha s))
(match s
; shapes
@ -609,6 +609,10 @@
[(tick-glyph alpha center radius angle pen-color pen-width pen-style)
(send pd set-pen pen-color pen-width pen-style)
(send pd draw-tick (view->dc (rotate/rho center)) radius angle)]
; arrow glyph
[(arrow-glyph alpha center v1 v2 pen-color pen-width pen-style)
(send pd set-pen pen-color pen-width pen-style)
(send pd draw-arrow (view->dc v1) (view->dc v2))]
[_ (error 'draw-shapes "shape not implemented: ~e" s)])))
;; Use a special view transform for the light so that the light angle is always the same
@ -886,6 +890,19 @@
(get-pen-color) (get-pen-width) (get-pen-style)
(get-brush-color) (get-brush-style))))))
(define/public (put-arrow v1 v2 [c (v* (v+ v1 v2) 1/2)])
(when (and (vregular? v1) (vregular? v2) (in-bounds? v1))
(cond [(in-bounds? v2) (add-shape!
(arrow-glyph (get-alpha) (plot->view/no-rho c)
(plot->view v1) (plot->view v2)
(->brush-color (plot-background))
(+ 2 (get-pen-width)) 'solid))
(add-shape!
(arrow-glyph (get-alpha) (plot->view/no-rho c)
(plot->view v1) (plot->view v2)
(get-pen-color) (get-pen-width) (get-pen-style)))]
[else (put-line v1 v2)])))
(define/public (put-tick v radius angle)
(when (and (vregular? v) (in-bounds? v))
(add-shape!

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

@ -44,3 +44,71 @@
(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)))])))
;; ===================================================================================================
(define ((vector-field3d-render-fun f samples scale color line-width line-style alpha label) area)
(match-define (vector (ivl x-min x-max) (ivl y-min y-max) (ivl z-min z-max))
(send area get-bounds-rect))
(define xs0 (linear-seq x-min x-max samples #:start? #t #:end? #t))
(define ys0 (linear-seq y-min y-max samples #:start? #t #:end? #t))
(define zs0 (linear-seq z-min z-max samples #:start? #t #:end? #t))
(define-values (vs dxs dys dzs norms mags)
(for*/lists (vs dxs dys dzs norms mags) ([x (in-list xs0)]
[y (in-list ys0)]
[z (in-list zs0)]
[dv (in-value (f x y z))] #:when (vregular? dv))
(match-define (vector dx dy dz) dv)
(values (vector x y z) dx dy dz (vnormalize dv) (vmag dv))))
(cond [(empty? vs) empty]
[else (define box-x-size (/ (- x-max x-min) samples))
(define box-y-size (/ (- y-max y-min) samples))
(define box-z-size (/ (- z-max z-min) samples))
(define new-mags
(match scale
[(? real?) (map (λ (mag) (* scale mag)) mags)]
['normalized (define box-size (min box-x-size box-y-size box-z-size))
(build-list (length dxs) (λ _ box-size))]
['auto (define dx-max (apply max (map abs dxs)))
(define dy-max (apply max (map abs dys)))
(define dz-max (apply max (map abs dzs)))
(define scale (min (/ box-x-size dx-max)
(/ box-y-size dy-max)
(/ box-z-size dz-max)))
(map (λ (mag) (* scale mag)) mags)]))
(send area put-alpha alpha)
(send area put-pen color line-width line-style)
(for ([v (in-list vs)]
[norm (in-list norms)]
[mag (in-list new-mags)])
(send area put-arrow v (v+ v (v* norm mag))))
(cond [label (vector-field-legend-entry label color line-width line-style)]
[else empty])]))
(defproc (vector-field3d
[f (or/c (real? real? real? . -> . (vector/c real? real? real?))
((vector/c real? real? real?) . -> . (vector/c real? real? real?)))]
[x-min (or/c regular-real? #f) #f]
[x-max (or/c regular-real? #f) #f]
[y-min (or/c regular-real? #f) #f]
[y-max (or/c regular-real? #f) #f]
[z-min (or/c regular-real? #f) #f]
[z-max (or/c regular-real? #f) #f]
[#:samples samples exact-positive-integer? ( vector-field3d-samples)]
[#:scale scale (or/c real? (one-of/c 'auto 'normalized)) (vector-field-scale)]
[#:color color plot-color/c (vector-field-color)]
[#:line-width line-width (>=/c 0) (vector-field-line-width)]
[#:line-style line-style plot-pen-style/c (vector-field-line-style)]
[#:alpha alpha (real-in 0 1) (vector-field-alpha)]
[#:label label (or/c string? #f) #f]
) renderer3d?
(let ([f (cond [(procedure-arity-includes? f 3 #t) f]
[else (λ (x y z) (f (vector x y z)))])])
(renderer3d (vector (ivl x-min x-max) (ivl y-min y-max) (ivl z-min z-max)) #f default-ticks-fun
(vector-field3d-render-fun f samples scale color line-width line-style alpha label))))

1
collects/plot/plot3d/shape.rkt
View File

@ -12,6 +12,7 @@
(struct text shape (anchor angle str font-size font-family color) #:transparent)
(struct glyph shape (symbol size pen-color pen-width pen-style brush-color brush-style) #:transparent)
(struct tick-glyph shape (radius angle pen-color pen-width pen-style) #:transparent)
(struct arrow-glyph shape (start end pen-color pen-width pen-style) #:transparent)
(struct shapes shape (list) #:transparent)
(define (draw-before? s1 s2)

8
collects/plot/scribblings/renderer2d.scrbl
View File

@ -243,10 +243,6 @@ For example,
#:styles '(solid dot)))]
}
@defproc[(isolines ...) renderer2d?]{
A synonym of @(racket contours).
}
@doc-apply[contour-intervals]{
Returns a renderer that fills the area between contour lines, and additionally draws contour lines.
@ -258,10 +254,6 @@ For example, the canonical saddle, with its gradient field superimposed:
#:color "black" #:label "Gradient")))]
}
@defproc[(isoline-intervals ...) renderer2d?]{
A synonym of @(racket contour-intervals).
}
@section{2D Rectangle Renderers}
@defstruct[ivl ([min real?] [max real?])]{

14
collects/plot/scribblings/renderer3d.scrbl
View File

@ -98,14 +98,10 @@ Combining polar function renderers allows faking latitudes or longitudes in larg
@section{3D Contour (Isoline) Renderers}
@doc-apply[contour3d]{
@doc-apply[isoline3d]{
Returns a renderer that plots a single contour line on the surface of a function.
}
@defproc[(isoline3d ...) renderer3d?]{
A synonym of @(racket contour3d).
}
@doc-apply[contours3d]{
Returns a renderer that plots contour lines on the surface of a function.
@ -118,10 +114,6 @@ For example,
#:legend-anchor 'top-left)]
}
@defproc[(isolines3d ...) renderer3d?]{
A synonym of @(racket contours3d).
}
@doc-apply[contour-intervals3d]{
Returns a renderer that plots contour intervals and contour lines on the surface of a function.
The appearance keyword arguments are interpreted identically to the appearance keyword arguments to @(racket contour-intervals).
@ -133,10 +125,6 @@ For example,
#:legend-anchor 'top-left)]
}
@defproc[(isoline-intervals3d ...) renderer3d?]{
A synonym of @(racket contour-intervals3d).
}
@section{3D Isosurface Renderers}
@doc-apply[isosurface3d]{

31
collects/plot/tests/doc-tests.rkt Normal file
View File

@ -0,0 +1,31 @@
#lang racket
(require plot/doc
scribble/manual
scribble/render
scribble/text-render
scribble/decode)
(define (render-doc doc-part)
(define path (make-temporary-file "racket-doc-~a.txt" #f (current-directory)))
(dynamic-wind
(λ () (void))
(λ ()
(render (list (decode (list (declare-exporting) doc-part)))
(list path)
#:render-mixin render-mixin)
(file->lines path))
(λ () (delete-file path))))
(define (display-doc doc-part)
(for ([line (in-list (render-doc doc-part))])
(displayln line)))
(display-doc (plot/dc:doc))
(newline)
(display-doc (treeof:doc))
(newline)
(display-doc (plot-background:doc))
(newline)
(display-doc (known-point-symbols:doc))
(newline)

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

@ -35,7 +35,9 @@
(time
(define saddle (λ (x y z) (- (sqr x) (* 1/2 (+ (sqr y) (sqr z))))))
(plot3d (isosurface3d saddle -1/4 #:color 0 #:line-color 0 #:alpha 7/8
(plot3d (isosurface3d saddle -1/4 #:samples 21
#:color "black" #:style 3
#:alpha 1
#:label "d = -1/4")
#:x-min -2 #:x-max 2
#:y-min -2 #:y-max 2

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

@ -196,6 +196,29 @@
#:y-label "Widgetyness"
#:legend-anchor 'bottom-right))
(time
(plot (stacked-histogram '(#(a (1 1 1)) #(b (1.5 3)) #(c ()) #(d (1/2)))
#:labels '("Red" #f "Blue"))))
(time
(parameterize ([discrete-histogram-gap 0]
[discrete-histogram-skip 3]
[rectangle-line-width 2])
(plot (list (discrete-histogram '(#(a 1) #(b 2.5) #(c 2)) #:label "Blue")
(discrete-histogram '(#(a 2) #(b 4) #(c 1)) #:x-min 2/3 #:color 1 #:line-color 1
#:label "Red")
(discrete-histogram '(#(a 3) #(b 3) #(c 2.5)) #:x-min 4/3 #:color 2 #:line-color 2
#:label "Green")))))
(time
(parameterize ([discrete-histogram-gap 0]
[discrete-histogram-skip 2]
[stacked-histogram-line-widths '(3)])
(plot (list (stacked-histogram '(#(a (0.2 1)) #(b (2.5 1.2)) #(c (2 0))))
(stacked-histogram '(#(a (2 1)) #(b (1.1 0.9)) #(c (1 1.1))) #:x-min 7/8
#:colors '(3 4)
#:line-colors '(3 4))))))
(time
(plot (rectangles
(map vector
@ -285,7 +308,7 @@
(time (plot (list (tick-grid)
(contour-intervals f1 -5 2 -5 2
#:levels '(0.25 0.5 0.75 1.0 1.25 1.5 1.75)
#:colors default-contour-colors
#:colors (compose default-contour-colors (curry map ivl-center))
#:styles '(0 1 2 3 4 5 6)
#:contour-styles '(transparent)
#:label "z")

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

@ -20,6 +20,10 @@
(plot3d (points3d '(#(0.1 0.6 0.3)))
#:x-min 0 #:x-max 1 #:y-min 0 #:y-max 1 #:z-min 0 #:z-max 1))
(time
(plot3d (vector-field3d (λ (x y z) (vector x z y)) -2 2 -2 2 -2 2
#:line-width 3)))
(time
(define x-ivls (bounds->intervals (linear-seq 2 8 10)))
(define y-ivls (bounds->intervals (linear-seq -5 5 10)))