diff --git a/plot-doc/plot/scribblings/params.scrbl b/plot-doc/plot/scribblings/params.scrbl index 9040bb7b..ddd30ca2 100644 --- a/plot-doc/plot/scribblings/params.scrbl +++ b/plot-doc/plot/scribblings/params.scrbl @@ -310,6 +310,14 @@ width should take that into consideration. For example, a width of 86400 may be as there are 86400 seconds in a day. This candle will be exactly one day in width. } +@section{Color fields} + +@deftogether[((defparam color-field-samples n exact-positive-integer? #:value 20) + (defparam color-field-alpha alpha (real-in 0 1) #:value 1))]{ +The default sample rate and opacity used by @racket[color-field]. +@history[#:added "7.9"] +} + @section{Contours and Contour Intervals} @deftogether[( diff --git a/plot-doc/plot/scribblings/renderer2d.scrbl b/plot-doc/plot/scribblings/renderer2d.scrbl index b03d7578..96eb8f4b 100644 --- a/plot-doc/plot/scribblings/renderer2d.scrbl +++ b/plot-doc/plot/scribblings/renderer2d.scrbl @@ -198,6 +198,22 @@ fourth, and fifth elements in each vector comprise the open, high, low, and clos (vector 6 24 36 10 24)))))] } +@defproc[(color-field + [f (or/c (-> real? real? plot-color/c) + (-> (vector/c real? real?) plot-color/c))] + [x-min (or/c rational? #f) #f] [x-max (or/c rational? #f) #f] + [y-min (or/c rational? #f) #f] [y-max (or/c rational? #f) #f] + [#:samples samples exact-positive-integer? (color-field-samples)] + [#:alpha alpha (real-in 0 1) (color-field-alpha)] + ) renderer2d?]{ +Returns a renderer that draws rectangles filled with a color based on the center point. + +@interaction[#:eval plot-eval + (plot (color-field (λ (x y) (if (< (+ (sqr x) (sqr y)) 1) (random 10) 'black)) + -2 2 -2 2))] +@history[#:added "7.9"] +} + @section{2D Line Renderers} @defproc[(function [f (real? . -> . real?)] diff --git a/plot-lib/plot/no-gui.rkt b/plot-lib/plot/no-gui.rkt index 6d929dbe..df4b19d5 100644 --- a/plot-lib/plot/no-gui.rkt +++ b/plot-lib/plot/no-gui.rkt @@ -51,6 +51,10 @@ error-bars candlesticks) +(require "private/plot2d/color-field.rkt") +(provide + color-field) + (require "private/plot2d/line.rkt") (provide lines diff --git a/plot-lib/plot/private/common/parameters.rkt b/plot-lib/plot/private/common/parameters.rkt index c9c38395..51075edd 100644 --- a/plot-lib/plot/private/common/parameters.rkt +++ b/plot-lib/plot/private/common/parameters.rkt @@ -228,6 +228,12 @@ (defparam candlestick-line-style Plot-Pen-Style 'solid) (defparam2 candlestick-alpha Real Nonnegative-Real 2/3 (unit-ivl 'candlestick-alpha)) + +;; color fields + +(defparam color-field-samples Positive-Integer 20) +(defparam2 color-field-alpha Real Nonnegative-Real 1 (unit-ivl 'color-field-alpha)) + ;; Contours (defparam2 contour-samples Integer Positive-Integer 51 (integer>=2 'contour-samples)) diff --git a/plot-lib/plot/private/common/untyped-utils.rkt b/plot-lib/plot/private/common/untyped-utils.rkt index 356b851d..67027f1a 100644 --- a/plot-lib/plot/private/common/untyped-utils.rkt +++ b/plot-lib/plot/private/common/untyped-utils.rkt @@ -10,6 +10,10 @@ [else (λ (x y) (sequence-head-vector name (f (vector x y)) 2))])) +(define (fix-a-field-fun name f) + (cond [(procedure-arity-includes? f 2 #t) f] + [else (λ (x y) (f (vector x y)))])) + (define (fix-vector-field3d-fun name f) (cond [(procedure-arity-includes? f 3 #t) (λ (x y z) (sequence-head-vector name (f x y z) 3))] diff --git a/plot-lib/plot/private/plot2d/color-field.rkt b/plot-lib/plot/private/plot2d/color-field.rkt new file mode 100644 index 00000000..d1c64bf7 --- /dev/null +++ b/plot-lib/plot/private/plot2d/color-field.rkt @@ -0,0 +1,76 @@ +#lang typed/racket/base + +;; Renderers for points and other point-like things. + +(require typed/racket/class racket/match racket/list + plot/utils + "../common/type-doc.rkt" + "../common/utils.rkt") + +(require/typed + "../common/untyped-utils.rkt" + [fix-a-field-fun (All (A) + (-> Symbol + (U (-> Real Real A) + (-> (Vector Real Real) A)) + (-> Real Real A)))]) + +(provide (all-defined-out)) + +;; =================================================================================================== +;; color-field +;; similar to point.rkt/vector-field, but draws a square area with a color + +(: color-field-render-fun + (-> (-> Real Real Plot-Color) + Positive-Integer + Nonnegative-Real + 2D-Render-Proc)) +(define ((color-field-render-fun f samples alpha) area) + (match-define (vector (ivl x-min x-max) (ivl y-min y-max)) (send area get-bounds-rect)) + + (cond + [(and x-min x-max y-min y-max) + (define xs (linear-seq x-min x-max (+ samples 1) #:start? #t #:end? #t)) + (define ys (linear-seq y-min y-max (+ samples 1) #:start? #t #:end? #t)) + + (send area put-alpha alpha) + (send area put-pen 'black 0 'transparent) + (for ([x- (in-list xs)] + [x+ (in-list (cdr xs))]) + (define x (/ (+ x- x+) 2)) + (for ([y- (in-list ys)] + [y+ (in-list (cdr ys))]) + (define y (/ (+ y- y+) 2)) + (define c (f x y)) + (send area put-brush c 'solid) + (send area put-rect (vector (ivl x- x+) + (ivl y- y+))))) + empty] + [else empty])) + +(:: color-field + (->* [(U (-> Real Real Plot-Color) + (-> (Vector Real Real) Plot-Color))] + [(U Real #f) (U Real #f) + (U Real #f) (U Real #f) + #:samples Positive-Integer + #:alpha Nonnegative-Real] + renderer2d)) +(define (color-field f [x-min #f] [x-max #f] [y-min #f] [y-max #f] + #:samples [samples (color-field-samples)] + #:alpha [alpha (color-field-alpha)]) + (define fail/pos (make-raise-argument-error 'vector-field3d f x-min x-max y-min y-max)) + (define fail/kw (make-raise-keyword-error 'vector-field3d)) + (cond + [(and x-min (not (rational? x-min))) (fail/pos "#f or rational" 1)] + [(and x-max (not (rational? x-max))) (fail/pos "#f or rational" 2)] + [(and y-min (not (rational? y-min))) (fail/pos "#f or rational" 3)] + [(and y-max (not (rational? y-max))) (fail/pos "#f or rational" 4)] + [(or (> alpha 1) (not (rational? alpha))) (fail/kw "real in [0,1]" '#:alpha alpha)] + [else + (let ([f ((inst fix-a-field-fun Plot-Color) 'color-field f)]) + (renderer2d (vector (ivl x-min x-max) (ivl y-min y-max)) #f default-ticks-fun + (color-field-render-fun + f samples alpha)))])) + diff --git a/plot-lib/plot/private/utils-and-no-gui.rkt b/plot-lib/plot/private/utils-and-no-gui.rkt index e467b6be..df39f6aa 100644 --- a/plot-lib/plot/private/utils-and-no-gui.rkt +++ b/plot-lib/plot/private/utils-and-no-gui.rkt @@ -161,6 +161,8 @@ candlestick-line-width candlestick-line-style candlestick-alpha + color-field-samples + color-field-alpha contour-samples contour-levels contour-colors diff --git a/plot-test/plot/tests/PRs/66.rkt b/plot-test/plot/tests/PRs/66.rkt new file mode 100644 index 00000000..bc2f1db3 --- /dev/null +++ b/plot-test/plot/tests/PRs/66.rkt @@ -0,0 +1,37 @@ +#lang racket +(require rackunit + plot + racket/draw + racket/runtime-path + "../helpers.rkt") + +;; Tests for: https://github.com/racket/plot/pull/66 : color-field +(define (do-plot-color-field output-fn) + (output-fn + (color-field + (λ (x y) + (define z (make-rectangular x y)) + (if (< (magnitude z) 1) + (cond + [(< (magnitude z) 0.5) 'red] + [(< (angle z) 0) 'blue] + [else 'green]) + 'black)) + -2 2 -2 2))) + +(define-runtime-path pr66-color-field-data "./test-data/pr66-1.dat") + +(define pr66-test-suite + (test-suite + "PR#66: color-field" + (test-case "pr66-color-field" + (check-draw-steps do-plot-color-field pr66-color-field-data)))) + +(module+ test + (require rackunit/text-ui) + (run-tests pr66-test-suite)) + +;; + + + diff --git a/plot-test/plot/tests/PRs/test-data/pr66-1.dat b/plot-test/plot/tests/PRs/test-data/pr66-1.dat new file mode 100644 index 00000000..b3478b18 Binary files /dev/null and b/plot-test/plot/tests/PRs/test-data/pr66-1.dat differ diff --git a/plot-test/plot/tests/PRs/test-data/pr66-1.png b/plot-test/plot/tests/PRs/test-data/pr66-1.png new file mode 100644 index 00000000..03334587 Binary files /dev/null and b/plot-test/plot/tests/PRs/test-data/pr66-1.png differ