add color-field 2D renderer (#66)

The new `color-field`  2D renderer allows filling up an area with rectangles 
of a certain color.

Author: bdeket

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[(

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?)]

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

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))

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))]

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)))]))
+

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

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))
+
+;;
+
+
+