#lang racket/base (require racket/class racket/match racket/list racket/flonum racket/contract unstable/latent-contract/defthing plot/utils "../common/utils.rkt") (provide (all-defined-out)) ;; =================================================================================================== ;; One contour line in 3D (using marching squares) (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)) (define sample (f x-min x-max (animated-samples samples) y-min y-max (animated-samples samples))) (when (<= z-min z z-max) (send area put-alpha alpha) (send area put-pen color width style) (let* ([flonum-ok? (flonum-ok-for-3d? x-min x-max y-min y-max z-min z-max)] [sample (if flonum-ok? (2d-sample-exact->inexact sample) sample)] [z (if flonum-ok? (exact->inexact z) z)]) (for-2d-sample (xa xb ya yb z1 z2 z3 z4) sample (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-entry label color width style)] [else empty])) (defproc (isoline3d [f (real? real? . -> . real?)] [z real?] [x-min (or/c rational? #f) #f] [x-max (or/c rational? #f) #f] [y-min (or/c rational? #f) #f] [y-max (or/c rational? #f) #f] [#:z-min z-min (or/c rational? #f) #f] [#:z-max z-max (or/c rational? #f) #f] [#:samples samples (and/c exact-integer? (>=/c 2)) (plot3d-samples)] [#:color color plot-color/c (line-color)] [#:width width (>=/c 0) (line-width)] [#:style style plot-pen-style/c (line-style)] [#:alpha alpha (real-in 0 1) (line-alpha)] [#:label label (or/c string? #f) #f] ) renderer3d? (define g (2d-function->sampler f)) (let ([z-min (if z-min z-min z)] [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 (isoline3d-render-proc g z samples color width style alpha label)))) ;; =================================================================================================== ;; Contour lines in 3D (using marching squares) (define ((contours3d-render-proc f levels samples colors widths 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)) (define sample (f x-min x-max (animated-samples samples) y-min y-max (animated-samples samples))) ;; can't use the actual z ticks because some or all could be collapsed (match-define (list (tick zs _ labels) ...) (contour-ticks (plot-z-ticks) z-min z-max levels #f)) (let* ([colors (maybe-apply colors zs)] [widths (maybe-apply widths zs)] [styles (maybe-apply styles zs)] [alphas (maybe-apply alphas zs)] [flonum-ok? (flonum-ok-for-3d? x-min x-max y-min y-max z-min z-max)] [sample (if flonum-ok? (2d-sample-exact->inexact sample) sample)] [zs (if flonum-ok? (map exact->inexact zs) 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-2d-sample (xa xb ya yb z1 z2 z3 z4) sample (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?)] [x-min (or/c rational? #f) #f] [x-max (or/c rational? #f) #f] [y-min (or/c rational? #f) #f] [y-max (or/c rational? #f) #f] [#:z-min z-min (or/c rational? #f) #f] [#:z-max z-max (or/c rational? #f) #f] [#:samples samples (and/c exact-integer? (>=/c 2)) (plot3d-samples)] [#: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] ) 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 (contours3d-render-proc g levels samples colors widths styles alphas label))) ;; =================================================================================================== ;; Contour intervals in 3D (using marching squares) (define ((contour-intervals3d-render-proc 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)) (send area get-bounds-rect)) (define sample (f x-min x-max (animated-samples samples) y-min y-max (animated-samples samples))) ;; can't use the actual z ticks because some or all could be collapsed (match-define (list (tick zs _ labels) ...) (contour-ticks (plot-z-ticks) z-min z-max levels #t)) (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)))) (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)] [flonum-ok? (flonum-ok-for-3d? x-min x-max y-min y-max z-min z-max)] [sample (if flonum-ok? (2d-sample-exact->inexact sample) sample)] [zs (if flonum-ok? (map exact->inexact zs) zs)]) (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-2d-sample (xa xb ya yb z1 z2 z3 z4) sample (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?)] [x-min (or/c rational? #f) #f] [x-max (or/c rational? #f) #f] [y-min (or/c rational? #f) #f] [y-max (or/c rational? #f) #f] [#:z-min z-min (or/c rational? #f) #f] [#:z-max z-max (or/c rational? #f) #f] [#:samples samples (and/c exact-integer? (>=/c 2)) (plot3d-samples)] [#: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)] [#: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 styles line-colors line-widths line-styles contour-colors contour-widths contour-styles alphas label)))