Refactor *d-plot-area%; they are now containers for plot-device% instead of descendants of plot-area%
This commit is contained in:
Neil Toronto
parent
596e8b3775
commit
5a379b7236
|
|
@ -236,3 +236,43 @@
|
|||
[xs (listof any/c)]) (listof any/c)
|
||||
(cond [(procedure? list-or-proc) (list-or-proc xs)]
|
||||
[else list-or-proc]))
|
||||
|
||||
;; ===================================================================================================
|
||||
;; Subdividing nonlinearly transformed shapes
|
||||
|
||||
(define subdivide-fracs '(3/7 4/7 2/7 5/7 1/7 6/7))
|
||||
|
||||
(define (subdivide-line transform v1 v2)
|
||||
(let loop ([v1 v1] [v2 v2] [depth 10])
|
||||
(let/ec return
|
||||
(when (zero? depth) (return (list v1 v2)))
|
||||
|
||||
(define dc-v1 (transform v1))
|
||||
(define dc-v2 (transform v2))
|
||||
(define dc-dv (v- dc-v2 dc-v1))
|
||||
(when ((vmag dc-dv) . <= . 3)
|
||||
(return (list v1 v2)))
|
||||
|
||||
(define dv (v- v2 v1))
|
||||
(define-values (max-area vc)
|
||||
(for/fold ([max-area 0] [vc v1]) ([frac (in-list subdivide-fracs)])
|
||||
(define test-vc (v+ (v* dv frac) v1))
|
||||
(define test-area (abs (vcross2 dc-dv (v- (transform test-vc) dc-v1))))
|
||||
(cond [(test-area . > . max-area) (values test-area test-vc)]
|
||||
[else (values max-area vc)])))
|
||||
(when (max-area . <= . 3) (return (list v1 v2)))
|
||||
|
||||
;(plot3d-subdivisions (+ (plot3d-subdivisions) 1))
|
||||
(append (loop v1 vc (- depth 1))
|
||||
(rest (loop vc v2 (- depth 1)))))))
|
||||
|
||||
(define (subdivide-lines transform vs)
|
||||
(append
|
||||
(append*
|
||||
(for/list ([v1 (in-list vs)] [v2 (in-list (rest vs))])
|
||||
(define line-vs (subdivide-line transform v1 v2))
|
||||
(take line-vs (sub1 (length line-vs)))))
|
||||
(list (last vs))))
|
||||
|
||||
(define (subdivide-polygon transform vs)
|
||||
(subdivide-lines transform (cons (last vs) vs)))
|
||||
|
|
|
|||
|
|
@ -19,11 +19,11 @@
|
|||
(defproc (line-legend-entry [label string?]
|
||||
[color plot-color/c] [width (>=/c 0)] [style plot-pen-style/c]
|
||||
) legend-entry?
|
||||
(legend-entry label (λ (plot-area x-min x-max y-min y-max)
|
||||
(legend-entry label (λ (pd x-min x-max y-min y-max)
|
||||
(define y (* 1/2 (+ y-min y-max)))
|
||||
(send plot-area set-pen color width style)
|
||||
(send plot-area set-alpha 1)
|
||||
(send plot-area draw-line (vector x-min y) (vector x-max y)))))
|
||||
(send pd set-pen color width style)
|
||||
(send pd set-alpha 1)
|
||||
(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]
|
||||
|
|
@ -51,11 +51,11 @@
|
|||
[fill-color plot-color/c] [fill-style plot-brush-style/c]
|
||||
[line-color plot-color/c] [line-width (>=/c 0)]
|
||||
[line-style plot-pen-style/c]) legend-entry?
|
||||
(legend-entry label (λ (plot-area x-min x-max y-min y-max)
|
||||
(send plot-area set-brush fill-color fill-style)
|
||||
(send plot-area set-pen line-color line-width line-style)
|
||||
(send plot-area set-alpha 1)
|
||||
(send plot-area draw-rectangle (vector x-min y-min) (vector x-max y-max)))))
|
||||
(legend-entry label (λ (pd x-min x-max y-min y-max)
|
||||
(send pd set-brush fill-color fill-style)
|
||||
(send pd set-pen line-color line-width line-style)
|
||||
(send pd set-alpha 1)
|
||||
(send pd draw-rectangle (vector x-min y-min) (vector x-max y-max)))))
|
||||
|
||||
(defproc (rectangle-legend-entries [label string?] [zs (listof real?)]
|
||||
[fill-colors plot-colors/c] [fill-styles plot-brush-styles/c]
|
||||
|
|
@ -92,18 +92,18 @@
|
|||
[line1-color plot-color/c] [line1-width (>=/c 0)] [line1-style plot-pen-style/c]
|
||||
[line2-color plot-color/c] [line2-width (>=/c 0)] [line2-style plot-pen-style/c]
|
||||
) legend-entry?
|
||||
(legend-entry label (λ (plot-area x-min x-max y-min y-max)
|
||||
(send plot-area set-alpha 1)
|
||||
(legend-entry label (λ (pd x-min x-max y-min y-max)
|
||||
(send pd set-alpha 1)
|
||||
;; rectangle
|
||||
(send plot-area set-pen line-color line-width line-style)
|
||||
(send plot-area set-brush fill-color fill-style)
|
||||
(send plot-area draw-rectangle (vector x-min y-min) (vector x-max y-max))
|
||||
(send pd set-pen line-color line-width line-style)
|
||||
(send pd set-brush fill-color fill-style)
|
||||
(send pd draw-rectangle (vector x-min y-min) (vector x-max y-max))
|
||||
;; bottom line
|
||||
(send plot-area set-pen line1-color line1-width line1-style)
|
||||
(send plot-area draw-line (vector x-min y-max) (vector x-max y-max))
|
||||
(send pd set-pen line1-color line1-width line1-style)
|
||||
(send pd draw-line (vector x-min y-max) (vector x-max y-max))
|
||||
;; top line
|
||||
(send plot-area set-pen line2-color line2-width line2-style)
|
||||
(send plot-area draw-line (vector x-min y-min) (vector x-max y-min)))))
|
||||
(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?)]
|
||||
|
|
@ -173,19 +173,19 @@
|
|||
|
||||
(defproc (point-legend-entry [label string?] [sym point-sym/c]
|
||||
[color plot-color/c] [size (>=/c 0)] [line-width (>=/c 0)]) legend-entry?
|
||||
(legend-entry label (λ (plot-area x-min x-max y-min y-max)
|
||||
(send plot-area set-pen color line-width 'solid)
|
||||
(send plot-area set-alpha 1)
|
||||
(send plot-area draw-glyphs
|
||||
(legend-entry label (λ (pd x-min x-max y-min y-max)
|
||||
(send pd set-pen color line-width 'solid)
|
||||
(send pd set-alpha 1)
|
||||
(send pd draw-glyphs
|
||||
(list (vector (* 1/2 (+ x-min x-max)) (* 1/2 (+ y-min y-max))))
|
||||
sym size))))
|
||||
|
||||
(defproc (vector-field-legend-entry [label string?] [color plot-color/c]
|
||||
[line-width (>=/c 0)] [line-style plot-pen-style/c]
|
||||
) legend-entry?
|
||||
(legend-entry label (λ (plot-area x-min x-max y-min y-max)
|
||||
(send plot-area set-pen color line-width line-style)
|
||||
(send plot-area set-alpha 1)
|
||||
(send plot-area draw-arrow-glyph
|
||||
(legend-entry label (λ (pd x-min x-max y-min y-max)
|
||||
(send pd set-pen color line-width line-style)
|
||||
(send pd set-alpha 1)
|
||||
(send pd draw-arrow-glyph
|
||||
(vector (* 1/2 (+ x-min x-max)) (* 1/2 (+ y-min y-max)))
|
||||
(* 1/4 (- x-max x-min)) 0))))
|
||||
|
|
|
|||
|
|
@ -1,14 +1,10 @@
|
|||
#lang racket/base
|
||||
|
||||
;; Defines the base class for 2d-plot-area% and 3d-plot-area%.
|
||||
|
||||
;; Instances of this class know how to draw points, polygons, rectangles, lines, text, and a bunch of
|
||||
;; Instances of this class know how to draw points, polygons, rectangles, lines, text, a bunch of
|
||||
;; different "glyphs" (used for point symbols and ticks), and legends on their underlying device
|
||||
;; contexts.
|
||||
;; contexts. Drawing functions accept vectors representing dc coordinates.
|
||||
|
||||
;; Drawing functions accept vectors representing dc coordinates. It is up to descendants to provide
|
||||
;; drawing functions that accept view coordinates and transform them into dc coordinates. By
|
||||
;; convention, such functions start with "put-" instead of "draw-".
|
||||
;; It is up to callers to transform view or plot coordinates into dc coordinates.
|
||||
|
||||
(require racket/draw racket/class racket/match racket/math racket/bool racket/list racket/contract
|
||||
"contract.rkt"
|
||||
|
|
@ -18,7 +14,7 @@
|
|||
"parameters.rkt"
|
||||
"legend.rkt")
|
||||
|
||||
(provide plot-area%)
|
||||
(provide plot-device%)
|
||||
|
||||
(define (coord->cons v)
|
||||
(match-define (vector x y) v)
|
||||
|
|
@ -152,7 +148,7 @@
|
|||
try-color)
|
||||
(super-new)))
|
||||
|
||||
(define plot-area%
|
||||
(define plot-device%
|
||||
(class object%
|
||||
(init-field dc dc-x-min dc-y-min dc-x-size dc-y-size)
|
||||
|
||||
|
|
@ -547,7 +543,7 @@
|
|||
;; ===============================================================================================
|
||||
;; Legend
|
||||
|
||||
(define/public (draw-legend-box legend-entries x-min x-max y-min y-max)
|
||||
(define/public (draw-legend legend-entries x-min x-max y-min y-max)
|
||||
(define n (length legend-entries))
|
||||
(match-define (list (legend-entry labels draws) ...) legend-entries)
|
||||
|
||||
|
|
@ -88,9 +88,12 @@
|
|||
x-min x-max y-min y-max
|
||||
dc 0 0 width height))
|
||||
|
||||
(define data+axes (mix x-axis-data y-axis-data data))
|
||||
|
||||
(send area start-plot)
|
||||
(send area start-renderer x-min x-max y-min y-max)
|
||||
((mix x-axis-data y-axis-data data) area)
|
||||
(data+axes area)
|
||||
(send area end-renderers)
|
||||
(send area end-plot)
|
||||
|
||||
(when out-file (send bm save-file out-file 'png))
|
||||
|
|
@ -135,6 +138,7 @@
|
|||
(send area start-plot)
|
||||
(send area start-renderer x-min x-max y-min y-max z-min z-max)
|
||||
(data area)
|
||||
(send area end-renderers)
|
||||
(send area end-plot)
|
||||
|
||||
(when out-file (send bm save-file out-file 'png))
|
||||
|
|
|
|||
|
|
@ -3,10 +3,11 @@
|
|||
(require racket/contract unstable/latent-contract racket/class)
|
||||
|
||||
(require "../common/legend.rkt"
|
||||
"../common/area.rkt")
|
||||
"../common/plot-device.rkt")
|
||||
(provide (contract-out
|
||||
(struct legend-entry ([label string?]
|
||||
[draw ((is-a?/c plot-area%) real? real? real? real? . -> . void?)])))
|
||||
[draw ((is-a?/c plot-device%) real? real? real? real?
|
||||
. -> . void?)])))
|
||||
(activate-contract-out
|
||||
line-legend-entry line-legend-entries
|
||||
rectangle-legend-entry rectangle-legend-entries
|
||||
|
|
|
|||
|
|
@ -1,10 +1,11 @@
|
|||
#lang racket/base
|
||||
|
||||
(require racket/draw racket/class racket/contract racket/match racket/math racket/list racket/string
|
||||
"../common/area.rkt"
|
||||
"../common/plot-device.rkt"
|
||||
"../common/ticks.rkt"
|
||||
"../common/contract.rkt"
|
||||
"../common/math.rkt"
|
||||
"../common/draw.rkt"
|
||||
"../common/axis-transform.rkt"
|
||||
"../common/sample.rkt"
|
||||
"../common/legend.rkt"
|
||||
|
|
@ -17,23 +18,16 @@
|
|||
(define plot2d-subdivisions (make-parameter 0))
|
||||
|
||||
(define 2d-plot-area%
|
||||
(class plot-area%
|
||||
(class object%
|
||||
(init-field rx-ticks rx-far-ticks ry-ticks ry-far-ticks
|
||||
x-min x-max y-min y-max)
|
||||
(init dc dc-x-min dc-y-min dc-x-size dc-y-size)
|
||||
(inherit
|
||||
set-alpha set-pen set-major-pen set-minor-pen set-brush set-background set-text-foreground
|
||||
set-font restore-drawing-params reset-drawing-params
|
||||
get-text-width get-text-extent get-char-height get-char-baseline
|
||||
set-clipping-rect clear-clipping-rect
|
||||
clear draw-polygon draw-rectangle draw-line draw-lines draw-text draw-glyphs draw-arrow
|
||||
draw-tick draw-legend-box)
|
||||
(super-new)
|
||||
|
||||
(super-make-object dc dc-x-min dc-y-min dc-x-size dc-y-size)
|
||||
(define pd (make-object plot-device% dc dc-x-min dc-y-min dc-x-size dc-y-size))
|
||||
(send pd reset-drawing-params)
|
||||
|
||||
(reset-drawing-params)
|
||||
|
||||
(define char-height (get-char-height))
|
||||
(define char-height (send pd get-char-height))
|
||||
|
||||
(define dc-x-max (+ dc-x-min dc-x-size))
|
||||
(define dc-y-max (+ dc-y-min dc-y-size))
|
||||
|
|
@ -71,6 +65,11 @@
|
|||
(define/public (clip-to-none)
|
||||
(set! clipping? #f))
|
||||
|
||||
(define (in-bounds? v)
|
||||
(or (not clipping?)
|
||||
(point-in-bounds? v clip-x-min clip-x-max
|
||||
clip-y-min clip-y-max)))
|
||||
|
||||
(define/public (get-x-ticks) x-ticks)
|
||||
(define/public (get-x-far-ticks) x-far-ticks)
|
||||
(define/public (get-y-ticks) y-ticks)
|
||||
|
|
@ -99,10 +98,11 @@
|
|||
(vector (fx x) (fy y))))]))
|
||||
|
||||
(define view->dc #f)
|
||||
(define/public (plot->dc v) (view->dc (plot->view v)))
|
||||
(define (plot->dc* v) (view->dc (plot->view v)))
|
||||
(define/public (plot->dc v) (plot->dc* v))
|
||||
|
||||
(define/public (plot-line->dc-angle v1 v2)
|
||||
(match-define (vector dx dy) (v- (plot->dc v1) (plot->dc v2)))
|
||||
(match-define (vector dx dy) (v- (plot->dc* v1) (plot->dc* v2)))
|
||||
(- (atan2 (- dy) dx)))
|
||||
|
||||
(define (make-view->dc left right top bottom)
|
||||
|
|
@ -135,15 +135,17 @@
|
|||
;; ===============================================================================================
|
||||
;; Tick and label constants
|
||||
|
||||
(define near-dist^2 (sqr(* 3 (plot-line-width))))
|
||||
(define (vnear? v1 v2)
|
||||
((vmag^2 (v- (plot->dc* v1) (plot->dc* v2))) . <= . near-dist^2))
|
||||
|
||||
(define ((x-tick-near? y) t1 t2)
|
||||
((vmag (v- (plot->dc (vector (pre-tick-value t1) y))
|
||||
(plot->dc (vector (pre-tick-value t2) y))))
|
||||
. <= . (* 3 (plot-line-width))))
|
||||
(vnear? (vector (pre-tick-value t1) y)
|
||||
(vector (pre-tick-value t2) y)))
|
||||
|
||||
(define ((y-tick-near? x) t1 t2)
|
||||
((vmag (v- (plot->dc (vector x (pre-tick-value t1)))
|
||||
(plot->dc (vector x (pre-tick-value t2)))))
|
||||
. <= . (* 3 (plot-line-width))))
|
||||
(vnear? (vector x (pre-tick-value t1))
|
||||
(vector x (pre-tick-value t2))))
|
||||
|
||||
(define x-ticks
|
||||
(collapse-nearby-ticks (filter (λ (t) (<= x-min (pre-tick-value t) x-max)) rx-ticks)
|
||||
|
|
@ -176,7 +178,7 @@
|
|||
|
||||
(define (max-tick-label-width ts)
|
||||
(apply max 0 (for/list ([t (in-list ts)] #:when (pre-tick-major? t))
|
||||
(get-text-width (tick-label t)))))
|
||||
(send pd get-text-width (tick-label t)))))
|
||||
|
||||
(define max-x-tick-label-height (if (plot-x-axis?) (max-tick-label-height x-ticks) 0))
|
||||
(define max-y-tick-label-width (if (plot-y-axis?) (max-tick-label-width y-ticks) 0))
|
||||
|
|
@ -227,25 +229,25 @@
|
|||
(define offset (vector 0 (+ (pen-gap) (* 1/2 (plot-tick-size)))))
|
||||
(for/list ([t (in-list x-ticks)] #:when (pre-tick-major? t))
|
||||
(match-define (tick x _ label) t)
|
||||
(list label (v+ (plot->dc (vector x y-min)) offset) 'top)))
|
||||
(list label (v+ (plot->dc* (vector x y-min)) offset) 'top)))
|
||||
|
||||
(define (get-y-tick-label-params)
|
||||
(define offset (vector (+ (pen-gap) (* 1/2 (plot-tick-size))) 0))
|
||||
(for/list ([t (in-list y-ticks)] #:when (pre-tick-major? t))
|
||||
(match-define (tick y _ label) t)
|
||||
(list label (v- (plot->dc (vector x-min y)) offset) 'right)))
|
||||
(list label (v- (plot->dc* (vector x-min y)) offset) 'right)))
|
||||
|
||||
(define (get-x-far-tick-label-params)
|
||||
(define offset (vector 0 (+ (pen-gap) (* 1/2 (plot-tick-size)))))
|
||||
(for/list ([t (in-list x-far-ticks)] #:when (pre-tick-major? t))
|
||||
(match-define (tick x _ label) t)
|
||||
(list label (v- (plot->dc (vector x y-max)) offset) 'bottom)))
|
||||
(list label (v- (plot->dc* (vector x y-max)) offset) 'bottom)))
|
||||
|
||||
(define (get-y-far-tick-label-params)
|
||||
(define offset (vector (+ (pen-gap) (* 1/2 (plot-tick-size))) 0))
|
||||
(for/list ([t (in-list y-far-ticks)] #:when (pre-tick-major? t))
|
||||
(match-define (tick y _ label) t)
|
||||
(list label (v+ (plot->dc (vector x-max y)) offset) 'left)))
|
||||
(list label (v+ (plot->dc* (vector x-max y)) offset) 'left)))
|
||||
|
||||
;; ===============================================================================================
|
||||
;; Tick parameters
|
||||
|
|
@ -257,16 +259,16 @@
|
|||
(append
|
||||
(for/list ([t (in-list (if (plot-x-axis?) x-ticks empty))])
|
||||
(match-define (tick x major? _) t)
|
||||
(list major? (plot->dc (vector x y-min)) (if major? radius 1/2radius) (* 1/2 pi)))
|
||||
(list major? (plot->dc* (vector x y-min)) (if major? radius 1/2radius) (* 1/2 pi)))
|
||||
(for/list ([t (in-list (if (plot-y-axis?) y-ticks empty))])
|
||||
(match-define (tick y major? _) t)
|
||||
(list major? (plot->dc (vector x-min y)) (if major? radius 1/2radius) 0))
|
||||
(list major? (plot->dc* (vector x-min y)) (if major? radius 1/2radius) 0))
|
||||
(for/list ([t (in-list (if (plot-x-far-axis?) x-far-ticks empty))])
|
||||
(match-define (tick x major? _) t)
|
||||
(list major? (plot->dc (vector x y-max)) (if major? radius 1/2radius) (* 1/2 pi)))
|
||||
(list major? (plot->dc* (vector x y-max)) (if major? radius 1/2radius) (* 1/2 pi)))
|
||||
(for/list ([t (in-list (if (plot-y-far-axis?) y-far-ticks empty))])
|
||||
(match-define (tick y major? _) t)
|
||||
(list major? (plot->dc (vector x-max y)) (if major? radius 1/2radius) 0)))]
|
||||
(list major? (plot->dc* (vector x-max y)) (if major? radius 1/2radius) 0)))]
|
||||
[else empty]))
|
||||
|
||||
;; ===============================================================================================
|
||||
|
|
@ -290,9 +292,9 @@
|
|||
|
||||
(define (new-margins left right top bottom label-params tick-params)
|
||||
(match-define (list (vector label-xs label-ys) ...)
|
||||
(append* (map (λ (params) (send/apply this get-text-corners params)) label-params)))
|
||||
(append* (map (λ (params) (send/apply pd get-text-corners params)) label-params)))
|
||||
(match-define (list (vector tick-xs tick-ys) ...)
|
||||
(append* (map (λ (params) (send/apply this get-tick-endpoints (rest params))) tick-params)))
|
||||
(append* (map (λ (params) (send/apply pd get-tick-endpoints (rest params))) tick-params)))
|
||||
(define xs (append label-xs tick-xs))
|
||||
(define ys (append label-ys tick-ys))
|
||||
|
||||
|
|
@ -322,95 +324,89 @@
|
|||
|
||||
(define (draw-labels)
|
||||
(for ([params (in-list (get-label-params))])
|
||||
(send/apply this draw-text params)))
|
||||
(send/apply pd draw-text params)))
|
||||
|
||||
(define (draw-ticks)
|
||||
(for ([params (in-list (get-tick-params))])
|
||||
(match-define (list major? v r angle) params)
|
||||
(if major? (set-major-pen) (set-minor-pen))
|
||||
(send this draw-tick v r angle)))
|
||||
(if major? (put-major-pen) (put-minor-pen))
|
||||
(send pd draw-tick v r angle)))
|
||||
|
||||
(define (draw-title)
|
||||
(when (and (plot-decorations?) (plot-title))
|
||||
(draw-text (plot-title) (vector (* 1/2 (+ dc-x-min dc-x-max)) dc-y-min) 'top)))
|
||||
(send pd draw-text (plot-title) (vector (* 1/2 (+ dc-x-min dc-x-max)) dc-y-min) 'top)))
|
||||
|
||||
(define (draw-borders)
|
||||
(when (plot-decorations?)
|
||||
(set-minor-pen)
|
||||
(when (plot-x-axis?) (draw-line (vector area-x-min area-y-max)
|
||||
(vector area-x-max area-y-max)))
|
||||
(when (plot-x-far-axis?) (draw-line (vector area-x-min area-y-min)
|
||||
(vector area-x-max area-y-min)))
|
||||
(when (plot-y-axis?) (draw-line (vector area-x-min area-y-min)
|
||||
(vector area-x-min area-y-max)))
|
||||
(when (plot-y-far-axis?) (draw-line (vector area-x-max area-y-min)
|
||||
(vector area-x-max area-y-max)))))
|
||||
(put-minor-pen)
|
||||
(when (plot-x-axis?) (send pd draw-line
|
||||
(vector area-x-min area-y-max)
|
||||
(vector area-x-max area-y-max)))
|
||||
(when (plot-x-far-axis?) (send pd draw-line
|
||||
(vector area-x-min area-y-min)
|
||||
(vector area-x-max area-y-min)))
|
||||
(when (plot-y-axis?) (send pd draw-line
|
||||
(vector area-x-min area-y-min)
|
||||
(vector area-x-min area-y-max)))
|
||||
(when (plot-y-far-axis?) (send pd draw-line
|
||||
(vector area-x-max area-y-min)
|
||||
(vector area-x-max area-y-max)))))
|
||||
|
||||
;; ===============================================================================================
|
||||
;; Drawing
|
||||
;; Public drawing control (used by plot/dc)
|
||||
|
||||
(define/public (start-plot)
|
||||
(reset-drawing-params)
|
||||
(clear)
|
||||
(send pd reset-drawing-params)
|
||||
(send pd clear)
|
||||
(draw-borders)
|
||||
(draw-ticks))
|
||||
|
||||
(define/public (start-renderer rx-min rx-max ry-min ry-max)
|
||||
(reset-drawing-params)
|
||||
(set-clipping-rect (vector (+ 1/2 (- area-x-min (plot-line-width)))
|
||||
(+ 1/2 (- area-y-min (plot-line-width))))
|
||||
(vector (+ area-x-max (plot-line-width))
|
||||
(+ area-y-max (plot-line-width))))
|
||||
(send pd reset-drawing-params)
|
||||
(send pd set-clipping-rect (vector (+ 1/2 (- area-x-min (plot-line-width)))
|
||||
(+ 1/2 (- area-y-min (plot-line-width))))
|
||||
(vector (+ area-x-max (plot-line-width))
|
||||
(+ area-y-max (plot-line-width))))
|
||||
(clip-to-bounds rx-min rx-max ry-min ry-max))
|
||||
|
||||
(define/public (end-plot)
|
||||
(clear-clipping-rect)
|
||||
(define/public (end-renderers)
|
||||
(send pd clear-clipping-rect)
|
||||
(clip-to-none)
|
||||
(reset-drawing-params)
|
||||
(send pd reset-drawing-params)
|
||||
(draw-title)
|
||||
(draw-labels))
|
||||
|
||||
(define/public (draw-legend legend-entries)
|
||||
(define gap-size (+ (pen-gap) (* 1/2 (plot-tick-size))))
|
||||
(draw-legend-box legend-entries
|
||||
(+ area-x-min gap-size) (- area-x-max gap-size)
|
||||
(+ area-y-min gap-size) (- area-y-max gap-size)))
|
||||
(send pd draw-legend
|
||||
legend-entries
|
||||
(+ area-x-min gap-size) (- area-x-max gap-size)
|
||||
(+ area-y-min gap-size) (- area-y-max gap-size)))
|
||||
|
||||
(define subdivide-fracs '(3/7 4/7 2/7 5/7 1/7 6/7))
|
||||
(define/public (end-plot)
|
||||
(send pd restore-drawing-params))
|
||||
|
||||
(define (subdivide-line v1 v2 [depth 10])
|
||||
(let/ec return
|
||||
(when (zero? depth) (return (list v1 v2)))
|
||||
|
||||
(define dc-v1 (plot->dc v1))
|
||||
(define dc-v2 (plot->dc v2))
|
||||
(define dc-dv (v- dc-v2 dc-v1))
|
||||
(when ((vmag dc-dv) . <= . 3)
|
||||
(return (list v1 v2)))
|
||||
|
||||
(define dv (v- v2 v1))
|
||||
(define-values (max-area vc)
|
||||
(for/fold ([max-area 0] [vc v1]) ([frac (in-list subdivide-fracs)])
|
||||
(define test-vc (v+ (v* dv frac) v1))
|
||||
(define test-area (abs (vcross2 dc-dv (v- (plot->dc test-vc) dc-v1))))
|
||||
(cond [(test-area . > . max-area) (values test-area test-vc)]
|
||||
[else (values max-area vc)])))
|
||||
(when (max-area . <= . 3) (return (list v1 v2)))
|
||||
|
||||
;(plot2d-subdivisions (+ (plot2d-subdivisions) 1))
|
||||
(append (subdivide-line v1 vc (- depth 1))
|
||||
(rest (subdivide-line vc v2 (- depth 1))))))
|
||||
;; ===============================================================================================
|
||||
;; Public drawing interface (used by renderers)
|
||||
|
||||
(define (subdivide-lines vs)
|
||||
(append
|
||||
(append*
|
||||
(for/list ([v1 (in-list vs)] [v2 (in-list (rest vs))])
|
||||
(define line-vs (subdivide-line v1 v2))
|
||||
(take line-vs (sub1 (length line-vs)))))
|
||||
(list (last vs))))
|
||||
(define/public (get-plot-device) pd)
|
||||
|
||||
(define (subdivide-polygon vs)
|
||||
(subdivide-lines (append vs (list (first vs)))))
|
||||
(define/public (put-alpha alpha) (send pd set-alpha alpha))
|
||||
|
||||
(define/public (put-pen color width style) (send pd set-pen color width style))
|
||||
(define/public (put-major-pen [style 'solid]) (send pd set-major-pen style))
|
||||
(define/public (put-minor-pen [style 'solid]) (send pd set-minor-pen style))
|
||||
|
||||
(define/public (put-brush color style) (send pd set-brush color style))
|
||||
|
||||
(define/public (put-background color) (send pd set-background color))
|
||||
|
||||
(define/public (put-font-size size) (send pd set-font-size size))
|
||||
(define/public (put-font-family family) (send pd set-font-family family))
|
||||
(define/public (put-font size family) (send pd set-font size family))
|
||||
(define/public (put-text-foreground color) (send pd set-text-foreground color))
|
||||
|
||||
;; Shapes
|
||||
|
||||
(define/public (put-lines vs)
|
||||
(for ([vs (vregular-sublists vs)])
|
||||
|
|
@ -419,8 +415,8 @@
|
|||
clip-y-min clip-y-max))
|
||||
(in-value vs))])
|
||||
(when (not (empty? vs))
|
||||
(let ([vs (if identity-transforms? vs (subdivide-lines vs))])
|
||||
(draw-lines (map (λ (v) (plot->dc v)) vs)))))))
|
||||
(let ([vs (if identity-transforms? vs (subdivide-lines plot->dc* vs))])
|
||||
(send pd draw-lines (map (λ (v) (plot->dc* v)) vs)))))))
|
||||
|
||||
(define/public (put-line v1 v2)
|
||||
(when (and (vregular? v1) (vregular? v2))
|
||||
|
|
@ -430,9 +426,9 @@
|
|||
(values v1 v2))])
|
||||
(when (and v1 v2)
|
||||
(if identity-transforms?
|
||||
(draw-line (plot->dc v1) (plot->dc v2))
|
||||
(draw-lines (map (λ (v) (plot->dc v))
|
||||
(subdivide-line v1 v2))))))))
|
||||
(send pd draw-line (plot->dc* v1) (plot->dc* v2))
|
||||
(send pd draw-lines (map (λ (v) (plot->dc* v))
|
||||
(subdivide-line plot->dc* v1 v2))))))))
|
||||
|
||||
(define/public (put-polygon vs)
|
||||
(when (andmap vregular? vs)
|
||||
|
|
@ -442,9 +438,9 @@
|
|||
vs)])
|
||||
(when (not (empty? vs))
|
||||
(if identity-transforms?
|
||||
(draw-polygon (map (λ (v) (plot->dc v)) vs))
|
||||
(draw-polygon (map (λ (v) (plot->dc v))
|
||||
(subdivide-polygon vs))))))))
|
||||
(send pd draw-polygon (map (λ (v) (plot->dc* v)) vs))
|
||||
(send pd draw-polygon (map (λ (v) (plot->dc* v))
|
||||
(subdivide-polygon plot->dc* vs))))))))
|
||||
|
||||
(define/public (put-rectangle v1 v2)
|
||||
(when (and (vregular? v1) (vregular? v2))
|
||||
|
|
@ -453,29 +449,24 @@
|
|||
clip-y-min clip-y-max)
|
||||
(values v1 v2))])
|
||||
(when (and v1 v2)
|
||||
(draw-rectangle (plot->dc v1) (plot->dc v2))))))
|
||||
|
||||
(define (in-bounds? v)
|
||||
(or (not clipping?)
|
||||
(point-in-bounds? v clip-x-min clip-x-max
|
||||
clip-y-min clip-y-max)))
|
||||
(send pd draw-rectangle (plot->dc* v1) (plot->dc* v2))))))
|
||||
|
||||
(define/public (put-text str v [anchor 'top-left] [angle 0]
|
||||
#:outline? [outline? #f])
|
||||
(when (and (vregular? v) (in-bounds? v))
|
||||
(draw-text str (plot->dc v) anchor angle #:outline? outline?)))
|
||||
(send pd draw-text str (plot->dc* v) anchor angle #:outline? outline?)))
|
||||
|
||||
(define/public (put-glyphs vs symbol size)
|
||||
(draw-glyphs (map (λ (v) (plot->dc v))
|
||||
(filter (λ (v) (and (vregular? v) (in-bounds? v)))
|
||||
vs))
|
||||
symbol size))
|
||||
(send pd draw-glyphs (map (λ (v) (plot->dc* v))
|
||||
(filter (λ (v) (and (vregular? v) (in-bounds? v)))
|
||||
vs))
|
||||
symbol size))
|
||||
|
||||
(define/public (put-arrow v1 v2)
|
||||
(when (and (vregular? v1) (vregular? v2) (in-bounds? v1))
|
||||
(draw-arrow (plot->dc v1) (plot->dc v2))))
|
||||
(send pd draw-arrow (plot->dc* v1) (plot->dc* v2))))
|
||||
|
||||
(define/public (put-tick v r angle)
|
||||
(when (and (vregular? v) (in-bounds? v))
|
||||
(draw-tick (plot->dc v) r angle)))
|
||||
(send pd draw-tick (plot->dc* v) r angle)))
|
||||
))
|
||||
|
|
|
|||
|
|
@ -19,8 +19,8 @@
|
|||
(g x-min x-max samples y-min y-max samples))
|
||||
|
||||
(when (<= z-min z z-max)
|
||||
(send area set-alpha alpha)
|
||||
(send area set-pen color width style)
|
||||
(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)]
|
||||
|
|
@ -74,8 +74,8 @@
|
|||
[width (in-cycle ws)]
|
||||
[style (in-cycle ss)]
|
||||
[alpha (in-cycle as)])
|
||||
(send area set-alpha alpha)
|
||||
(send area set-pen color width style)
|
||||
(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)]
|
||||
|
|
@ -155,20 +155,20 @@
|
|||
(send area put-polygon poly)))
|
||||
|
||||
(cond [(= alpha 1)
|
||||
(send area set-pen color 1 poly-line-style)
|
||||
(send area set-brush color fill-style)
|
||||
(send area set-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 set-pen color 1 poly-line-style)
|
||||
(send area set-brush color 'transparent)
|
||||
(send area set-alpha (alpha-expt alpha 1/8))
|
||||
(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 set-pen color 1 'transparent)
|
||||
(send area set-brush color fill-style)
|
||||
(send area set-alpha alpha)
|
||||
(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)
|
||||
|
|
|
|||
|
|
@ -22,21 +22,22 @@
|
|||
(define x-ticks (if far? (send area get-x-far-ticks) (send area get-x-ticks)))
|
||||
(define radius (if ticks? (* 1/2 (plot-tick-size)) 0))
|
||||
|
||||
(send area set-alpha alpha)
|
||||
(send area set-major-pen)
|
||||
(send area put-alpha alpha)
|
||||
(send area put-major-pen)
|
||||
(send area put-line (vector x-min y) (vector x-max y))
|
||||
|
||||
(when ticks?
|
||||
(for ([t (in-list x-ticks)])
|
||||
(match-define (tick x major? _) t)
|
||||
(if major? (send area set-major-pen) (send area set-minor-pen))
|
||||
(if major? (send area put-major-pen) (send area put-minor-pen))
|
||||
(send area put-tick (vector x y) (if major? radius (* 1/2 radius)) (* 1/2 pi))))
|
||||
|
||||
(when labels?
|
||||
(define pd (send area get-plot-device))
|
||||
(define offset (vector 0 (+ radius (pen-gap))))
|
||||
(for ([t (in-list x-ticks)] #:when (pre-tick-major? t))
|
||||
(match-define (tick x _ label) t)
|
||||
(send area draw-text label
|
||||
(send pd draw-text label
|
||||
((if far? v- v+) (send area plot->dc (vector x y)) offset)
|
||||
(if far? 'bottom 'top) 0)))
|
||||
|
||||
|
|
@ -55,21 +56,22 @@
|
|||
(define y-ticks (if far? (send area get-y-far-ticks) (send area get-y-ticks)))
|
||||
(define radius (if ticks? (* 1/2 (plot-tick-size)) 0))
|
||||
|
||||
(send area set-alpha alpha)
|
||||
(send area set-major-pen)
|
||||
(send area put-alpha alpha)
|
||||
(send area put-major-pen)
|
||||
(send area put-line (vector x y-min) (vector x y-max))
|
||||
|
||||
(when ticks?
|
||||
(for ([t (in-list y-ticks)])
|
||||
(match-define (tick y major? _) t)
|
||||
(if major? (send area set-major-pen) (send area set-minor-pen))
|
||||
(if major? (send area put-major-pen) (send area put-minor-pen))
|
||||
(send area put-tick (vector x y) (if major? radius (* 1/2 radius)) 0)))
|
||||
|
||||
(when labels?
|
||||
(define pd (send area get-plot-device))
|
||||
(define offset (vector (+ radius (pen-gap)) 0))
|
||||
(for ([t (in-list y-ticks)] #:when (pre-tick-major? t))
|
||||
(match-define (tick y _ label) t)
|
||||
(send area draw-text label
|
||||
(send pd draw-text label
|
||||
((if far? v+ v-) (send area plot->dc (vector x y)) offset)
|
||||
(if far? 'left 'right) 0)))
|
||||
|
||||
|
|
@ -125,7 +127,7 @@
|
|||
;; Draw the tick lines
|
||||
(for ([t (in-list ts)])
|
||||
(match-define (tick r major? label) t)
|
||||
(if major? (send area set-minor-pen) (send area set-minor-pen 'long-dash))
|
||||
(if major? (send area put-minor-pen) (send area put-minor-pen 'long-dash))
|
||||
(define pts (for/list ([θ (in-list (linear-seq 0 (* 2 pi) 500))])
|
||||
(vector (* r (cos θ)) (* r (sin θ)))))
|
||||
(send area put-lines pts))
|
||||
|
|
@ -147,14 +149,14 @@
|
|||
(define-values (x-min x-max y-min y-max) (send area get-bounds))
|
||||
(define-values (θs r-mins r-maxs) (build-polar-axes num x-min x-max y-min y-max))
|
||||
|
||||
(send area set-major-pen)
|
||||
(send area put-major-pen)
|
||||
(for ([θ (in-list θs)] [r-min (in-list r-mins)] [r-max (in-list r-maxs)])
|
||||
(send area put-line
|
||||
(vector (* r-min (cos θ)) (* r-min (sin θ)))
|
||||
(vector (* r-max (cos θ)) (* r-max (sin θ))))))
|
||||
|
||||
(define ((polar-axes-render-proc num ticks? labels? alpha) area)
|
||||
(send area set-alpha alpha)
|
||||
(send area put-alpha alpha)
|
||||
(when (num . > . 0) (draw-polar-axis-lines num area))
|
||||
(when ticks? (draw-polar-axis-ticks (if (num . > . 0) num 12) labels? area))
|
||||
empty)
|
||||
|
|
@ -173,10 +175,10 @@
|
|||
(define y-max (send area get-y-max))
|
||||
(define x-ticks (send area get-x-ticks))
|
||||
|
||||
(send area set-alpha 1/2)
|
||||
(send area put-alpha 1/2)
|
||||
(for ([t (in-list x-ticks)])
|
||||
(match-define (tick x major? _) t)
|
||||
(if major? (send area set-minor-pen) (send area set-minor-pen 'long-dash))
|
||||
(if major? (send area put-minor-pen) (send area put-minor-pen 'long-dash))
|
||||
(send area put-line (vector x y-min) (vector x y-max)))
|
||||
|
||||
empty)
|
||||
|
|
@ -186,10 +188,10 @@
|
|||
(define x-max (send area get-x-max))
|
||||
(define y-ticks (send area get-y-ticks))
|
||||
|
||||
(send area set-alpha 1/2)
|
||||
(send area put-alpha 1/2)
|
||||
(for ([t (in-list y-ticks)])
|
||||
(match-define (tick y major? _) t)
|
||||
(if major? (send area set-minor-pen) (send area set-minor-pen 'long-dash))
|
||||
(if major? (send area put-minor-pen) (send area put-minor-pen 'long-dash))
|
||||
(send area put-line (vector x-min y) (vector x-max y)))
|
||||
|
||||
empty)
|
||||
|
|
@ -222,13 +224,13 @@
|
|||
|
||||
(define ((label-render-proc label v color size family anchor angle point-size alpha) area)
|
||||
(let ([label (if label label (format-coordinate v area))])
|
||||
(send area set-alpha alpha)
|
||||
(send area put-alpha alpha)
|
||||
; label
|
||||
(send area set-text-foreground color)
|
||||
(send area set-font size family)
|
||||
(send area put-text-foreground color)
|
||||
(send area put-font size family)
|
||||
(send area put-text (string-append " " label " ") v anchor angle #:outline? #t)
|
||||
; point
|
||||
(send area set-pen color 1 'solid)
|
||||
(send area put-pen color 1 'solid)
|
||||
(send area put-glyphs (list v) 'fullcircle point-size))
|
||||
|
||||
empty)
|
||||
|
|
|
|||
|
|
@ -16,15 +16,15 @@
|
|||
line2-color line2-width line2-style
|
||||
alpha label)
|
||||
area)
|
||||
(send area set-alpha alpha)
|
||||
(send area set-pen 0 0 'transparent)
|
||||
(send area set-brush color style)
|
||||
(send area put-alpha alpha)
|
||||
(send area put-pen 0 0 'transparent)
|
||||
(send area put-brush color style)
|
||||
(send area put-polygon (append v1s (reverse v2s)))
|
||||
|
||||
(send area set-pen line1-color line1-width line1-style)
|
||||
(send area put-pen line1-color line1-width line1-style)
|
||||
(send area put-lines v1s)
|
||||
|
||||
(send area set-pen line2-color line2-width line2-style)
|
||||
(send area put-pen line2-color line2-width line2-style)
|
||||
(send area put-lines v2s)
|
||||
|
||||
(cond [label (interval-legend-entry label color style 0 0 'transparent
|
||||
|
|
@ -127,8 +127,8 @@
|
|||
area)
|
||||
(define x-min (send area get-x-min))
|
||||
(define x-max (send area get-x-max))
|
||||
(match-define (list x1s y1s) (f1 x-min x-max samples))
|
||||
(match-define (list x2s y2s) (f2 x-min x-max samples))
|
||||
(match-define (sample x1s y1s y1-min y1-max) (f1 x-min x-max samples))
|
||||
(match-define (sample x2s y2s y2-min y2-max) (f2 x-min x-max samples))
|
||||
(define v1s (map vector x1s y1s))
|
||||
(define v2s (map vector x2s y2s))
|
||||
|
||||
|
|
@ -174,8 +174,8 @@
|
|||
area)
|
||||
(define y-min (send area get-y-min))
|
||||
(define y-max (send area get-y-max))
|
||||
(match-define (list y1s x1s) (f1 y-min y-max samples))
|
||||
(match-define (list y2s x2s) (f2 y-min y-max samples))
|
||||
(match-define (sample y1s x1s x1-min x1-max) (f1 y-min y-max samples))
|
||||
(match-define (sample y2s x2s x2-min x2-max) (f2 y-min y-max samples))
|
||||
(define v1s (map vector x1s y1s))
|
||||
(define v2s (map vector x2s y2s))
|
||||
|
||||
|
|
|
|||
|
|
@ -12,8 +12,8 @@
|
|||
;; Lines, parametric, polar
|
||||
|
||||
(define ((lines-render-proc vs color width style alpha label) area)
|
||||
(send area set-alpha alpha)
|
||||
(send area set-pen color width style)
|
||||
(send area put-alpha alpha)
|
||||
(send area put-pen color width style)
|
||||
(send area put-lines vs)
|
||||
|
||||
(cond [label (line-legend-entry label color width style)]
|
||||
|
|
@ -80,8 +80,8 @@
|
|||
(define x-max (send area get-x-max))
|
||||
(match-define (sample xs ys y-min y-max) (f x-min x-max samples))
|
||||
|
||||
(send area set-alpha alpha)
|
||||
(send area set-pen color width style)
|
||||
(send area put-alpha alpha)
|
||||
(send area put-pen color width style)
|
||||
(send area put-lines (map vector xs ys))
|
||||
|
||||
(cond [label (line-legend-entry label color width style)]
|
||||
|
|
@ -109,10 +109,10 @@
|
|||
(define ((inverse-render-proc f samples color width style alpha label) area)
|
||||
(define y-min (send area get-y-min))
|
||||
(define y-max (send area get-y-max))
|
||||
(match-define (list ys xs x-min x-max) (f y-min y-max samples))
|
||||
(match-define (sample ys xs x-min x-max) (f y-min y-max samples))
|
||||
|
||||
(send area set-alpha alpha)
|
||||
(send area set-pen color width style)
|
||||
(send area put-alpha alpha)
|
||||
(send area put-pen color width style)
|
||||
(send area put-lines (map vector xs ys))
|
||||
|
||||
(cond [label (line-legend-entry label color width style)]
|
||||
|
|
|
|||
|
|
@ -82,12 +82,12 @@
|
|||
(send area start-renderer rx-min rx-max ry-min ry-max)
|
||||
(if render-proc (render-proc area) empty))))
|
||||
|
||||
(send area end-plot)
|
||||
(send area end-renderers)
|
||||
|
||||
(when (not (empty? legend-entries))
|
||||
(send area draw-legend legend-entries))
|
||||
|
||||
(send area restore-drawing-params)))
|
||||
(send area end-plot)))
|
||||
|
||||
;; ===================================================================================================
|
||||
;; Plot to various other backends
|
||||
|
|
|
|||
|
|
@ -13,8 +13,8 @@
|
|||
;; Points (scatter plots)
|
||||
|
||||
(define ((points-render-fun vs sym color size line-width alpha label) area)
|
||||
(send area set-alpha alpha)
|
||||
(send area set-pen color line-width 'solid)
|
||||
(send area put-alpha alpha)
|
||||
(send area put-pen color line-width 'solid)
|
||||
(send area put-glyphs vs sym size)
|
||||
|
||||
(if label (point-legend-entry label sym color size line-width) empty))
|
||||
|
|
@ -71,8 +71,8 @@
|
|||
(/ box-y-size dy-max)))
|
||||
(map (λ (mag) (* scale mag)) mags)]))
|
||||
|
||||
(send area set-alpha alpha)
|
||||
(send area set-pen color line-width line-style)
|
||||
(send area put-alpha alpha)
|
||||
(send area put-pen color line-width line-style)
|
||||
(for ([x (in-list xs)]
|
||||
[y (in-list ys)]
|
||||
[angle (in-list angles)]
|
||||
|
|
@ -108,24 +108,17 @@
|
|||
(define ((error-bars-render-fun xs ys hs color line-width line-style width alpha) area)
|
||||
(define-values (x-min x-max y-min y-max) (send area get-clip-bounds))
|
||||
|
||||
(define half (* 1/2 width))
|
||||
(define radius (* 1/2 width))
|
||||
|
||||
(send area set-alpha alpha)
|
||||
(send area set-pen color line-width line-style)
|
||||
(send area put-alpha alpha)
|
||||
(send area put-pen color line-width line-style)
|
||||
(for ([x (in-list xs)] [y (in-list ys)] [h (in-list hs)])
|
||||
(when (point-in-bounds? (vector x y) x-min x-max y-min y-max)
|
||||
(define v1 (vector x (- y h)))
|
||||
(define v2 (vector x (+ y h)))
|
||||
(send area put-line v1 v2)
|
||||
|
||||
(match-define (vector dc-x1 dc-y1) (send area plot->dc v1))
|
||||
(match-define (vector dc-x2 dc-y2) (send area plot->dc v2))
|
||||
(send area draw-line
|
||||
(vector (- dc-x1 half) dc-y1)
|
||||
(vector (+ dc-x1 half) dc-y1))
|
||||
(send area draw-line
|
||||
(vector (- dc-x2 half) dc-y2)
|
||||
(vector (+ dc-x2 half) dc-y2))))
|
||||
(send area put-tick v1 radius 0)
|
||||
(send area put-tick v2 radius 0)))
|
||||
|
||||
empty)
|
||||
|
||||
|
|
|
|||
|
|
@ -14,9 +14,9 @@
|
|||
|
||||
(define ((rectangles-render-proc rects color style line-color line-width line-style alpha label)
|
||||
area)
|
||||
(send area set-pen line-color line-width line-style)
|
||||
(send area set-brush color style)
|
||||
(send area set-alpha alpha)
|
||||
(send area put-pen line-color line-width line-style)
|
||||
(send area put-brush color style)
|
||||
(send area put-alpha alpha)
|
||||
(for ([rect (in-list rects)])
|
||||
(match-define (vector (ivl x1 x2) (ivl y1 y2)) rect)
|
||||
(send area put-rectangle (vector x1 y1) (vector x2 y2)))
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
|
||||
(require racket/class racket/match racket/list racket/math racket/contract
|
||||
"../common/math.rkt"
|
||||
"../common/area.rkt"
|
||||
"../common/plot-device.rkt"
|
||||
"../common/ticks.rkt"
|
||||
"../common/draw.rkt"
|
||||
"../common/contract.rkt"
|
||||
|
|
@ -18,23 +18,16 @@
|
|||
(define plot3d-subdivisions (make-parameter 0))
|
||||
|
||||
(define 3d-plot-area%
|
||||
(class plot-area%
|
||||
(class object%
|
||||
(init-field rx-ticks rx-far-ticks ry-ticks ry-far-ticks rz-ticks rz-far-ticks
|
||||
x-min x-max y-min y-max z-min z-max)
|
||||
(init dc dc-x-min dc-y-min dc-x-size dc-y-size)
|
||||
(inherit
|
||||
set-alpha set-pen set-major-pen set-minor-pen set-brush set-background set-text-foreground
|
||||
set-font reset-drawing-params
|
||||
get-text-width get-text-extent get-char-height get-char-baseline
|
||||
set-clipping-rect clear-clipping-rect
|
||||
clear draw-polygon draw-rectangle draw-line draw-lines draw-text draw-glyphs draw-arrow-glyph
|
||||
draw-tick draw-legend-box)
|
||||
(super-new)
|
||||
|
||||
(super-make-object dc dc-x-min dc-y-min dc-x-size dc-y-size)
|
||||
(define pd (make-object plot-device% dc dc-x-min dc-y-min dc-x-size dc-y-size))
|
||||
(send pd reset-drawing-params)
|
||||
|
||||
(reset-drawing-params)
|
||||
|
||||
(define char-height (get-char-height))
|
||||
(define char-height (send pd get-char-height))
|
||||
|
||||
(define clipping? #f)
|
||||
(define clip-x-min x-min)
|
||||
|
|
@ -128,7 +121,8 @@
|
|||
|
||||
(define view->dc #f)
|
||||
(define (plot->dc/no-axis-trans v) (view->dc (m3-apply transform-matrix (center v))))
|
||||
(define (plot->dc v) (view->dc (plot->view v)))
|
||||
(define (plot->dc* v) (view->dc (plot->view v)))
|
||||
(define/public (plot->dc v) (plot->dc* v))
|
||||
|
||||
(define dc-x-max (+ dc-x-min dc-x-size))
|
||||
(define dc-y-max (+ dc-y-min dc-y-size))
|
||||
|
|
@ -163,7 +157,7 @@
|
|||
(vector (+ area-x-mid x) (- area-y-mid z)))))
|
||||
|
||||
;; Initial view->dc
|
||||
(define init-top-margin (if (and (plot-decorations?) (plot-title)) (* 3/2 (get-char-height)) 0))
|
||||
(define init-top-margin (if (and (plot-decorations?) (plot-title)) (* 3/2 char-height) 0))
|
||||
(set! view->dc (make-view->dc 0 0 init-top-margin 0))
|
||||
|
||||
;; ===============================================================================================
|
||||
|
|
@ -183,7 +177,7 @@
|
|||
|
||||
(define near-dist^2 (sqr(* 3 (plot-line-width))))
|
||||
(define (vnear? v1 v2)
|
||||
((vmag^2 (v- (plot->dc v1) (plot->dc v2))) . <= . near-dist^2))
|
||||
((vmag^2 (v- (plot->dc* v1) (plot->dc* v2))) . <= . near-dist^2))
|
||||
|
||||
(define ((x-ticks-near? y) t1 t2)
|
||||
(vnear? (vector (pre-tick-value t1) y z-min)
|
||||
|
|
@ -236,7 +230,7 @@
|
|||
|
||||
(define (max-tick-label-width ts)
|
||||
(apply max 0 (for/list ([t (in-list ts)] #:when (pre-tick-major? t))
|
||||
(get-text-width (tick-label t)))))
|
||||
(send pd get-text-width (tick-label t)))))
|
||||
|
||||
(define (max-x-tick-label-diag y-axis-angle)
|
||||
(if (plot-x-axis?)
|
||||
|
|
@ -296,7 +290,7 @@
|
|||
'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))
|
||||
(list #t (plot-z-label) (v+ (plot->dc* (vector z-axis-x z-axis-y z-max))
|
||||
(vector 0 (* -1/2 char-height)))
|
||||
'bottom-left 0))
|
||||
|
||||
|
|
@ -321,7 +315,7 @@
|
|||
'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))
|
||||
(list #t (plot-z-far-label) (v+ (plot->dc* (vector z-far-axis-x z-far-axis-y z-max))
|
||||
(vector 0 (* -1/2 char-height)))
|
||||
'bottom-right 0))
|
||||
|
||||
|
|
@ -359,7 +353,7 @@
|
|||
(if x-axis-y-min? (- dist) dist)))
|
||||
(for/list ([t (in-list x-ticks)] #:when (pre-tick-major? t))
|
||||
(match-define (tick x _ label) t)
|
||||
(list #f label (v+ (plot->dc (vector x x-axis-y z-min)) offset)
|
||||
(list #f label (v+ (plot->dc* (vector x x-axis-y z-min)) offset)
|
||||
x-tick-label-anchor 0)))
|
||||
|
||||
(define (get-y-tick-label-params)
|
||||
|
|
@ -369,15 +363,15 @@
|
|||
(if y-axis-x-min? (- dist) dist)))
|
||||
(for/list ([t (in-list y-ticks)] #:when (pre-tick-major? t))
|
||||
(match-define (tick y _ label) t)
|
||||
(list #f label (v+ (plot->dc (vector y-axis-x y z-min)) offset)
|
||||
(list #f label (v+ (plot->dc* (vector y-axis-x y z-min)) offset)
|
||||
y-tick-label-anchor 0)))
|
||||
|
||||
(define (get-z-tick-label-params)
|
||||
(define dist (+ (pen-gap) (* 1/2 (plot-tick-size))))
|
||||
(define offset (vector (- dist) (* 2 (get-char-baseline))))
|
||||
(define offset (vector (- dist) (* 2 (send pd get-char-baseline))))
|
||||
(for/list ([t (in-list z-ticks)] #:when (pre-tick-major? t))
|
||||
(match-define (tick z _ label) t)
|
||||
(list #t label (v+ (plot->dc (vector z-axis-x z-axis-y z)) offset) 'bottom-right 0)))
|
||||
(list #t label (v+ (plot->dc* (vector z-axis-x z-axis-y z)) offset) 'bottom-right 0)))
|
||||
|
||||
(define (get-x-far-tick-label-params)
|
||||
(define y-axis-angle (plot-dir->dc-angle (vector 0 1 0)))
|
||||
|
|
@ -386,7 +380,7 @@
|
|||
(if x-axis-y-min? dist (- dist))))
|
||||
(for/list ([t (in-list x-far-ticks)] #:when (pre-tick-major? t))
|
||||
(match-define (tick x _ label) t)
|
||||
(list #f label (v+ (plot->dc (vector x x-far-axis-y z-min)) offset)
|
||||
(list #f label (v+ (plot->dc* (vector x x-far-axis-y z-min)) offset)
|
||||
x-far-tick-label-anchor 0)))
|
||||
|
||||
(define (get-y-far-tick-label-params)
|
||||
|
|
@ -396,15 +390,15 @@
|
|||
(if y-axis-x-min? dist (- dist))))
|
||||
(for/list ([t (in-list y-far-ticks)] #:when (pre-tick-major? t))
|
||||
(match-define (tick y _ label) t)
|
||||
(list #f label (v+ (plot->dc (vector y-far-axis-x y z-min)) offset)
|
||||
(list #f label (v+ (plot->dc* (vector y-far-axis-x y z-min)) offset)
|
||||
y-far-tick-label-anchor 0)))
|
||||
|
||||
(define (get-z-far-tick-label-params)
|
||||
(define dist (+ (pen-gap) (* 1/2 (plot-tick-size))))
|
||||
(define offset (vector dist (* 2 (get-char-baseline))))
|
||||
(define offset (vector dist (* 2 (send pd get-char-baseline))))
|
||||
(for/list ([t (in-list z-far-ticks)] #:when (pre-tick-major? t))
|
||||
(match-define (tick z _ label) t)
|
||||
(list #t label (v+ (plot->dc (vector z-far-axis-x z-far-axis-y z)) offset)
|
||||
(list #t label (v+ (plot->dc* (vector z-far-axis-x z-far-axis-y z)) offset)
|
||||
'bottom-left 0)))
|
||||
|
||||
;; ===============================================================================================
|
||||
|
|
@ -415,7 +409,7 @@
|
|||
(define angle (plot-dir->dc-angle (vector 0 1 0)))
|
||||
(for/list ([t (in-list x-ticks)])
|
||||
(match-define (tick x major? _) t)
|
||||
(list major? (plot->dc (vector x x-axis-y z-min))
|
||||
(list major? (plot->dc* (vector x x-axis-y z-min))
|
||||
(if major? radius (* 1/2 radius)) angle)))
|
||||
|
||||
(define (get-y-tick-params)
|
||||
|
|
@ -423,14 +417,14 @@
|
|||
(define angle (plot-dir->dc-angle (vector 1 0 0)))
|
||||
(for/list ([t (in-list y-ticks)])
|
||||
(match-define (tick y major? _) t)
|
||||
(list major? (plot->dc (vector y-axis-x y z-min))
|
||||
(list major? (plot->dc* (vector y-axis-x y z-min))
|
||||
(if major? radius (* 1/2 radius)) angle)))
|
||||
|
||||
(define (get-z-tick-params)
|
||||
(define radius (* 1/2 (plot-tick-size)))
|
||||
(for/list ([t (in-list z-ticks)])
|
||||
(match-define (tick z major? _) t)
|
||||
(list major? (plot->dc (vector z-axis-x z-axis-y z))
|
||||
(list major? (plot->dc* (vector z-axis-x z-axis-y z))
|
||||
(if major? radius (* 1/2 radius)) 0)))
|
||||
|
||||
(define (get-x-far-tick-params)
|
||||
|
|
@ -438,7 +432,7 @@
|
|||
(define angle (plot-dir->dc-angle (vector 0 1 0)))
|
||||
(for/list ([t (in-list x-ticks)])
|
||||
(match-define (tick x major? _) t)
|
||||
(list major? (plot->dc (vector x x-far-axis-y z-min))
|
||||
(list major? (plot->dc* (vector x x-far-axis-y z-min))
|
||||
(if major? radius (* 1/2 radius)) angle)))
|
||||
|
||||
(define (get-y-far-tick-params)
|
||||
|
|
@ -446,14 +440,14 @@
|
|||
(define angle (plot-dir->dc-angle (vector 1 0 0)))
|
||||
(for/list ([t (in-list y-ticks)])
|
||||
(match-define (tick y major? _) t)
|
||||
(list major? (plot->dc (vector y-far-axis-x y z-min))
|
||||
(list major? (plot->dc* (vector y-far-axis-x y z-min))
|
||||
(if major? radius (* 1/2 radius)) angle)))
|
||||
|
||||
(define (get-z-far-tick-params)
|
||||
(define radius (* 1/2 (plot-tick-size)))
|
||||
(for/list ([t (in-list z-ticks)])
|
||||
(match-define (tick z major? _) t)
|
||||
(list major? (plot->dc (vector z-far-axis-x z-far-axis-y z))
|
||||
(list major? (plot->dc* (vector z-far-axis-x z-far-axis-y z))
|
||||
(if major? radius (* 1/2 radius)) 0)))
|
||||
|
||||
;; ===============================================================================================
|
||||
|
|
@ -519,9 +513,9 @@
|
|||
|
||||
(define (new-margins left right top bottom label-params tick-params)
|
||||
(match-define (list (vector label-xs label-ys) ...)
|
||||
(append* (map (λ (params) (send/apply this get-text-corners (rest params))) label-params)))
|
||||
(append* (map (λ (params) (send/apply pd get-text-corners (rest params))) label-params)))
|
||||
(match-define (list (vector tick-xs tick-ys) ...)
|
||||
(append* (map (λ (params) (send/apply this get-tick-endpoints (rest params))) tick-params)))
|
||||
(append* (map (λ (params) (send/apply pd get-tick-endpoints (rest params))) tick-params)))
|
||||
(define xs (append label-xs tick-xs))
|
||||
(define ys (append label-ys tick-ys))
|
||||
|
||||
|
|
@ -546,104 +540,93 @@
|
|||
(values new-left new-right new-top new-bottom)))
|
||||
|
||||
;; ===============================================================================================
|
||||
|
||||
;; Plot decoration
|
||||
|
||||
(define (draw-ticks tick-params)
|
||||
(for ([params (in-list tick-params)])
|
||||
(match-define (list major? v r angle) params)
|
||||
(if major? (set-major-pen) (set-minor-pen))
|
||||
(send this draw-tick v r angle)))
|
||||
(if major? (send pd set-major-pen) (send pd set-minor-pen))
|
||||
(send pd draw-tick v r angle)))
|
||||
|
||||
(define (draw-labels label-params)
|
||||
(for ([params (in-list label-params)])
|
||||
(send/apply this draw-text (rest params) #:outline? (first params))))
|
||||
(send/apply pd draw-text (rest params) #:outline? (first params))))
|
||||
|
||||
(define (draw-far-borders)
|
||||
(when (plot-decorations?)
|
||||
(set-minor-pen)
|
||||
(send pd set-minor-pen)
|
||||
(when (plot-x-axis?)
|
||||
(draw-line (plot->dc/no-axis-trans (vector x-min x-axis-y z-min))
|
||||
(plot->dc/no-axis-trans (vector x-max x-axis-y z-min))))
|
||||
(send pd draw-line
|
||||
(plot->dc/no-axis-trans (vector x-min x-axis-y z-min))
|
||||
(plot->dc/no-axis-trans (vector x-max x-axis-y z-min))))
|
||||
(when (plot-x-far-axis?)
|
||||
(draw-line (plot->dc/no-axis-trans (vector x-min x-far-axis-y z-min))
|
||||
(plot->dc/no-axis-trans (vector x-max x-far-axis-y z-min))))
|
||||
(send pd draw-line
|
||||
(plot->dc/no-axis-trans (vector x-min x-far-axis-y z-min))
|
||||
(plot->dc/no-axis-trans (vector x-max x-far-axis-y z-min))))
|
||||
(when (plot-y-axis?)
|
||||
(draw-line (plot->dc/no-axis-trans (vector y-axis-x y-min z-min))
|
||||
(plot->dc/no-axis-trans (vector y-axis-x y-max z-min))))
|
||||
(send pd draw-line
|
||||
(plot->dc/no-axis-trans (vector y-axis-x y-min z-min))
|
||||
(plot->dc/no-axis-trans (vector y-axis-x y-max z-min))))
|
||||
(when (plot-y-far-axis?)
|
||||
(draw-line (plot->dc/no-axis-trans (vector y-far-axis-x y-min z-min))
|
||||
(plot->dc/no-axis-trans (vector y-far-axis-x y-max z-min))))))
|
||||
(send pd draw-line
|
||||
(plot->dc/no-axis-trans (vector y-far-axis-x y-min z-min))
|
||||
(plot->dc/no-axis-trans (vector y-far-axis-x y-max z-min))))))
|
||||
|
||||
(define (draw-near-borders)
|
||||
(when (plot-decorations?)
|
||||
(set-minor-pen)
|
||||
(send pd set-minor-pen)
|
||||
(when (plot-z-axis?)
|
||||
(draw-line (plot->dc/no-axis-trans (vector z-axis-x z-axis-y z-min))
|
||||
(plot->dc/no-axis-trans (vector z-axis-x z-axis-y z-max))))
|
||||
(send pd draw-line
|
||||
(plot->dc/no-axis-trans (vector z-axis-x z-axis-y z-min))
|
||||
(plot->dc/no-axis-trans (vector z-axis-x z-axis-y z-max))))
|
||||
(when (plot-z-far-axis?)
|
||||
(draw-line (plot->dc/no-axis-trans (vector z-far-axis-x z-far-axis-y z-min))
|
||||
(plot->dc/no-axis-trans (vector z-far-axis-x z-far-axis-y z-max))))))
|
||||
(send pd draw-line
|
||||
(plot->dc/no-axis-trans (vector z-far-axis-x z-far-axis-y z-min))
|
||||
(plot->dc/no-axis-trans (vector z-far-axis-x z-far-axis-y z-max))))))
|
||||
|
||||
(define (draw-title)
|
||||
(when (and (plot-decorations?) (plot-title))
|
||||
(draw-text (plot-title) (vector (* 1/2 (+ dc-x-min dc-x-max)) dc-y-min) 'top)))
|
||||
(send pd draw-text (plot-title) (vector (* 1/2 (+ dc-x-min dc-x-max)) dc-y-min) 'top)))
|
||||
|
||||
(define/public (start-plot)
|
||||
(reset-drawing-params)
|
||||
(clear)
|
||||
(set! render-list empty)
|
||||
(draw-labels (get-far-label-params))
|
||||
(draw-ticks (get-far-tick-params))
|
||||
(draw-far-borders))
|
||||
;; ===============================================================================================
|
||||
;; Delayed drawing
|
||||
|
||||
(define/public (start-renderer rx-min rx-max ry-min ry-max rz-min rz-max)
|
||||
(reset-drawing-params)
|
||||
(clip-to-bounds rx-min rx-max ry-min ry-max rz-min rz-max))
|
||||
|
||||
(define/public (end-plot)
|
||||
(draw-render-list)
|
||||
(clip-to-none)
|
||||
(reset-drawing-params)
|
||||
(draw-title)
|
||||
(draw-near-borders)
|
||||
(draw-ticks (get-near-tick-params))
|
||||
(draw-labels (get-near-label-params)))
|
||||
|
||||
(define (put-major-pen) (put-pen (plot-foreground) (plot-line-width) 'solid))
|
||||
(define (put-minor-pen) (put-pen (plot-foreground) (* 1/2 (plot-line-width)) 'solid))
|
||||
|
||||
(define (draw-angles*)
|
||||
(define angle-str (format " angle = ~a " (number->string (round angle))))
|
||||
(define alt-str (format " altitude = ~a " (number->string (round altitude))))
|
||||
(define-values (angle-width angle-height baseline _angle2) (get-text-extent angle-str))
|
||||
(define-values (alt-width alt-height _alt1 _alt2) (get-text-extent alt-str))
|
||||
|
||||
(define box-x-size (max angle-width alt-width))
|
||||
(define box-y-size (+ angle-height alt-height (* 3 baseline)))
|
||||
(define box-x-min (+ dc-x-min (* 1/2 (- dc-x-size box-x-size))))
|
||||
(define box-y-min (+ dc-y-min (* 1/2 (- dc-y-size box-y-size))))
|
||||
(define box-x-max (+ box-x-min box-x-size))
|
||||
(define box-y-max (+ box-y-min box-y-size))
|
||||
|
||||
(set-alpha 1/2)
|
||||
(set-minor-pen)
|
||||
(set-brush (plot-background) 'solid)
|
||||
(draw-rectangle (vector box-x-min box-y-min) (vector box-x-max box-y-max))
|
||||
|
||||
(set-alpha 1)
|
||||
(draw-text angle-str (vector box-x-min (+ box-y-min baseline))
|
||||
'top-left #:outline? #t)
|
||||
(draw-text alt-str (vector box-x-min (+ box-y-min baseline char-height))
|
||||
'top-left #:outline? #t))
|
||||
|
||||
(define/public (draw-angles) (draw-angles*))
|
||||
|
||||
(define (draw-legend* legend-entries)
|
||||
(define gap (plot-line-width))
|
||||
(draw-legend-box legend-entries
|
||||
(+ dc-x-min gap) (- dc-x-max gap)
|
||||
(+ area-y-min gap) (- dc-y-max gap)))
|
||||
|
||||
(define/public (draw-legend legend-entries) (draw-legend* legend-entries))
|
||||
(define render-list empty)
|
||||
(define (add-shape! shape) (set! render-list (cons shape render-list)))
|
||||
|
||||
(define (draw-shapes lst)
|
||||
(for ([s (in-list (depth-sort lst))])
|
||||
(send pd set-alpha (shape-alpha s))
|
||||
(match s
|
||||
; shapes
|
||||
[(shapes alpha center ss) (draw-shapes ss)]
|
||||
; polygon
|
||||
[(polygon alpha center vs normal pen-color pen-width pen-style brush-color brush-style)
|
||||
(define-values (diff spec) (get-light-values center normal))
|
||||
(let ([pen-color (map (λ (v) (+ (* v diff) spec)) pen-color)]
|
||||
[brush-color (map (λ (v) (+ (* v diff) spec)) brush-color)])
|
||||
(send pd set-pen pen-color pen-width pen-style)
|
||||
(send pd set-brush brush-color brush-style)
|
||||
(send pd draw-polygon (map (λ (v) (view->dc v)) vs)))]
|
||||
; line
|
||||
[(line alpha center v1 v2 pen-color pen-width pen-style)
|
||||
(send pd set-pen pen-color pen-width pen-style)
|
||||
(send pd draw-line (view->dc v1) (view->dc v2))]
|
||||
; text
|
||||
[(text alpha center anchor angle str font-size font-family color)
|
||||
(send pd set-font font-size font-family)
|
||||
(send pd set-text-foreground color)
|
||||
(send pd draw-text str (view->dc (rotate/rho center)) anchor angle)]
|
||||
; glyph
|
||||
[(glyph alpha center symbol size pen-color pen-width pen-style brush-color brush-style)
|
||||
(send pd set-pen pen-color pen-width pen-style)
|
||||
(send pd set-brush brush-color brush-style)
|
||||
(send pd draw-glyphs (list (view->dc (rotate/rho center))) symbol size)]
|
||||
; tick glyph
|
||||
[(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)]
|
||||
[_ (error 'draw-shapes "shape not implemented: ~e" s)])))
|
||||
|
||||
(define light (plot->view (vector x-mid y-mid (+ z-max (* 5 z-size)))))
|
||||
(define view-dir (vector 0 -50 0))
|
||||
|
|
@ -670,48 +653,76 @@
|
|||
; put it all together
|
||||
(values (+ ambient-light (* (- 1 ambient-light) diff)) spec))]))
|
||||
|
||||
(define (draw-shapes lst)
|
||||
(for ([s (in-list (depth-sort lst))])
|
||||
(set-alpha (shape-alpha s))
|
||||
(match s
|
||||
; shapes
|
||||
[(shapes alpha center ss) (draw-shapes ss)]
|
||||
; polygon
|
||||
[(polygon alpha center vs normal pen-color pen-width pen-style brush-color brush-style)
|
||||
(define-values (diff spec) (get-light-values center normal))
|
||||
(let ([pen-color (map (λ (v) (+ (* v diff) spec)) pen-color)]
|
||||
[brush-color (map (λ (v) (+ (* v diff) spec)) brush-color)])
|
||||
(set-pen pen-color pen-width pen-style)
|
||||
(set-brush brush-color brush-style)
|
||||
(draw-polygon (map (λ (v) (view->dc v)) vs)))]
|
||||
; line
|
||||
[(line alpha center v1 v2 pen-color pen-width pen-style)
|
||||
(set-pen pen-color pen-width pen-style)
|
||||
(draw-line (view->dc v1) (view->dc v2))]
|
||||
; text
|
||||
[(text alpha center anchor angle str font-size font-family color)
|
||||
(set-font font-size font-family)
|
||||
(set-text-foreground color)
|
||||
(draw-text str (view->dc (rotate/rho center)) anchor angle)]
|
||||
; glyph
|
||||
[(glyph alpha center symbol size pen-color pen-width pen-style brush-color brush-style)
|
||||
(set-pen pen-color pen-width pen-style)
|
||||
(set-brush brush-color brush-style)
|
||||
(draw-glyphs (list (view->dc (rotate/rho center))) symbol size)]
|
||||
; tick glyph
|
||||
[(tick-glyph alpha center radius angle pen-color pen-width pen-style)
|
||||
(set-pen pen-color pen-width pen-style)
|
||||
(draw-tick (view->dc (rotate/rho center)) radius angle)]
|
||||
[_ (error 'end-plot "shape not implemented: ~e" s)])))
|
||||
;; ===============================================================================================
|
||||
;; Public drawing control (used by plot3d/dc)
|
||||
|
||||
(define/public (start-plot)
|
||||
(send pd reset-drawing-params)
|
||||
(send pd clear)
|
||||
(set! render-list empty)
|
||||
(draw-labels (get-far-label-params))
|
||||
(draw-ticks (get-far-tick-params))
|
||||
(draw-far-borders))
|
||||
|
||||
(define/public (start-renderer rx-min rx-max ry-min ry-max rz-min rz-max)
|
||||
(send pd reset-drawing-params)
|
||||
(clip-to-bounds rx-min rx-max ry-min ry-max rz-min rz-max))
|
||||
|
||||
(define/public (end-renderers)
|
||||
(draw-shapes render-list)
|
||||
(clip-to-none)
|
||||
(send pd reset-drawing-params)
|
||||
(draw-title)
|
||||
(draw-near-borders)
|
||||
(draw-ticks (get-near-tick-params))
|
||||
(draw-labels (get-near-label-params)))
|
||||
|
||||
(define (draw-angles*)
|
||||
(define angle-str (format " angle = ~a " (number->string (round angle))))
|
||||
(define alt-str (format " altitude = ~a " (number->string (round altitude))))
|
||||
(define-values (angle-width angle-height baseline _angle2) (send pd get-text-extent angle-str))
|
||||
(define-values (alt-width alt-height _alt1 _alt2) (send pd get-text-extent alt-str))
|
||||
|
||||
(define box-x-size (max angle-width alt-width))
|
||||
(define box-y-size (+ angle-height alt-height (* 3 baseline)))
|
||||
(define box-x-min (+ dc-x-min (* 1/2 (- dc-x-size box-x-size))))
|
||||
(define box-y-min (+ dc-y-min (* 1/2 (- dc-y-size box-y-size))))
|
||||
(define box-x-max (+ box-x-min box-x-size))
|
||||
(define box-y-max (+ box-y-min box-y-size))
|
||||
|
||||
(send pd set-alpha 1/2)
|
||||
(send pd set-minor-pen)
|
||||
(send pd set-brush (plot-background) 'solid)
|
||||
(send pd draw-rectangle (vector box-x-min box-y-min) (vector box-x-max box-y-max))
|
||||
|
||||
(send pd set-alpha 1)
|
||||
(send pd draw-text
|
||||
angle-str (vector box-x-min (+ box-y-min baseline))
|
||||
'top-left #:outline? #t)
|
||||
(send pd draw-text
|
||||
alt-str (vector box-x-min (+ box-y-min baseline char-height))
|
||||
'top-left #:outline? #t))
|
||||
|
||||
(define/public (draw-angles) (draw-angles*))
|
||||
|
||||
(define (draw-legend* legend-entries)
|
||||
(define gap (plot-line-width))
|
||||
(send pd draw-legend
|
||||
legend-entries
|
||||
(+ dc-x-min gap) (- dc-x-max gap)
|
||||
(+ area-y-min gap) (- dc-y-max gap)))
|
||||
|
||||
(define/public (draw-legend legend-entries) (draw-legend* legend-entries))
|
||||
|
||||
(define/public (end-plot)
|
||||
(send pd restore-drawing-params))
|
||||
|
||||
;; ===============================================================================================
|
||||
;; Delayed drawing
|
||||
;; Public drawing interface (used by renderers)
|
||||
|
||||
(define render-list empty)
|
||||
(define (add-shape! shape) (set! render-list (cons shape render-list)))
|
||||
(define (draw-render-list) (draw-shapes render-list))
|
||||
(define/public (get-plot-device) pd)
|
||||
|
||||
; drawing parameters
|
||||
;; Drawing parameters
|
||||
|
||||
(define alpha 1)
|
||||
|
||||
|
|
@ -728,26 +739,25 @@
|
|||
(define font-family 'roman)
|
||||
(define text-foreground '(0 0 0))
|
||||
|
||||
;; drawing parameter accessors
|
||||
|
||||
; alpha
|
||||
;; Drawing parameter accessors
|
||||
|
||||
(define/public (put-alpha a) (set! alpha a))
|
||||
(define (get-alpha) alpha)
|
||||
|
||||
; pen
|
||||
|
||||
(define/public (put-pen color width style)
|
||||
(set! pen-color (->pen-color color))
|
||||
(set! pen-width width)
|
||||
(set! pen-style (->pen-style style)))
|
||||
|
||||
(define/public (put-major-pen [style 'solid])
|
||||
(put-pen (plot-foreground) (plot-line-width) style))
|
||||
(define/public (put-minor-pen [style 'solid])
|
||||
(put-pen (plot-foreground) (* 1/2 (plot-line-width)) style))
|
||||
|
||||
(define (get-pen-color) pen-color)
|
||||
(define (get-pen-width) pen-width)
|
||||
(define (get-pen-style) pen-style)
|
||||
|
||||
; brush
|
||||
|
||||
(define/public (put-brush color style)
|
||||
(set! brush-color (->brush-color color))
|
||||
(set! brush-style (->brush-style style)))
|
||||
|
|
@ -755,14 +765,10 @@
|
|||
(define (get-brush-color) brush-color)
|
||||
(define (get-brush-style) brush-style)
|
||||
|
||||
; background color
|
||||
|
||||
(define/public (put-background color)
|
||||
(set! background-color (->brush-color color)))
|
||||
(define (get-background) background-color)
|
||||
|
||||
; font
|
||||
|
||||
(define/public (put-font-size size) (set! font-size size))
|
||||
(define/public (put-font-family family) (set! font-family family))
|
||||
|
||||
|
|
@ -777,46 +783,7 @@
|
|||
(define (get-font-family) font-family)
|
||||
(define (get-text-foreground) text-foreground)
|
||||
|
||||
;; ===============================================================================================
|
||||
;; Subdividing nonlinearly transformed shapes
|
||||
|
||||
(define subdivide-fracs '(3/7 4/7 2/7 5/7 1/7 6/7))
|
||||
|
||||
(define (subdivide-line v1 v2 [depth 10])
|
||||
(let/ec return
|
||||
(when (zero? depth) (return (list v1 v2)))
|
||||
|
||||
(define dc-v1 (plot->dc v1))
|
||||
(define dc-v2 (plot->dc v2))
|
||||
(define dc-dv (v- dc-v2 dc-v1))
|
||||
(when ((vmag dc-dv) . <= . 3)
|
||||
(return (list v1 v2)))
|
||||
|
||||
(define dv (v- v2 v1))
|
||||
(define-values (max-area vc)
|
||||
(for/fold ([max-area 0] [vc v1]) ([frac (in-list subdivide-fracs)])
|
||||
(define test-vc (v+ (v* dv frac) v1))
|
||||
(define test-area (abs (vcross2 dc-dv (v- (plot->dc test-vc) dc-v1))))
|
||||
(cond [(test-area . > . max-area) (values test-area test-vc)]
|
||||
[else (values max-area vc)])))
|
||||
(when (max-area . <= . 3) (return (list v1 v2)))
|
||||
|
||||
;(plot3d-subdivisions (+ (plot3d-subdivisions) 1))
|
||||
(append (subdivide-line v1 vc (- depth 1))
|
||||
(rest (subdivide-line vc v2 (- depth 1))))))
|
||||
|
||||
(define (subdivide-lines vs)
|
||||
(append
|
||||
(append*
|
||||
(for/list ([v1 (in-list vs)] [v2 (in-list (rest vs))])
|
||||
(define line-vs (subdivide-line v1 v2))
|
||||
(take line-vs (sub1 (length line-vs)))))
|
||||
(list (last vs))))
|
||||
|
||||
(define (subdivide-polygon vs)
|
||||
(subdivide-lines (cons (last vs) vs)))
|
||||
|
||||
; shapes
|
||||
;; Drawing shapes
|
||||
|
||||
(define/public (put-line v1 v2 [c (vcenter (list v1 v2))])
|
||||
(let/ec return
|
||||
|
|
@ -835,7 +802,7 @@
|
|||
(add-shape! (line alpha (plot->view/no-rho c) (plot->view v1) (plot->view v2)
|
||||
pen-color pen-width pen-style))]
|
||||
[else
|
||||
(define vs (map plot->view (subdivide-line v1 v2)))
|
||||
(define vs (map plot->view (subdivide-line plot->dc* v1 v2)))
|
||||
(for ([v1 (in-list vs)] [v2 (in-list (rest vs))])
|
||||
(add-shape! (line alpha (plot->view/no-rho c) v1 v2
|
||||
pen-color pen-width pen-style)))]))))
|
||||
|
|
@ -857,7 +824,7 @@
|
|||
clip-y-min clip-y-max
|
||||
clip-z-min clip-z-max)
|
||||
vs)]
|
||||
[vs (map plot->view (if identity-transforms? vs (subdivide-polygon vs)))])
|
||||
[vs (map plot->view (if identity-transforms? vs (subdivide-polygon plot->dc* vs)))])
|
||||
(when (empty? vs) (return lst))
|
||||
(cons (polygon (get-alpha) (plot->view/no-rho c) vs norm
|
||||
(get-pen-color) (get-pen-width) (get-pen-style)
|
||||
|
|
|
|||
|
|
@ -173,7 +173,7 @@
|
|||
(define ((polar3d-render-proc f g samples color line-color line-width line-style alpha label) area)
|
||||
(define-values (x-min x-max y-min y-max z-min z-max) (send area get-bounds))
|
||||
(match-define (3d-sample xs ys zs dsss d-min d-max)
|
||||
(f x-min x-max (animated-samples samples)
|
||||
(g x-min x-max (animated-samples samples)
|
||||
y-min y-max (animated-samples samples)
|
||||
z-min z-max (animated-samples samples)))
|
||||
|
||||
|
|
|
|||
|
|
@ -95,7 +95,7 @@
|
|||
(send area start-renderer rx-min rx-max ry-min ry-max rz-min rz-max)
|
||||
(if render-proc (render-proc area) empty))))
|
||||
|
||||
(send area end-plot)
|
||||
(send area end-renderers)
|
||||
|
||||
(when (and (not (empty? legend-entries))
|
||||
(or (not (plot-animating?))
|
||||
|
|
@ -104,7 +104,7 @@
|
|||
|
||||
(when (plot-animating?) (send area draw-angles))
|
||||
|
||||
(send area restore-drawing-params)))
|
||||
(send area end-plot)))
|
||||
|
||||
;; ===================================================================================================
|
||||
;; Plot to various other backends
|
||||
|
|
|
|||
|
|
@ -12,8 +12,8 @@
|
|||
(define ((surface3d-render-proc f samples color style line-color line-width line-style alpha label)
|
||||
area)
|
||||
(define-values (x-min x-max y-min y-max z-min z-max) (send area get-bounds))
|
||||
(match-define (list xs ys zss) (f x-min x-max (animated-samples samples)
|
||||
y-min y-max (animated-samples samples)))
|
||||
(match-define (2d-sample xs ys zss fz-min fz-max) (f x-min x-max (animated-samples samples)
|
||||
y-min y-max (animated-samples samples)))
|
||||
|
||||
(send area put-alpha alpha)
|
||||
(send area put-brush color style)
|
||||
|
|
|
|||
|
|
@ -134,7 +134,8 @@
|
|||
[plot-z-far-label "z far axis"]
|
||||
[plot-z-far-ticks (currency-ticks)]
|
||||
[plot-z-far-max-ticks 5])
|
||||
(plot3d (surface3d (λ (x y) (+ (sin x) (cos y))) -2 2 -2 2 #:alpha 1/2)))
|
||||
(plot3d (surface3d (λ (x y) (+ (sin x) (cos y))) -2 2 -2 2 #:alpha 1/2)
|
||||
#:angle 60 #:altitude 35))
|
||||
|
||||
(parameterize ([plot-title "Saddle"]
|
||||
[plot-x-axis? #f]
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user