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

Little fixes and improvements

Browse Source
This commit is contained in:
Neil Toronto 2011-11-13 15:08:47 -07:00
parent a710cbb7fe
commit 20e09c9f7f
10 changed files with 53 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -58,6 +58,25 @@
(define i (inexact->exact (floor f)))
(min (max i 0) 255))
;; 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)
(define color (make-object color% r g b))
(send color set-immutable)
color)
;; Returns an immutable instance of pen%. Same reasoning as for make-color%.
(define (make-pen% r g b w s)
(define pen (make-object pen% (make-color% r g b) w s))
(send pen set-immutable)
pen)
;; Returns an immutable instance of brush%. Same reasoning as for make-color%.
(define (make-brush% r g b s)
(define brush (make-object brush% (make-color% r g b) s))
(send brush set-immutable)
brush)
(define (color%? c) (is-a? c color%))
(defproc (->color [c color/c]) (list/c real? real? real?)
@ -72,7 +91,7 @@
(define (color->color% c)
(match-define (list r g b) c)
(make-object color% (real->color-byte r) (real->color-byte g) (real->color-byte b)))
(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))

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

@ -168,9 +168,9 @@
(send pd set-alpha 1)
(send pd draw-glyphs (list (rect-center rect)) 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?
(defproc (arrow-legend-entry [label string?] [color plot-color/c]
[line-width (>=/c 0)] [line-style plot-pen-style/c]
) legend-entry?
(legend-entry label (λ (pd rect)
(match-define (vector (ivl x-min x-max) y-ivl) rect)
(send pd set-pen color line-width line-style)

30
collects/plot/common/plot-device.rkt
View File

@ -135,24 +135,20 @@
;; Pen, brush, alpha parameters
(define pen-hash (make-hash))
(define transparent-pen (make-pen% 0 0 0 1 'transparent))
(define pen-color (plot-foreground))
(define pen-width (plot-line-width))
(define pen-style 'solid)
;; Sets the pen, using a hash table to avoid making duplicate objects. At time of writing (and for
;; the forseeable future) this is much faster than using a pen-list%, because it doesn't have to
;; synchronize access to be thread-safe.
;; synchronize access. It's also not thread-safe.
(define/public (set-pen color width style)
(match-define (list (app real->color-byte r) (app real->color-byte g) (app real->color-byte b))
(->pen-color color))
(set! pen-color color)
(set! pen-width width)
(set! pen-style (->pen-style style))
(let ([style (if (eq? style 'transparent) 'transparent 'solid)])
(send dc set-pen
(hash-ref! pen-hash (vector r g b width style)
(λ () (make-object pen% (make-object color% r g b) width style))))))
(send dc set-pen (hash-ref! pen-hash (vector r g b width style)
(λ () (make-pen% r g b width style))))))
;; Sets the pen used to draw major ticks.
(define/public (set-major-pen [style 'solid])
@ -164,19 +160,13 @@
(define brush-hash (make-hash))
(define brush-color (plot-background))
(define brush-style 'solid)
;; Sets the brush. Same idea as set-pen.
(define/public (set-brush color style)
(match-define (list (app real->color-byte r) (app real->color-byte g) (app real->color-byte b))
(->brush-color color))
(let ([style (->brush-style style)])
(set! brush-color color)
(set! brush-style style)
(send dc set-brush
(hash-ref! brush-hash (vector r g b style)
(λ () (make-object brush% (make-object color% r g b) style))))))
(send dc set-brush (hash-ref! brush-hash (vector r g b style)
(λ () (make-brush% r g b style))))))
(define alpha (plot-foreground-alpha))
@ -275,13 +265,13 @@
(send dc draw-polygon vs 0 0 'winding)
(send dc set-smoothing 'smoothed)]
[else
(define old-pen-style pen-style)
(set-pen pen-color pen-width 'transparent)
(define old-pen (send dc get-pen))
(send dc set-pen transparent-pen)
(send dc set-smoothing 'unsmoothed)
(send dc draw-polygon vs 0 0 'winding)
(send dc set-smoothing 'smoothed)
(set-pen pen-color pen-width old-pen-style)
(draw-lines/pen-style dc (cons (last vs) vs) old-pen-style)]))))
(send dc set-pen old-pen)
(draw-lines/pen-style dc (cons (last vs) vs) pen-style)]))))
(define/public (draw-rect r)
(when (rect-regular? r)

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

@ -13,4 +13,4 @@
rectangle-legend-entry rectangle-legend-entries
interval-legend-entry interval-legend-entries
point-legend-entry
vector-field-legend-entry))
arrow-legend-entry))

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

@ -82,7 +82,7 @@
(vector x y)
(vector (+ x (* mag (cos angle))) (+ y (* mag (sin angle))))))
(cond [label (vector-field-legend-entry label color line-width line-style)]
(cond [label (arrow-legend-entry label color line-width line-style)]
[else empty])]))
(defproc (vector-field

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

@ -88,7 +88,7 @@
[mag (in-list new-mags)])
(send area put-arrow v (v+ v (v* norm mag))))
(cond [label (vector-field-legend-entry label color line-width line-style)]
(cond [label (arrow-legend-entry label color line-width line-style)]
[else empty])]))
(defproc (vector-field3d

5
collects/plot/scribblings/custom.scrbl
View File

@ -4,6 +4,7 @@
@title[#:tag "custom"]{Custom Plot Elements}
@defmodule*/no-declare[(plot/utils)]
@declare-exporting[plot/utils]
@section{Plot Elements}
@ -64,6 +65,4 @@ Examples: @racket[x-ticks], @racket[y-ticks], @racket[z-ticks], @racket[invisibl
@doc-apply[interval-legend-entry]
@doc-apply[interval-legend-entries]
@doc-apply[point-legend-entry]
@doc-apply[vector-field-legend-entry]
todo: rename vector-field-legend-entry to arrow-legend-entry?
@doc-apply[arrow-legend-entry]

4
collects/plot/scribblings/intro.scrbl
View File

@ -113,13 +113,13 @@ We might say that bounds passed to renderers are @italic{suggestions}, and bound
Here is an example of commanding @(racket plot3d) to override a renderer's bounds. First, consider the plot of a sphere with radius @(racket 1):
@interaction[#:eval plot-eval (plot3d (polar3d (λ (θ ρ) 1) #:line-color "white" #:line-width 1)
@interaction[#:eval plot-eval (plot3d (polar3d (λ (θ ρ) 1) #:color 2 #:line-style 'transparent)
#:altitude 25)]
Passing bounds to @(racket plot3d) that are smaller than [-1..1] × [-1..1] × [-1..1] cuts off the six axial poles:
@interaction[#:eval plot-eval
(plot3d (polar3d (λ (θ ρ) 1) #:line-color "white" #:line-width 1)
(plot3d (polar3d (λ (θ ρ) 1) #:color 2 #:line-style 'transparent)
#:x-min -0.8 #:x-max 0.8
#:y-min -0.8 #:y-max 0.8
#:z-min -0.8 #:z-max 0.8

17
collects/plot/tests/doc-tests.rkt
View File

@ -4,7 +4,8 @@
scribble/manual
scribble/render
scribble/text-render
scribble/decode)
scribble/decode
(for-syntax racket/base racket/syntax))
(define (render-doc doc-part)
(define path (make-temporary-file "racket-doc-~a.txt" #f (current-directory)))
@ -21,11 +22,17 @@
(for ([line (in-list (render-doc doc-part))])
(displayln line)))
(display-doc (plot/dc:doc))
(define-syntax (doc stx)
(syntax-case stx ()
[(_ name) (with-syntax ([name:doc (format-id #'name "~a:doc" #'name)])
(syntax/loc stx
(display-doc (name:doc))))]))
(doc plot/dc)
(newline)
(display-doc (treeof:doc))
(doc treeof)
(newline)
(display-doc (plot-background:doc))
(doc plot-background)
(newline)
(display-doc (known-point-symbols:doc))
(doc known-point-symbols)
(newline)

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

@ -1,6 +1,6 @@
#lang racket
(require plot plot/utils #;racket/flonum)
(require plot plot/utils)
(time
(plot3d (isosurface3d (λ (x y z) (sqrt (+ (sqr x) (sqr y) (sqr z)))) 1