68e005fb2c
Also, use keywords for `make-pen' and `make-brush'. Adding `make-pen' and `make-color' creates many conflicts among teaching libraries, such as `2htdp/image'. These are easy to fix up in the tree, but adding such obvious names to `racket/draw' may create other compatibility problems, so we might have to reconsider the names. In consultation with Asumu.
581 lines
24 KiB
Racket
581 lines
24 KiB
Racket
#lang racket/base
|
|
|
|
;; Extra drawing, font, color and style functions.
|
|
|
|
(require racket/draw racket/class racket/match racket/list racket/contract racket/math racket/flonum
|
|
unstable/latent-contract/defthing
|
|
"math.rkt"
|
|
"utils.rkt"
|
|
"contract.rkt"
|
|
"sample.rkt")
|
|
|
|
(provide (all-defined-out))
|
|
|
|
;; ===================================================================================================
|
|
;; Drawing text rotated around an anchor point
|
|
|
|
(define sin45 (/ 1 (sqrt 2)))
|
|
|
|
(define (draw-text/anchor dc str x y [anchor 'top-left] [angle 0] [dist 0])
|
|
(define-values (width height _1 _2) (send dc get-text-extent str #f #t 0))
|
|
(let ([dist (case anchor
|
|
[(top-left bottom-left top-right bottom-right) (* sin45 dist)]
|
|
[else dist])])
|
|
(define dx (case anchor
|
|
[(top-left left bottom-left) (- dist)]
|
|
[(top center bottom) (* 1/2 width)]
|
|
[(top-right right bottom-right) (+ width dist)]
|
|
[else (raise-type-error 'draw-text/anchor "anchor/c" anchor)]))
|
|
(define dy (case anchor
|
|
[(top-left top top-right) (- dist)]
|
|
[(left center right) (* 1/2 height)]
|
|
[(bottom-left bottom bottom-right) (+ height dist)]))
|
|
(define rdx (+ (* (sin angle) dy) (* (cos angle) dx)))
|
|
(define rdy (- (* (cos angle) dy) (* (sin angle) dx)))
|
|
|
|
(send dc draw-text str (- x rdx) (- y rdy) #t 0 angle)))
|
|
|
|
(define (get-text-corners/anchor dc str x y [anchor 'top-left] [angle 0] [dist 0])
|
|
(define-values (width height _1 _2) (send dc get-text-extent str #f #t 0))
|
|
(let ([dist (case anchor
|
|
[(top-left bottom-left top-right bottom-right) (* sin45 dist)]
|
|
[else dist])])
|
|
(define dxs (case anchor
|
|
[(top-left left bottom-left) (list (- dist) (- width dist))]
|
|
[(top center bottom) (list (* -1/2 width) (* 1/2 width))]
|
|
[(top-right right bottom-right) (list (- dist width) dist)]
|
|
[else (raise-type-error 'get-text-corners/anchor "anchor/c" anchor)]))
|
|
(define dys (case anchor
|
|
[(top-left top top-right) (list (- dist) (- height dist))]
|
|
[(left center right) (list (* -1/2 height) (* 1/2 width))]
|
|
[(bottom-left bottom bottom-right) (list (- dist height) dist)]))
|
|
|
|
(for*/list ([dx (in-list dxs)] [dy (in-list dys)])
|
|
(define rdx (+ (* (sin angle) dy) (* (cos angle) dx)))
|
|
(define rdy (- (* (cos angle) dy) (* (sin angle) dx)))
|
|
(vector (+ x rdx) (+ y rdy)))))
|
|
|
|
;; ===================================================================================================
|
|
;; Draw paramter normalization
|
|
|
|
(define (real->font-size size)
|
|
(define i (inexact->exact (round size)))
|
|
(min (max i 1) 255))
|
|
|
|
(define (real->color-byte f)
|
|
(cond [(rational? f) (define i (inexact->exact (floor f)))
|
|
(min (max i 0) 255)]
|
|
[(eqv? f +inf.0) 255]
|
|
[else 0]))
|
|
|
|
;; Returns an immutable instance of color%. Immutable colors are faster because they don't have to
|
|
;; have immutable copies made when they're used in a dc.
|
|
(define (make-color% r g b)
|
|
(make-color r g b))
|
|
|
|
;; Returns an immutable instance of pen%. Same reasoning as for make-color%.
|
|
(define (make-pen% r g b w s)
|
|
(make-pen #:color (make-color% r g b) #:width w #:style s))
|
|
|
|
;; Returns an immutable instance of brush%. Same reasoning as for make-color%.
|
|
(define (make-brush% r g b s)
|
|
(make-brush #:color (make-color% r g b) #:style s))
|
|
|
|
(define (color%? c) (is-a? c color%))
|
|
|
|
(defproc (->color [c color/c]) (list/c real? real? real?)
|
|
(match c
|
|
[(? color%?) (list (send c red) (send c green) (send c blue))]
|
|
[(? string?) (define color (send the-color-database find-color c))
|
|
(when (not color) (error 'decode-color "unknown color name ~e" c))
|
|
(->color color)]
|
|
[(list (? real?) (? real?) (? real?)) c]
|
|
[(? symbol?) (->color (symbol->string c))]
|
|
[_ (error '->color "unable to convert to color triple: ~e" c)]))
|
|
|
|
(define (color->color% c)
|
|
(match-define (list r g b) c)
|
|
(make-color% (real->color-byte r) (real->color-byte g) (real->color-byte b)))
|
|
|
|
(define (rgb->hsv rgb)
|
|
(match-define (list r g b) (map (λ (x) (/ x 255)) rgb))
|
|
(define mx (max r g b))
|
|
(define mn (min r g b))
|
|
(define c (- mx mn))
|
|
(define h (* 60 (cond [(zero? c) 0]
|
|
[(= mx r) (/ (- g b) c)]
|
|
[(= mx g) (+ (/ (- b r) c) 2)]
|
|
[(= mx b) (+ (/ (- r g) c) 4)])))
|
|
(list (if (h . < . 0) (+ h 360) h)
|
|
(if (zero? mx) 0 (/ c mx))
|
|
mx))
|
|
|
|
(define (hsv->rgb hsv)
|
|
(match-define (list h s v) hsv)
|
|
(define c (* v s))
|
|
(let ([h (/ (real-modulo h 360) 60)])
|
|
(define x (* c (- 1 (abs (- (real-modulo h 2) 1)))))
|
|
(define-values (r g b)
|
|
(cond [(and (0 . <= . h) (h . < . 1)) (values c x 0)]
|
|
[(and (1 . <= . h) (h . < . 2)) (values x c 0)]
|
|
[(and (2 . <= . h) (h . < . 3)) (values 0 c x)]
|
|
[(and (3 . <= . h) (h . < . 4)) (values 0 x c)]
|
|
[(and (4 . <= . h) (h . < . 5)) (values x 0 c)]
|
|
[(and (5 . <= . h) (h . < . 6)) (values c 0 x)]))
|
|
(define m (- v c))
|
|
(list (* 255 (+ r m))
|
|
(* 255 (+ g m))
|
|
(* 255 (+ b m)))))
|
|
|
|
(define (integer->hue n)
|
|
(let ([n (abs n)])
|
|
(define i (+ (case (remainder n 6) [(0) 0] [(1) 2] [(2) 4] [(3) 1] [(4) 3] [(5) 5])
|
|
(* 6 3 (quotient n 6))))
|
|
(remainder (* i 59) 360)))
|
|
|
|
(define (integer->gray-value n)
|
|
(* 1/7 (remainder (abs n) 8)))
|
|
|
|
(define (integer->pen-color n)
|
|
(define h (integer->hue n))
|
|
(hsv->rgb (list (- h (* 25 (sin (* (/ h 360) (* 3 pi)))))
|
|
1
|
|
(+ 1/2 (* 1/6 (sin (* (/ h 360) (* 3 pi))))))))
|
|
|
|
(define (integer->brush-color n)
|
|
(define h (integer->hue n))
|
|
(hsv->rgb (list (let ([y (* (/ (- (sqrt (+ (/ h 60) 2)) (sqrt 2))
|
|
(- (sqrt 8) (sqrt 2)))
|
|
6)])
|
|
(- h (* 15 (sin (* (/ y 6) (* 3 pi))))))
|
|
(+ 3/16 (* 3/32 (sin (* (/ h 360) (* 2 pi)))))
|
|
1)))
|
|
|
|
(define (integer->gray-pen-color i)
|
|
(make-list 3 (* 128 (expt (integer->gray-value i) 3/4))))
|
|
|
|
(define (integer->gray-brush-color i)
|
|
(make-list 3 (+ 127 (* 128 (expt (- 1 (integer->gray-value i)) 3/4)))))
|
|
|
|
(define pen-colors
|
|
(for/vector ([color (in-list (append (list (integer->gray-pen-color 0))
|
|
(build-list 120 integer->pen-color)
|
|
(build-list 7 (λ (n) (integer->gray-pen-color (- 7 n))))))])
|
|
(map real->color-byte color)))
|
|
|
|
(define brush-colors
|
|
(for/vector ([color (in-list (append (list (integer->gray-brush-color 0))
|
|
(build-list 120 integer->brush-color)
|
|
(build-list 7 (λ (n) (integer->gray-brush-color (- 7 n))))))])
|
|
(map real->color-byte color)))
|
|
|
|
(defproc (->pen-color [c plot-color/c]) (list/c real? real? real?)
|
|
(cond [(exact-integer? c) (vector-ref pen-colors (modulo c 128))]
|
|
[else (->color c)]))
|
|
|
|
(defproc (->brush-color [c plot-color/c]) (list/c real? real? real?)
|
|
(cond [(exact-integer? c) (vector-ref brush-colors (modulo c 128))]
|
|
[else (->color c)]))
|
|
|
|
(defproc (->pen-style [s plot-pen-style/c]) symbol?
|
|
(cond [(exact-integer? s) (case (remainder (abs s) 5)
|
|
[(0) 'solid]
|
|
[(1) 'dot]
|
|
[(2) 'long-dash]
|
|
[(3) 'short-dash]
|
|
[(4) 'dot-dash])]
|
|
[(symbol? s) s]
|
|
[else (raise-type-error '->pen-style "symbol or integer" s)]))
|
|
|
|
(defproc (->brush-style [s plot-brush-style/c]) symbol?
|
|
(cond [(exact-integer? s) (case (remainder (abs s) 7)
|
|
[(0) 'solid]
|
|
[(1) 'bdiagonal-hatch]
|
|
[(2) 'fdiagonal-hatch]
|
|
[(3) 'crossdiag-hatch]
|
|
[(4) 'horizontal-hatch]
|
|
[(5) 'vertical-hatch]
|
|
[(6) 'cross-hatch])]
|
|
[(symbol? s) s]
|
|
[else (raise-type-error '->brush-style "symbol or integer" s)]))
|
|
|
|
;; ===================================================================================================
|
|
;; Color functions
|
|
|
|
(defproc (color-seq [c1 color/c] [c2 color/c] [num exact-nonnegative-integer?]
|
|
[#:start? start? boolean? #t]
|
|
[#:end? end? boolean? #t]) (listof (list/c real? real? real?))
|
|
(match-define (list r1 g1 b1) (->color c1))
|
|
(match-define (list r2 g2 b2) (->color c2))
|
|
(define rs (linear-seq r1 r2 num #:start? start? #:end? end?))
|
|
(define gs (linear-seq g1 g2 num #:start? start? #:end? end?))
|
|
(define bs (linear-seq b1 b2 num #:start? start? #:end? end?))
|
|
(map list rs gs bs))
|
|
|
|
(defproc (color-seq* [colors (listof color/c)] [num exact-nonnegative-integer?]
|
|
[#:start? start? boolean? #t]
|
|
[#:end? end? boolean? #t]) (listof (list/c real? real? real?))
|
|
(when (empty? colors) (raise-type-error 'color-seq* "nonempty (listof plot-color/c)" colors))
|
|
(match-define (list (list rs gs bs) ...) (map ->color colors))
|
|
(let ([rs (linear-seq* rs num #:start? start? #:end? end?)]
|
|
[gs (linear-seq* gs num #:start? start? #:end? end?)]
|
|
[bs (linear-seq* bs num #:start? start? #:end? end?)])
|
|
(map list rs gs bs)))
|
|
|
|
;; Returns an alpha value b such that, if
|
|
(defproc (alpha-expt [a (real-in 0 1)] [n (>/c 0)]) real?
|
|
(- 1 (expt (- 1 a) n)))
|
|
|
|
;; ===================================================================================================
|
|
;; 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)))
|
|
|
|
;; ===================================================================================================
|
|
;; Fixpoint margin computation
|
|
|
|
;; In calculating margins in 2d-plot-area% and 3d-plot-area%, we have a mutual dependence problem:
|
|
;; 1. We can't set the margins without knowing where the ticks and axis labels will be drawn.
|
|
;; 2. We can't determine the tick and label angles (and thus their vertexes) without the margins.
|
|
|
|
;; The margins could be solved exactly using algebra and trigonometry, but the solutions wouldn't
|
|
;; be robust, as small changes to the layout algorithms would invalidate them.
|
|
|
|
;; So we use a fixpoint solution: iterate
|
|
;; 1. Getting tick and label vertexes ('get-vs' below); then
|
|
;; 2. Calculating new margins by how far off the dc the vertexes would be.
|
|
|
|
;; As long as this process is monotone and bounded, the distance off the dc is zero in the limit. In
|
|
;; practice, only a few iterations drives this distance to less than 1 drawing unit.
|
|
|
|
(define (margin-fixpoint x-min x-max y-min y-max
|
|
init-left init-right init-top init-bottom
|
|
get-vs)
|
|
(let/ec return
|
|
(for/fold ([left init-left] [right init-right] [top init-top] [bottom init-bottom]
|
|
) ([i (in-range 3)])
|
|
(match-define (list (vector xs ys) ...) (get-vs left right top bottom))
|
|
(define param-x-min (apply min x-min xs))
|
|
(define param-x-max (apply max (sub1 x-max) xs))
|
|
(define param-y-min (apply min y-min ys))
|
|
(define param-y-max (apply max (sub1 y-max) ys))
|
|
|
|
(define new-left (round (+ left (- x-min param-x-min))))
|
|
(define new-right (round (- right (- (sub1 x-max) param-x-max))))
|
|
(define new-top (round (+ top (- y-min param-y-min))))
|
|
(define new-bottom (round (- bottom (- (sub1 y-max) param-y-max))))
|
|
|
|
;; Not enough space?
|
|
(define area-x-min (+ x-min new-left))
|
|
(define area-x-max (- x-max new-right))
|
|
(define area-y-min (+ y-min new-top))
|
|
(define area-y-max (- y-max new-bottom))
|
|
(when (or (area-x-min . > . area-x-max)
|
|
(area-y-min . > . area-y-max))
|
|
(return init-left init-right init-top init-bottom))
|
|
|
|
;; Early out: if the margins haven't changed much, another iteration won't change them more
|
|
;; (hopefully)
|
|
(when (and (= left new-left) (= right new-right)
|
|
(= top new-top) (= bottom new-bottom))
|
|
(return new-left new-right new-top new-bottom))
|
|
|
|
(values new-left new-right new-top new-bottom))))
|
|
|
|
;; ===================================================================================================
|
|
;; Null device context (used for speed testing)
|
|
|
|
(define-syntax-rule (define-public-stubs val name ...)
|
|
(begin (define/public (name . args) val) ...))
|
|
|
|
(define null-dc%
|
|
(class* object% (dc<%>)
|
|
(define color (make-object color% 0 0 0))
|
|
(define font (make-object font% 8 'default))
|
|
(define pen (make-object pen% color 1 'solid))
|
|
(define brush (make-object brush% color 'solid))
|
|
(define matrix (vector 1 0 0 0 1 0))
|
|
(define transformation (vector matrix 0 0 0 0 0))
|
|
(define-public-stubs transformation get-transformation)
|
|
(define-public-stubs matrix get-initial-matrix)
|
|
(define-public-stubs 'solid get-text-mode)
|
|
(define-public-stubs color get-text-foreground get-text-background get-background)
|
|
(define-public-stubs #t get-smoothing ok? start-doc glyph-exists?)
|
|
(define-public-stubs #f get-clipping-region get-gl-context)
|
|
(define-public-stubs 0 get-rotation get-char-height get-char-width)
|
|
(define-public-stubs (values 0 0) get-origin get-scale get-size)
|
|
(define-public-stubs font get-font)
|
|
(define-public-stubs pen get-pen)
|
|
(define-public-stubs brush get-brush)
|
|
(define-public-stubs 1 get-alpha)
|
|
(define-public-stubs (values 1 1) get-device-scale)
|
|
(define-public-stubs (values 0 0 0 0) get-text-extent)
|
|
(define-public-stubs (void)
|
|
flush suspend-flush resume-flush
|
|
start-page end-page end-doc
|
|
set-transformation
|
|
set-text-mode
|
|
set-smoothing
|
|
set-text-foreground
|
|
set-text-background
|
|
set-scale
|
|
set-rotation
|
|
set-origin
|
|
set-initial-matrix
|
|
set-font
|
|
set-clipping-region
|
|
set-clipping-rect
|
|
set-brush
|
|
set-pen
|
|
set-alpha
|
|
set-background
|
|
draw-text
|
|
draw-spline
|
|
draw-line
|
|
draw-lines
|
|
draw-ellipse
|
|
draw-rectangle
|
|
draw-rounded-rectangle
|
|
draw-polygon
|
|
draw-point
|
|
draw-path
|
|
draw-bitmap-section
|
|
draw-bitmap
|
|
draw-arc
|
|
copy clear erase
|
|
cache-font-metrics-key
|
|
transform rotate scale translate
|
|
try-color)
|
|
(super-new)))
|
|
|
|
;; ===================================================================================================
|
|
;; Visible faces of a 3D rectangle
|
|
|
|
(define (rect-visible-faces r theta)
|
|
(match-define (vector (ivl x-min x-max) (ivl y-min y-max) (ivl z-min z-max)) r)
|
|
(list
|
|
;; Top (z-max) face
|
|
(list (vector 0.0 0.0 1.0)
|
|
(vector x-min y-min z-max) (vector x-max y-min z-max)
|
|
(vector x-max y-max z-max) (vector x-min y-max z-max))
|
|
;; Front (y-min) face
|
|
(if ((cos theta) . > . 0.0)
|
|
(list (vector 0.0 -1.0 0.0)
|
|
(vector x-min y-min z-min) (vector x-max y-min z-min)
|
|
(vector x-max y-min z-max) (vector x-min y-min z-max))
|
|
empty)
|
|
;; Back (y-max) face
|
|
(if ((cos theta) . < . 0.0)
|
|
(list (vector 0.0 1.0 0.0)
|
|
(vector x-min y-max z-min) (vector x-max y-max z-min)
|
|
(vector x-max y-max z-max) (vector x-min y-max z-max))
|
|
empty)
|
|
;; Left (x-min) face
|
|
(if ((sin theta) . > . 0.0)
|
|
(list (vector -1.0 0.0 0.0)
|
|
(vector x-min y-min z-min) (vector x-min y-max z-min)
|
|
(vector x-min y-max z-max) (vector x-min y-min z-max))
|
|
empty)
|
|
;; Right (x-max) face
|
|
(if ((sin theta) . < . 0.0)
|
|
(list (vector 1.0 0.0 0.0)
|
|
(vector x-max y-min z-min) (vector x-max y-max z-min)
|
|
(vector x-max y-max z-max) (vector x-max y-min z-max))
|
|
empty)))
|
|
|
|
;; ===================================================================================================
|
|
;; Origin-neutral pen styles
|
|
|
|
(struct pen-style (length ps) #:transparent)
|
|
|
|
(define (make-pen-style diff-ps)
|
|
(let* ([diff-ps (map exact->inexact diff-ps)]
|
|
[diff-ps (if (even? (length diff-ps)) diff-ps (append diff-ps diff-ps))])
|
|
(define ps (map exact->inexact (cumulative-sum diff-ps)))
|
|
(define len (last ps))
|
|
(pen-style len ps)))
|
|
|
|
(define long-dash-pen-style (make-pen-style '(5 4)))
|
|
(define short-dash-pen-style (make-pen-style '(3 2)))
|
|
(define dot-pen-style (make-pen-style '(1 2)))
|
|
(define dot-dash-pen-style (make-pen-style '(1 3 4 3)))
|
|
|
|
(define (scale-pen-style sty scale)
|
|
(let ([scale (exact->inexact scale)])
|
|
(match-define (pen-style len ps) sty)
|
|
(pen-style (fl* scale len) (map (λ (p) (fl* scale p)) ps))))
|
|
|
|
(define (cons-exact->inexact v)
|
|
(match-define (cons x1 y1) v)
|
|
(cons (exact->inexact x1) (exact->inexact y1)))
|
|
|
|
(define (cons=? v1 v2)
|
|
(match-define (cons x1 y1) v1)
|
|
(match-define (cons x2 y2) v2)
|
|
(and (fl= x1 x2) (fl= y1 y2)))
|
|
|
|
(define (segment-reverse seg)
|
|
(reverse (map reverse seg)))
|
|
|
|
(define (segment-join s1 s2)
|
|
(match-let ([(list s1 ... a) s1]
|
|
[(list b s2 ...) s2])
|
|
(append s1 (list (append a (rest b))) s2)))
|
|
|
|
(define (join-styled-segments segments)
|
|
(let ([segments (filter (compose not empty?) segments)])
|
|
(if (empty? segments)
|
|
empty
|
|
(match-let ([(cons current-segment segments) segments])
|
|
(let loop ([current-segment current-segment] [segments segments])
|
|
(cond [(empty? segments) (list current-segment)]
|
|
[else
|
|
(define lst (last (last current-segment)))
|
|
(match-let ([(cons segment segments) segments])
|
|
(define fst (first (first segment)))
|
|
(cond [(cons=? lst fst) (loop (segment-join current-segment segment) segments)]
|
|
[else (cons current-segment (loop segment segments))]))]))))))
|
|
|
|
(define (styled-segment* x1 y1 x2 y2 sty pair)
|
|
(match-define (pen-style len (cons p rest-ps)) sty)
|
|
(define start-x (fl* len (flfloor (fl/ x1 len))))
|
|
(define m (fl/ (fl- y2 y1) (fl- x2 x1)))
|
|
(define b (fl- y1 (fl* m x1)))
|
|
(let loop ([xa start-x] [base-x 0.0] [ps rest-ps] [on? #t] [res empty])
|
|
(let-values ([(base-x ps) (cond [(empty? ps) (values (fl+ base-x len) rest-ps)]
|
|
[else (values base-x ps)])])
|
|
(cond [(xa . fl>= . x2) (reverse res)]
|
|
[else
|
|
(match-let ([(cons p ps) ps])
|
|
(define xb (fl+ start-x (fl+ p base-x)))
|
|
(cond [(and on? (xb . fl>= . x1))
|
|
(define v (let ([xa (flmax x1 xa)]
|
|
[xb (flmin x2 xb)])
|
|
(define ya (if (fl= x1 xa) y1 (fl+ (fl* m xa) b)))
|
|
(define yb (if (fl= x2 xb) y2 (fl+ (fl* m xb) b)))
|
|
(list (pair xa ya) (pair xb yb))))
|
|
(loop xb base-x ps (not on?) (cons v res))]
|
|
[else (loop xb base-x ps (not on?) res)]))]))))
|
|
|
|
(define (styled-segment x1 y1 x2 y2 sty)
|
|
(define dx (flabs (fl- x2 x1)))
|
|
(define dy (flabs (fl- y2 y1)))
|
|
(cond [(and (fl= dx 0.0) (fl= dy 0.0)) (list (list (cons x1 y1) (cons x2 y2)))]
|
|
[(dx . > . dy)
|
|
(define reverse? (x1 . fl> . x2))
|
|
(let-values ([(x1 y1) (if reverse? (values x2 y2) (values x1 y1))]
|
|
[(x2 y2) (if reverse? (values x1 y1) (values x2 y2))])
|
|
(define segment (styled-segment* x1 y1 x2 y2 sty cons))
|
|
(if reverse? (segment-reverse segment) segment))]
|
|
[else
|
|
(define reverse? (y1 . fl> . y2))
|
|
(let-values ([(x1 y1) (if reverse? (values x2 y2) (values x1 y1))]
|
|
[(x2 y2) (if reverse? (values x1 y1) (values x2 y2))])
|
|
(define segment (styled-segment* y1 x1 y2 x2 sty (λ (y x) (cons x y))))
|
|
(if reverse? (segment-reverse segment) segment))]))
|
|
|
|
(define (symbol->style name style-sym)
|
|
(case style-sym
|
|
[(long-dash) long-dash-pen-style]
|
|
[(short-dash) short-dash-pen-style]
|
|
[(dot) dot-pen-style]
|
|
[(dot-dash) dot-dash-pen-style]
|
|
[else (error name "unknown pen style ~e" style-sym)]))
|
|
|
|
(define (draw-line/pen-style dc x1 y1 x2 y2 style-sym)
|
|
(case style-sym
|
|
[(transparent) (void)]
|
|
[(solid) (send dc draw-line x1 y1 x2 y2)]
|
|
[else
|
|
(let ([x1 (exact->inexact x1)]
|
|
[y1 (exact->inexact y1)]
|
|
[x2 (exact->inexact x2)]
|
|
[y2 (exact->inexact y2)])
|
|
(define sty (symbol->style 'draw-line style-sym))
|
|
(define pen (send dc get-pen))
|
|
(define scale (flmax 1.0 (exact->inexact (send pen get-width))))
|
|
(define vss (styled-segment x1 y1 x2 y2 (scale-pen-style sty scale)))
|
|
(for ([vs (in-list vss)] #:when (not (empty? vs)))
|
|
(match-define (list (cons xa ya) (cons xb yb)) vs)
|
|
(send dc draw-line xa ya xb yb)))]))
|
|
|
|
(define (draw-lines* dc vs sty)
|
|
(define vss
|
|
(append* (join-styled-segments
|
|
(for/list ([v1 (in-list vs)] [v2 (in-list (rest vs))])
|
|
(match-define (cons x1 y1) v1)
|
|
(match-define (cons x2 y2) v2)
|
|
(styled-segment x1 y1 x2 y2 sty)))))
|
|
(for ([vs (in-list vss)])
|
|
(match vs
|
|
[(list (cons x1 y1) (cons x2 y2)) (send dc draw-line x1 y1 x2 y2)]
|
|
[_ (send dc draw-lines vs)])))
|
|
|
|
(define (draw-lines/pen-style dc vs style-sym)
|
|
(cond [(or (empty? vs) (eq? style-sym 'transparent)) (void)]
|
|
[else
|
|
(let ([vs (map cons-exact->inexact vs)])
|
|
(cond [(eq? style-sym 'solid) (send dc draw-lines vs)]
|
|
[else
|
|
(define pen (send dc get-pen))
|
|
(define scale (flmax 1.0 (exact->inexact (send pen get-width))))
|
|
(define sty (scale-pen-style (symbol->style 'draw-lines style-sym) scale))
|
|
(draw-lines* dc vs sty)]))]))
|
|
|
|
;; ===================================================================================================
|
|
;; Drawing a bitmap using 2x supersampling
|
|
|
|
(define (draw-bitmap/supersampling draw width height)
|
|
(define bm2 (make-bitmap (* 2 width) (* 2 height)))
|
|
(define dc2 (make-object bitmap-dc% bm2))
|
|
(send dc2 set-scale 2 2)
|
|
(draw dc2)
|
|
|
|
(define bm (make-bitmap width height))
|
|
(define dc (make-object bitmap-dc% bm))
|
|
(send dc set-scale 1/2 1/2)
|
|
(send dc set-smoothing 'smoothed)
|
|
(send dc draw-bitmap bm2 0 0)
|
|
bm)
|
|
|
|
(define (draw-bitmap draw width height)
|
|
(define bm (make-bitmap width height))
|
|
(define dc (make-object bitmap-dc% bm))
|
|
(draw dc)
|
|
bm)
|