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

Expanded numbered colors to 128

Browse Source
This commit is contained in:
Neil Toronto 2011-11-01 14:15:52 -06:00
parent e90ec4b69f
commit dab5caf67c
9 changed files with 155 additions and 53 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -2,7 +2,8 @@
;; Extra drawing, font, color and style functions.
(require racket/draw racket/class racket/match racket/list racket/contract
(require racket/draw racket/class racket/match racket/list racket/contract racket/math
"math.rkt"
"contract.rkt"
"contract-doc.rkt"
"sample.rkt")
@ -72,6 +73,87 @@
(match-define (list r g b) c)
(make-object 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)]))
#|
(define pen-colors
'#((0 0 0) ; black
(128 0 0) ; red
@ -83,7 +165,7 @@
(160 160 160))) ; gray
(defproc (->pen-color [c plot-color/c]) (list/c real? real? real?)
(cond [(exact-integer? c) (vector-ref pen-colors (remainder (abs c) 8))]
(cond [(exact-integer? c) (vector-ref pen-colors (modulo c 8))]
[else (->color c)]))
(define brush-colors
@ -97,8 +179,9 @@
(212 212 212))) ; gray
(defproc (->brush-color [c plot-color/c]) (list/c real? real? real?)
(cond [(exact-integer? c) (vector-ref brush-colors (remainder (abs c) 8))]
(cond [(exact-integer? c) (vector-ref brush-colors (modulo c 8))]
[else (->color c)]))
|#
(defproc (->pen-style [s plot-pen-style/c]) symbol?
(cond [(exact-integer? s) (case (remainder (abs s) 5)

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

@ -166,7 +166,13 @@
(cond [(not (and (exact-integer? b) (b . >= . 2))) (raise-type-error 'floor-log/base
"exact integer >= 2" 0 b x)]
[(not (and (real? x) (x . > . 0))) (raise-type-error 'floor-log/base "real > 0" 1 b x)]
[else (inexact->exact (ceiling (/ (log (abs x)) (log b))))]))
[else (define y (inexact->exact (ceiling (/ (log x) (log b)))))
(cond [(exact? x)
(let loop ([y y] [x (/ x (expt b y))])
(cond [(x . > . 1) (loop (add1 y) (/ x b))]
[(x . <= . (/ 1 b)) (loop (sub1 y) (* x b))]
[else y]))]
[else y])]))
(defproc (polar->cartesian [θ real?] [r real?]) (vector/c real? real?)
(cond [(not (real? θ)) (raise-type-error 'polar->cartesian "real number" 0 θ r)]

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

@ -19,7 +19,7 @@
;; cannot instantiate `racket/gui/base' a second time in the same process
(lazy-require ["../common/gui.rkt" (make-snip-frame)])
(provide (except-out (all-defined-out) make-snip-frame))
(provide (all-defined-out))
;; ===================================================================================================
;; Plot to a given device context

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

@ -20,7 +20,7 @@
(lazy-require ["snip.rkt" (make-3d-plot-snip)]
["../common/gui.rkt" (make-snip-frame)])
(provide (except-out (all-defined-out) make-3d-plot-snip make-snip-frame))
(provide (all-defined-out))
;; ===================================================================================================
;; Plot to a given device context

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

@ -152,15 +152,21 @@ When used as area or surface colors, numbers are interpreted as light, desaturat
@interaction[#:eval plot-eval
(parameterize ([interval-line1-width 3]
[interval-line2-width 3])
(plot (for/list ([i (in-range 8)])
(plot (for/list ([i (in-range -7 13)])
(function-interval
(λ (x) (* i 1.2)) (λ (x) (+ 1 (* i 1.2)))
(λ (x) (* i 1.3)) (λ (x) (+ 1 (* i 1.3)))
#:color i #:line1-color i #:line2-color i))
#:x-min -8 #:x-max 8))]
The colors repeat after @(racket 7); i.e. colors @(racket 8)..@(racket 15) are identical to colors @(racket 0)..@(racket 7).
Color @(racket 0) is black for lines and white for areas.
Colors @(racket 1)..@(racket 120) are generated by rotating hues and adjusting to make neighbors more visually dissimilar.
Colors @(racket 121)..@(racket 127) are grayscale.
If the paper will be published in black and white, use styles as well.
Colors @(racket -7)..@(racket -1) are also grayscale because before @(racket 0), colors repeat.
That is, colors @(racket -128)..@(racket -1) are identical to colors @(racket 0)..@(racket 127).
Colors also repeat after @(racket 127).
If the paper will be published in black and white, use styles as well as, or instead of, colors.
There are @(racket 5) numbered pen styles and @(racket 7) numbered brush styles, which also repeat.
@interaction[#:eval plot-eval

2
collects/plot/scribblings/todo.scrbl
View File

@ -30,11 +30,9 @@
@itemlist[
@item{Better depth sorting (possibly split intersecting polygons; look into BSP tree)}
@item{Legend entries have minimum sizes}
@item{Log-scale tick functions (i.e. major ticks are 10^0, 10^1, 10^2, ...)}
@item{Label contour heights on the contour lines}
@item{3D support for exact rational functions (i.e. polynomial at [big..big+ε])}
@item{Join 2D contour lines}
@item{More appearance options (i.e. draw 2D tick labels on right/top)}
@item{Manually exclude discontinuous points from function renderers: allow values @(racket (hole p1 p2)), @(racket (left-hole p1 p2)), @(racket (right-hole p1 p2))}
@item{@(racket histogram-list) to plot multiple histograms without manually calculating @(racket #:x-min)}
]

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

@ -112,7 +112,7 @@ Converts a @italic{line} color to an RGB triplet. This function interprets integ
Non-integer colors are converted using @(racket ->color).
Integer colors are chosen for good pairwise contrast, especially between neighbors.
Integer colors repeat starting with @(racket 8).
Integer colors repeat starting with @(racket 128).
@examples[#:eval plot-eval
(equal? (->pen-color 0) (->pen-color 8))
@ -127,7 +127,7 @@ Converts a @italic{fill} color to an RGB triplet. This function interprets integ
Non-integer colors are converted using @(racket ->color).
Integer colors are chosen for good pairwise contrast, especially between neighbors.
Integer colors repeat starting with @(racket 8).
Integer colors repeat starting with @(racket 128).
@examples[#:eval plot-eval
(equal? (->brush-color 0) (->brush-color 8))

71
collects/plot/tests/pen-brush-hsv.rkt
View File

@ -71,7 +71,7 @@
(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 (quotient n 6))))
(* 6 3 (quotient n 6))))
(remainder (* i 59) 360)))
(define (pen-color n)
@ -117,16 +117,48 @@
(define (brush-color n)
(define h (integer->hue n))
(hsv->rgb (list (brush-hue-transform h) (brush-saturation-transform h) (brush-value-transform h))))
#|
(define (integer->value n)
(* 1/7 (remainder (abs n) 8)))
(define (pen-intensity-transform i)
(* 128 (expt (integer->value i) 3/4)))
(define (brush-intensity-transform i)
(+ 127 (* 128 (expt (- 1 (integer->value i)) 3/4))))
(define (gray-pen-color i)
(make-list 3 (pen-intensity-transform i)))
(define (gray-brush-color i)
(make-list 3 (brush-intensity-transform i)))
(plot (for/list ([n (in-range 8)])
(function-interval sin (λ (x) (+ 1 (sin x))) n (+ 1 n)
#:color (gray-brush-color n)
#:line1-color (gray-pen-color n)
#:line2-color (gray-pen-color n)
#:line1-width 2 #:line2-width 2 #:alpha 1)))
(define new-brush-colors
(append (list (gray-brush-color 0))
(build-list 120 brush-color)
(build-list 7 (λ (n) (gray-brush-color (- 7 n))))))
(define new-pen-colors
(append (list (gray-brush-color 0))
(build-list 120 brush-color)
(build-list 7 (λ (n) (gray-brush-color (- 7 n))))))
(plot (for/list ([n (in-range 60)])
(lines (list (vector 0 n) (vector 1 n))
#:color (brush-color n)
#:width 6)))
(plot (for*/list ([i (in-range 6)] [j (in-range 60)])
(plot (for*/list ([i (in-range 6)] [j (in-range 20)])
(define n (+ i (* j 6)))
(rectangles (list (vector (ivl (+ i 0.05) (+ i 0.95))
(ivl (+ j 0.3) (+ j 0.7))))
(ivl (+ j 0.05) (+ j 0.95))))
#:color (brush-color n)
#:line-color (pen-color n)
#:line-width 3))
@ -146,10 +178,10 @@
#:line-width 3)))
#:height 200)
(plot (for/list ([n (in-range 6)])
(function-interval (λ (x) (* 1/2 (sin (+ x n))))
(λ (x) (+ 1/2 (sin (+ x n))))
-4 4 #:color (brush-color n)
(plot (for/list ([n (in-range 12)])
(function-interval (λ (x) (* 1/2 (sqr (+ x (* 2 n)))))
(λ (x) (+ 1/2 (sqr (+ x (* 2 n)))))
0 12 #:color (brush-color n)
#:line1-color (pen-color n)
#:line2-color (pen-color n)
#:line1-width 2 #:line2-width 2)))
@ -161,26 +193,3 @@
#:line1-color (->pen-color (+ n 1))
#:line2-color (->pen-color (+ n 1))
#:line1-width 2 #:line2-width 2)))
|#
(define (integer->value n)
(* 1/3 (case (remainder (abs n) 4) [(0) 0] [(1) 2] [(2) 1] [(3) 3])))
(define (pen-intensity-transform i)
(* 95 (expt (integer->value i) 3/4)))
(define (brush-intensity-transform i)
(+ 160 (* 95 (- 1 (integer->value i)))))
(define (gray-pen-color i)
(make-list 3 (pen-intensity-transform i)))
(define (gray-brush-color i)
(make-list 3 (brush-intensity-transform i)))
(plot (for/list ([n (in-range 8)])
(function-interval sin (λ (x) (+ 1 (sin x))) n (+ 1 n)
#:color (gray-brush-color n)
#:line1-color (gray-pen-color n)
#:line2-color (gray-pen-color n)
#:line1-width 2 #:line2-width 2 #:alpha 1)))

16
collects/unstable/latent-contract.rkt
View File

@ -45,29 +45,29 @@
(define-syntax activate-contract-out/end
(make-provide-pre-transformer
(λ (stx modes)
(λ (stx metas)
(syntax-case stx ()
[(_ id ...) (with-syntax ([(item ...) (for/list ([id (in-list (syntax->list #'(id ...)))])
(activate->contract-out stx id))])
(pre-expand-export
(syntax-protect
(syntax/loc stx (contract-out item ...)))
modes))]))))
metas))]))))
(define-for-syntax (modes->abs-modes modes)
(map (λ (mode) (and mode (+ mode (syntax-local-phase-level))))
(if (null? modes) '(0) modes)))
(define-for-syntax (metas->abs-metas metas)
(map (λ (meta) (and meta (+ meta (syntax-local-phase-level))))
(if (null? metas) '(0) metas)))
(define-for-syntax (make-lifting-provide-pre-transformer target-id)
(make-provide-pre-transformer
(λ (stx modes)
(λ (stx metas)
(syntax-case stx ()
[(_ args ...) (let ()
(for ([mode (in-list (modes->abs-modes modes))])
(for ([meta (in-list (metas->abs-metas metas))])
(syntax-local-lift-module-end-declaration
(syntax-protect
(quasisyntax/loc stx
(provide (for-meta #,mode (#,target-id args ...)))))))
(provide (for-meta #,meta (#,target-id args ...)))))))
(syntax/loc stx (combine-out)))]))))
(define-syntax activate-contract-out