Parameter groups
This commit is contained in:
Neil Toronto
parent
afadbbf0d1
commit
ae64e8683a
|
|
@ -2,73 +2,116 @@
|
|||
|
||||
;; Parameters that control the look and behavior of plots.
|
||||
|
||||
(require racket/contract
|
||||
(require racket/contract unstable/parameter-group
|
||||
"contract.rkt"
|
||||
"contract-doc.rkt"
|
||||
"draw.rkt"
|
||||
"axis-transform.rkt"
|
||||
"ticks.rkt"
|
||||
"parameter-list.rkt")
|
||||
"ticks.rkt")
|
||||
|
||||
(provide (all-defined-out))
|
||||
|
||||
;; ===================================================================================================
|
||||
;; Parameters common to 2D and 3D
|
||||
|
||||
(defparam plot-deprecation-warnings? boolean? #f)
|
||||
|
||||
;; Output
|
||||
|
||||
(defparam plot-width exact-positive-integer? 400)
|
||||
(defparam plot-height exact-positive-integer? 400)
|
||||
(defparam plot-new-window? boolean? #f)
|
||||
(defparam plot-jpeg-quality (integer-in 0 100) 100)
|
||||
(defparam plot-ps/pdf-interactive? boolean? #f)
|
||||
;; ===================================================================================================
|
||||
;; General plot parameters
|
||||
|
||||
;; General appearance
|
||||
|
||||
(defparam plot-width exact-positive-integer? 400)
|
||||
(defparam plot-height exact-positive-integer? 400)
|
||||
(defparam plot-foreground color plot-color/c 0)
|
||||
(defparam plot-background color plot-color/c 0)
|
||||
(defparam plot-foreground-alpha alpha (real-in 0 1) 1)
|
||||
(defparam plot-background-alpha alpha (real-in 0 1) 1)
|
||||
(defparam plot-line-width width (>=/c 0) 1)
|
||||
(defparam plot-tick-size (>=/c 0) 10)
|
||||
(defparam plot-font-size size (>=/c 0) 11)
|
||||
(defparam plot-font-family family font-family/c 'roman)
|
||||
(defparam plot-line-width width (>=/c 0) 1)
|
||||
(defparam plot-legend-anchor anchor anchor/c 'top-right)
|
||||
(defparam plot-legend-box-alpha alpha (real-in 0 1) 2/3)
|
||||
(defparam plot-animating? boolean? #f)
|
||||
|
||||
(defparam plot-x-max-ticks exact-positive-integer? 5)
|
||||
(defparam plot-y-max-ticks exact-positive-integer? 5)
|
||||
(defparam plot-z-max-ticks exact-positive-integer? 8)
|
||||
|
||||
(define-parameter-group plot-max-ticks (plot-x-max-ticks plot-y-max-ticks plot-z-max-ticks)
|
||||
#:struct list)
|
||||
|
||||
(define-parameter-group plot-appearance
|
||||
(plot-width
|
||||
plot-height
|
||||
plot-foreground
|
||||
plot-background
|
||||
plot-foreground-alpha
|
||||
plot-background-alpha
|
||||
plot-line-width
|
||||
plot-tick-size
|
||||
plot-font-size
|
||||
plot-font-family
|
||||
plot-legend-anchor
|
||||
plot-legend-box-alpha
|
||||
plot-animating?
|
||||
plot-max-ticks))
|
||||
|
||||
(define (pen-gap) (* 2 (plot-line-width)))
|
||||
|
||||
(defparam plot-legend-anchor anchor anchor/c 'top-right)
|
||||
(defparam plot-legend-box-alpha alpha (real-in 0 1) 2/3)
|
||||
(defproc (animated-samples [samples (and/c exact-integer? (>=/c 2))]) (and/c exact-integer? (>=/c 2))
|
||||
(cond [(plot-animating?) (max 2 (ceiling (* 1/4 samples)))]
|
||||
[else samples]))
|
||||
|
||||
(defparam plot-tick-size (>=/c 0) 10)
|
||||
;; 3D-specific appearance
|
||||
|
||||
(defparam plot3d-samples (and/c exact-integer? (>=/c 2)) 41)
|
||||
(defparam plot3d-angle real? 30)
|
||||
(defparam plot3d-altitude real? 60)
|
||||
(defparam plot3d-ambient-light (real-in 0 1) 2/3)
|
||||
(defparam plot3d-diffuse-light? boolean? #t)
|
||||
(defparam plot3d-specular-light? boolean? #t)
|
||||
|
||||
(define-parameter-group plot3d-appearance
|
||||
(plot3d-samples
|
||||
plot3d-angle
|
||||
plot3d-altitude
|
||||
plot3d-ambient-light
|
||||
plot3d-diffuse-light?
|
||||
plot3d-specular-light?))
|
||||
|
||||
;; Output
|
||||
|
||||
(defparam plot-new-window? boolean? #f)
|
||||
(defparam plot-jpeg-quality (integer-in 0 100) 100)
|
||||
(defparam plot-ps/pdf-interactive? boolean? #f)
|
||||
|
||||
(define-parameter-group plot-output (plot-new-window? plot-jpeg-quality plot-ps/pdf-interactive?))
|
||||
|
||||
;; Labels
|
||||
|
||||
(defparam plot-title (or/c string? #f) #f)
|
||||
(defparam plot-x-label (or/c string? #f) "x axis")
|
||||
(defparam plot-y-label (or/c string? #f) "y axis")
|
||||
(defparam plot-z-label (or/c string? #f) #f)
|
||||
|
||||
(defparam plot-animating? boolean? #f)
|
||||
(define-parameter-group plot-labels (plot-title plot-x-label plot-y-label plot-z-label))
|
||||
|
||||
(defproc (animated-samples [samples (and/c exact-integer? (>=/c 2))]) (and/c exact-integer? (>=/c 2))
|
||||
(cond [(plot-animating?) (max 2 (ceiling (* 1/4 samples)))]
|
||||
[else samples]))
|
||||
|
||||
;; Sampling
|
||||
;; Axes: transform, ticks
|
||||
|
||||
(defparam plot-x-transform axis-transform/c id-transform)
|
||||
(defparam plot-y-transform axis-transform/c id-transform)
|
||||
(defparam plot-z-transform axis-transform/c id-transform)
|
||||
|
||||
;; Ticks
|
||||
|
||||
(defparam plot-x-max-ticks exact-positive-integer? 5)
|
||||
(defparam plot-y-max-ticks exact-positive-integer? 5)
|
||||
(defparam plot-z-max-ticks exact-positive-integer? 8)
|
||||
|
||||
(defparam plot-x-ticks ticks? (linear-ticks))
|
||||
(defparam plot-y-ticks ticks? (linear-ticks))
|
||||
(defparam plot-z-ticks ticks? (linear-ticks))
|
||||
|
||||
(struct axis (transform ticks) #:transparent)
|
||||
|
||||
(define-parameter-group plot-x-axis (plot-x-transform plot-x-ticks) #:struct axis)
|
||||
(define-parameter-group plot-y-axis (plot-y-transform plot-y-ticks) #:struct axis)
|
||||
(define-parameter-group plot-z-axis (plot-z-transform plot-z-ticks) #:struct axis)
|
||||
(define-parameter-group plot-axes (plot-x-axis plot-y-axis plot-z-axis) #:struct list)
|
||||
|
||||
(defproc (default-x-ticks [x-min real?] [x-max real?]) (listof tick?)
|
||||
((plot-x-ticks) x-min x-max (plot-x-max-ticks) (plot-x-transform)))
|
||||
|
||||
|
|
@ -78,6 +121,18 @@
|
|||
(defproc (default-z-ticks [z-min real?] [z-max real?]) (listof tick?)
|
||||
((plot-z-ticks) z-min z-max (plot-z-max-ticks) (plot-z-transform)))
|
||||
|
||||
;; ===================================================================================================
|
||||
|
||||
(define-parameter-group plot-parameters
|
||||
(plot-appearance
|
||||
plot3d-appearance
|
||||
plot-labels
|
||||
plot-output
|
||||
plot-axes))
|
||||
|
||||
;; ===================================================================================================
|
||||
;; Renderer-specific parameters
|
||||
|
||||
;; Lines
|
||||
|
||||
(defparam line-samples (and/c exact-integer? (>=/c 2)) 500)
|
||||
|
|
@ -169,18 +224,6 @@
|
|||
(defparam label-alpha (real-in 0 1) 1)
|
||||
(defparam label-point-size (>=/c 0) 4)
|
||||
|
||||
;; ===================================================================================================
|
||||
;; 3D-specific parameters
|
||||
|
||||
;; General appearance
|
||||
|
||||
(defparam plot3d-samples (and/c exact-integer? (>=/c 2)) 41)
|
||||
(defparam plot3d-angle real? 30)
|
||||
(defparam plot3d-altitude real? 60)
|
||||
(defparam plot3d-ambient-light (real-in 0 1) 2/3)
|
||||
(defparam plot3d-diffuse-light? boolean? #t)
|
||||
(defparam plot3d-specular-light? boolean? #t)
|
||||
|
||||
;; Surfaces
|
||||
|
||||
(defparam surface-color plot-color/c 0)
|
||||
|
|
@ -216,43 +259,3 @@
|
|||
;; Histograms
|
||||
|
||||
(defparam rectangle3d-line-width (>=/c 0) 1/3)
|
||||
|
||||
;; ===================================================================================================
|
||||
|
||||
(define plot-parameters
|
||||
(parameter-list plot-deprecation-warnings?
|
||||
plot-width
|
||||
plot-height
|
||||
plot-new-window?
|
||||
plot-jpeg-quality
|
||||
plot-ps/pdf-interactive?
|
||||
plot-foreground
|
||||
plot-background
|
||||
plot-foreground-alpha
|
||||
plot-background-alpha
|
||||
plot-font-size
|
||||
plot-font-family
|
||||
plot-line-width
|
||||
plot-legend-anchor
|
||||
plot-legend-box-alpha
|
||||
plot-tick-size
|
||||
plot-title
|
||||
plot-x-label
|
||||
plot-y-label
|
||||
plot-z-label
|
||||
plot-animating?
|
||||
plot-x-transform
|
||||
plot-y-transform
|
||||
plot-z-transform
|
||||
plot-x-max-ticks
|
||||
plot-y-max-ticks
|
||||
plot-z-max-ticks
|
||||
plot-x-ticks
|
||||
plot-y-ticks
|
||||
plot-z-ticks
|
||||
plot3d-samples
|
||||
plot3d-angle
|
||||
plot3d-altitude
|
||||
plot3d-ambient-light
|
||||
plot3d-diffuse-light?
|
||||
plot3d-specular-light?))
|
||||
|
|
|
|||
|
|
@ -12,7 +12,7 @@
|
|||
"axis-transform.rkt"
|
||||
"currency.rkt")
|
||||
|
||||
(provide (struct-out pre-tick) (struct-out tick) (struct-out ticks)
|
||||
(provide (struct-out pre-tick) (struct-out tick) (struct-out ticks) ticks-layout/c ticks-format/c
|
||||
;; No ticks
|
||||
no-ticks-layout no-ticks
|
||||
;; Linear ticks
|
||||
|
|
|
|||
|
|
@ -4,6 +4,7 @@
|
|||
|
||||
(require racket/draw racket/snip racket/contract racket/list racket/class racket/match
|
||||
slideshow/pict
|
||||
unstable/parameter-group
|
||||
unstable/lazy-require
|
||||
(for-syntax racket/base
|
||||
syntax/strip-context
|
||||
|
|
@ -19,7 +20,6 @@
|
|||
"../common/deprecation-warning.rkt"
|
||||
"../common/renderer.rkt"
|
||||
"../common/utils.rkt"
|
||||
"../common/parameter-list.rkt"
|
||||
"area.rkt")
|
||||
|
||||
;; Require lazily: without this, Racket complains while generating documentation:
|
||||
|
|
@ -119,10 +119,10 @@
|
|||
[#:y-label y-label (or/c string? #f) (plot-y-label)]
|
||||
[#:legend-anchor legend-anchor anchor/c (plot-legend-anchor)]
|
||||
) pict?
|
||||
(define saved-parameters (plot-parameters))
|
||||
(define saved-values (plot-parameters))
|
||||
(dc (λ (dc x y)
|
||||
(parameterize/list
|
||||
([plot-parameters saved-parameters])
|
||||
(parameterize/group
|
||||
([plot-parameters saved-values])
|
||||
(plot/dc renderer-tree dc x y width height
|
||||
#:x-min x-min #:x-max x-max #:y-min y-min #:y-max y-max
|
||||
#:title title #:x-label x-label #:y-label y-label #:legend-anchor legend-anchor)))
|
||||
|
|
|
|||
|
|
@ -2,18 +2,19 @@
|
|||
|
||||
(require racket/draw racket/snip racket/match racket/list racket/class racket/contract
|
||||
slideshow/pict
|
||||
unstable/parameter-group
|
||||
unstable/lazy-require
|
||||
(for-syntax racket/base)
|
||||
"../common/math.rkt"
|
||||
"../common/vector.rkt"
|
||||
"../common/file-type.rkt"
|
||||
"../common/area.rkt"
|
||||
"../common/contract.rkt" "../common/contract-doc.rkt"
|
||||
"../common/contract.rkt"
|
||||
"../common/contract-doc.rkt"
|
||||
"../common/parameters.rkt"
|
||||
"../common/deprecation-warning.rkt"
|
||||
"../common/renderer.rkt"
|
||||
"../common/utils.rkt"
|
||||
"../common/parameter-list.rkt"
|
||||
"area.rkt")
|
||||
|
||||
;; Require lazily: without this, Racket complains while generating documentation:
|
||||
|
|
@ -133,10 +134,10 @@
|
|||
[#:z-label z-label (or/c string? #f) (plot-z-label)]
|
||||
[#:legend-anchor legend-anchor anchor/c (plot-legend-anchor)]
|
||||
) pict?
|
||||
(define saved-parameters (plot-parameters))
|
||||
(define saved-values (plot-parameters))
|
||||
(dc (λ (dc x y)
|
||||
(parameterize/list
|
||||
([plot-parameters saved-parameters])
|
||||
(parameterize/group
|
||||
([plot-parameters saved-values])
|
||||
(plot3d/dc renderer-tree dc x y width height
|
||||
#:x-min x-min #:x-max x-max #:y-min y-min #:y-max y-max #:z-min z-min
|
||||
#:z-max z-max #:angle angle #:altitude altitude #:title title #:x-label x-label
|
||||
|
|
|
|||
|
|
@ -9,7 +9,8 @@ exec gracket "$0" "$@"
|
|||
plot/common/date-time
|
||||
plot/common/vector
|
||||
plot/common/utils
|
||||
plot/common/parameter-list)
|
||||
plot/common/parameter-list
|
||||
plot/common/parameter-group)
|
||||
|
||||
(check-equal? (linear-seq 0 1 2 #:start? #t #:end? #t) '(0 1))
|
||||
(check-equal? (linear-seq 0 1 2 #:start? #t #:end? #f) '(0 2/3))
|
||||
|
|
@ -303,117 +304,3 @@ exec gracket "$0" "$@"
|
|||
(check-false (vector-ormap (λ (x y) (and (= x 1) (= y 2)))
|
||||
#(0 0 1 0)
|
||||
#(0 2 0 0)))
|
||||
|
||||
;; ===================================================================================================
|
||||
;; Parameter lists
|
||||
|
||||
(define p1 (make-parameter 1))
|
||||
(define p2 (make-parameter 2))
|
||||
|
||||
(define ps1 (parameter-list p1 p2))
|
||||
|
||||
(check-equal? (ps1) (list 1 2))
|
||||
(check-equal? (parameterize/list () (ps1)) (ps1))
|
||||
(check-equal? (parameterize*/list () (ps1)) (ps1))
|
||||
(check-equal? (parameterize/list ([ps1 (list 10 20)]) (ps1))
|
||||
(list 10 20))
|
||||
(check-equal? (parameterize/list ([p1 10] [p2 20]) (ps1))
|
||||
(list 10 20))
|
||||
(check-equal? (parameterize/list ([ps1 (list 10 20)]) (list (p1) (p2)))
|
||||
(list 10 20))
|
||||
(check-equal? (ps1) (list 1 2))
|
||||
|
||||
(check-exn exn:fail:contract? (λ () (ps1 (list 1 2 3))))
|
||||
(check-exn exn:fail:contract? (λ () (parameterize ([ps1 (list 1 2 3)]) (ps1))))
|
||||
(check-exn exn:fail:contract? (λ () (parameter-list 0)))
|
||||
(check-exn exn:fail:contract? (λ () (parameter-list* 0 ps1)))
|
||||
(check-exn exn:fail:contract? (λ () (parameter-list* p1 0)))
|
||||
(check-exn exn:fail:contract? (λ () (parameter-list-append 0 ps1)))
|
||||
(check-exn exn:fail:contract? (λ () (parameter-list-append ps1 0)))
|
||||
|
||||
(ps1 (list 10 20))
|
||||
|
||||
(check-equal? (ps1) (list 10 20))
|
||||
(check-equal? (parameterize/list ([ps1 (list 1 2)]) (ps1))
|
||||
(list 1 2))
|
||||
(check-equal? (parameterize/list ([p1 1] [p2 2]) (ps1))
|
||||
(list 1 2))
|
||||
(check-equal? (parameterize/list ([ps1 (list 1 2)]) (list (p1) (p2)))
|
||||
(list 1 2))
|
||||
(check-equal? (ps1) (list 10 20))
|
||||
|
||||
(p1 1)
|
||||
(p2 2)
|
||||
|
||||
(define p3 (make-parameter 3))
|
||||
|
||||
(define ps2 (parameter-list* p3 ps1))
|
||||
|
||||
(check-equal? (ps2) (list 3 1 2))
|
||||
(check-equal? (parameterize/list ([ps2 (list 30 10 20)]) (ps2))
|
||||
(list 30 10 20))
|
||||
(check-equal? (parameterize/list ([p3 30] [p1 10] [p2 20]) (ps2))
|
||||
(list 30 10 20))
|
||||
(check-equal? (parameterize/list ([ps2 (list 30 10 20)]) (list (p3) (p1) (p2)))
|
||||
(list 30 10 20))
|
||||
(check-equal? (ps2) (list 3 1 2))
|
||||
|
||||
(ps2 (list 30 10 20))
|
||||
|
||||
(check-equal? (ps2) (list 30 10 20))
|
||||
(check-equal? (parameterize/list ([ps2 (list 3 1 2)]) (ps2))
|
||||
(list 3 1 2))
|
||||
(check-equal? (parameterize/list ([p3 3] [p1 1] [p2 2]) (ps2))
|
||||
(list 3 1 2))
|
||||
(check-equal? (parameterize/list ([ps2 (list 3 1 2)]) (list (p3) (p1) (p2)))
|
||||
(list 3 1 2))
|
||||
(check-equal? (ps2) (list 30 10 20))
|
||||
|
||||
(p1 1)
|
||||
(p2 2)
|
||||
(p3 3)
|
||||
|
||||
(define ps3 (parameter-list-append ps1 (parameter-list p3)))
|
||||
|
||||
(check-equal? (ps3) (list 1 2 3))
|
||||
(check-equal? (parameterize/list ([ps3 (list 10 20 30)]) (ps3))
|
||||
(list 10 20 30))
|
||||
(check-equal? (parameterize/list ([p1 10] [p2 20] [p3 30]) (ps3))
|
||||
(list 10 20 30))
|
||||
(check-equal? (parameterize/list ([ps3 (list 10 20 30)]) (list (p1) (p2) (p3)))
|
||||
(list 10 20 30))
|
||||
(check-equal? (ps3) (list 1 2 3))
|
||||
|
||||
(ps3 (list 10 20 30))
|
||||
|
||||
(check-equal? (ps3) (list 10 20 30))
|
||||
(check-equal? (parameterize/list ([ps3 (list 1 2 3)]) (ps3))
|
||||
(list 1 2 3))
|
||||
(check-equal? (parameterize/list ([p1 1] [p2 2] [p3 3]) (ps3))
|
||||
(list 1 2 3))
|
||||
(check-equal? (parameterize/list ([ps3 (list 1 2 3)]) (list (p1) (p2) (p3)))
|
||||
(list 1 2 3))
|
||||
(check-equal? (ps3) (list 10 20 30))
|
||||
|
||||
(ps3 (list 1 2 3))
|
||||
|
||||
(define p4 (make-parameter 4))
|
||||
(define p5 (make-parameter 5))
|
||||
(define ps4 (parameter-list p4 p5))
|
||||
(define ps5 (parameter-list ps3 ps4))
|
||||
|
||||
(check-equal? (ps5) (list (list 1 2 3) (list 4 5)))
|
||||
(check-equal? (parameterize/list ([ps5 (list (list 10 20 30) (list 40 50))]) (ps5))
|
||||
(list (list 10 20 30) (list 40 50)))
|
||||
(check-equal? (parameterize/list ([p1 10] [p2 20] [p3 30] [p4 40] [p5 50]) (ps5))
|
||||
(list (list 10 20 30) (list 40 50)))
|
||||
(check-equal? (parameterize/list ([ps5 (list (list 10 20 30) (list 40 50))])
|
||||
(list (p1) (p2) (p3) (p4) (p5)))
|
||||
(list 10 20 30 40 50))
|
||||
(check-equal? (parameterize/list ([ps3 (list 10 20 30)] [ps4 (list 40 50)]) (ps5))
|
||||
(list (list 10 20 30) (list 40 50)))
|
||||
(check-equal? (parameterize/list ([ps3 (list 10 20 30)] [ps4 (list (p1) (p2))]) (ps5))
|
||||
(list (list 10 20 30) (list 1 2)))
|
||||
(check-equal? (parameterize*/list ([ps3 (list 10 20 30)] [ps4 (list (p1) (p2))]) (ps5))
|
||||
(list (list 10 20 30) (list 10 20)))
|
||||
(check-equal? (ps5) (list (list 1 2 3) (list 4 5)))
|
||||
|
|
|
|||
81
collects/tests/unstable/parameter-group.rkt
Normal file
81
collects/tests/unstable/parameter-group.rkt
Normal file
|
|
@ -0,0 +1,81 @@
|
|||
#lang racket/base
|
||||
|
||||
(require rackunit unstable/parameter-group)
|
||||
|
||||
(define p1 (make-parameter 1))
|
||||
(define p2 (make-parameter 2))
|
||||
|
||||
(define-parameter-group ps1 (p1 p2))
|
||||
|
||||
(check-true (parameter-group? ps1))
|
||||
(check-equal? (ps1) (ps1-value 1 2))
|
||||
(check-equal? (parameterize/group () (ps1)) (ps1))
|
||||
(check-equal? (parameterize*/group () (ps1)) (ps1))
|
||||
(check-equal? (parameterize/group ([ps1 (ps1-value 10 20)]) (ps1))
|
||||
(ps1-value 10 20))
|
||||
(check-equal? (parameterize/group ([p1 10] [p2 20]) (ps1))
|
||||
(ps1-value 10 20))
|
||||
(check-equal? (parameterize/group ([ps1 (ps1-value 10 20)]) (list (p1) (p2)))
|
||||
(list 10 20))
|
||||
(check-equal? (ps1) (ps1-value 1 2))
|
||||
|
||||
(check-exn exn:fail:contract? (λ () (ps1 (list 1 2 3))))
|
||||
(check-exn exn:fail:contract? (λ () (parameterize ([ps1 (list 1 2 3)]) (ps1))))
|
||||
|
||||
(ps1 (ps1-value 10 20))
|
||||
|
||||
(check-equal? (ps1) (ps1-value 10 20))
|
||||
(check-equal? (parameterize/group ([ps1 (ps1-value 1 2)]) (ps1))
|
||||
(ps1-value 1 2))
|
||||
(check-equal? (parameterize/group ([p1 1] [p2 2]) (ps1))
|
||||
(ps1-value 1 2))
|
||||
(check-equal? (parameterize/group ([ps1 (ps1-value 1 2)]) (list (p1) (p2)))
|
||||
(list 1 2))
|
||||
(check-equal? (ps1) (ps1-value 10 20))
|
||||
|
||||
(p1 1)
|
||||
(p2 2)
|
||||
|
||||
(define p3 (make-parameter 3))
|
||||
|
||||
(define-parameter-group ps2 (ps1 p3))
|
||||
|
||||
(check-equal? (ps2) (ps2-value (ps1-value 1 2) 3))
|
||||
(check-equal? (parameterize/group ([ps2 (ps2-value (ps1-value 10 20) 30)]) (ps2))
|
||||
(ps2-value (ps1-value 10 20) 30))
|
||||
(check-equal? (parameterize/group ([p1 10] [p2 20] [p3 30]) (ps2))
|
||||
(ps2-value (ps1-value 10 20) 30))
|
||||
(check-equal? (parameterize/group ([ps2 (ps2-value (ps1-value 10 20) 30)]) (list (p1) (p2) (p3)))
|
||||
(list 10 20 30))
|
||||
(check-equal? (ps2) (ps2-value (ps1-value 1 2) 3))
|
||||
|
||||
(ps2 (ps2-value (ps1-value 10 20) 30))
|
||||
|
||||
(check-equal? (ps2) (ps2-value (ps1-value 10 20) 30))
|
||||
(check-equal? (parameterize/group ([ps2 (ps2-value (ps1-value 1 2) 3)]) (ps2))
|
||||
(ps2-value (ps1-value 1 2) 3))
|
||||
(check-equal? (parameterize/group ([p1 1] [p2 2] [p3 3]) (ps2))
|
||||
(ps2-value (ps1-value 1 2) 3))
|
||||
(check-equal? (parameterize/group ([ps2 (ps2-value (ps1-value 1 2) 3)]) (list (p1) (p2) (p3)))
|
||||
(list 1 2 3))
|
||||
(check-equal? (ps2) (ps2-value (ps1-value 10 20) 30))
|
||||
|
||||
(p1 1)
|
||||
(p2 2)
|
||||
(p3 3)
|
||||
|
||||
(check-equal? (parameterize/group ([ps1 (ps1-value 10 20)]
|
||||
[ps2 (ps2-value (ps1) 30)])
|
||||
(ps2))
|
||||
(ps2-value (ps1-value 1 2) 30))
|
||||
|
||||
(check-equal? (parameterize*/group ([ps1 (ps1-value 10 20)]
|
||||
[ps2 (ps2-value (ps1) 30)])
|
||||
(ps2))
|
||||
(ps2-value (ps1-value 10 20) 30))
|
||||
|
||||
(check-equal? (ps1-value-p1 (ps1)) 1)
|
||||
(check-equal? (ps1-value-p2 (ps1)) 2)
|
||||
(check-equal? (ps1-value-p1 (ps2-value-ps1 (ps2))) 1)
|
||||
(check-equal? (ps1-value-p2 (ps2-value-ps1 (ps2))) 2)
|
||||
(check-equal? (ps2-value-p3 (ps2)) 3)
|
||||
88
collects/unstable/parameter-group.rkt
Normal file
88
collects/unstable/parameter-group.rkt
Normal file
|
|
@ -0,0 +1,88 @@
|
|||
#lang racket/base
|
||||
|
||||
;; Provides a way to treat a group of parameters as a parameter itself
|
||||
|
||||
(require racket/match racket/list
|
||||
(for-syntax racket/base racket/syntax syntax/parse racket/match)
|
||||
;; Can't make parameter lists first-class values without these:
|
||||
(only-in '#%paramz parameterization-key extend-parameterization))
|
||||
|
||||
(provide parameter-group? define-parameter-group parameterize/group parameterize*/group)
|
||||
|
||||
;; A wrapper for a group of parameters that acts like a parameter-procedure
|
||||
(struct parameter-group (proc extract-extension)
|
||||
#:property prop:procedure (struct-field-index proc))
|
||||
|
||||
;; Given the left and right side of a 'parameterize' binding, returns a list of alternating
|
||||
;; parameters and parameter values
|
||||
(define (extract-extension p v)
|
||||
(cond [(parameter? p) (list p v)]
|
||||
[(parameter-group? p) ((parameter-group-extract-extension p) v)]
|
||||
[else (raise-type-error 'parameterize "parameter or parameter-group" p)]))
|
||||
|
||||
(define-syntax (define-parameter-group stx)
|
||||
(syntax-parse stx
|
||||
[(_ name:id (param ...) #:struct struct-name:id)
|
||||
(with-syntax ([(param-name ...) (generate-temporaries (syntax->list #'(param ...)))]
|
||||
[(temp-name ...) (generate-temporaries (syntax->list #'(param ...)))]
|
||||
[proc (format-id #'name "~a-proc" #'name)]
|
||||
[extract (format-id #'name "~a-extract" #'name)])
|
||||
(syntax-protect
|
||||
(syntax/loc stx
|
||||
(define name
|
||||
(let ([param-name param] ...)
|
||||
(unless (or (parameter? param-name) (parameter-group? param-name))
|
||||
(raise-type-error 'define-parameter-group "parameter or parameter-group" param-name))
|
||||
...
|
||||
(define proc
|
||||
(case-lambda
|
||||
[() (struct-name (param-name) ...)]
|
||||
[(v) (match v
|
||||
[(struct-name temp-name ...) (param-name temp-name) ... (void)]
|
||||
[_ (raise-type-error 'name (symbol->string 'struct-name) v)])]))
|
||||
(define (extract v)
|
||||
(match v
|
||||
[(struct-name temp-name ...) (append (extract-extension param-name temp-name) ...)]
|
||||
[_ (raise-type-error 'name (symbol->string 'struct-name) v)]))
|
||||
(parameter-group proc extract))))))]
|
||||
[(_ name:id (param-name:id ...))
|
||||
(with-syntax ([struct-name (format-id #'name "~a-value" #'name)])
|
||||
(syntax-protect
|
||||
(syntax/loc stx
|
||||
(begin (struct struct-name (param-name ...) #:transparent)
|
||||
(define-parameter-group name (param-name ...) #:struct struct-name)))))]))
|
||||
|
||||
;; Corresponds to parameterize
|
||||
(define-syntax (parameterize/group stx)
|
||||
(syntax-case stx ()
|
||||
[(_ () expr1 expr ...)
|
||||
(syntax-protect (syntax/loc stx (let () expr1 expr ...)))]
|
||||
[(_ ([p v] ...) expr1 expr ...)
|
||||
(with-syntax* ([(p-name ...) (generate-temporaries (syntax->list #'(p ...)))]
|
||||
[(p/v ...) (apply append (map list
|
||||
(syntax->list #'(p-name ...))
|
||||
(syntax->list #'(v ...))))])
|
||||
(syntax-protect
|
||||
(syntax/loc stx
|
||||
(with-continuation-mark parameterization-key
|
||||
(let ([p-name p] ...)
|
||||
(if (and (parameter? p-name) ...)
|
||||
(extend-parameterization
|
||||
(continuation-mark-set-first #f parameterization-key)
|
||||
p/v ...)
|
||||
(apply extend-parameterization
|
||||
(continuation-mark-set-first #f parameterization-key)
|
||||
(append (extract-extension p-name v) ...))))
|
||||
(let () expr1 expr ...)))))]))
|
||||
|
||||
;; Corresponds to parameterize*
|
||||
(define-syntax parameterize*/group
|
||||
(syntax-rules ()
|
||||
[(_ () body1 body ...)
|
||||
(let () body1 body ...)]
|
||||
[(_ ([lhs1 rhs1] [lhs rhs] ...) body1 body ...)
|
||||
(parameterize/group
|
||||
([lhs1 rhs1])
|
||||
(parameterize*/group
|
||||
([lhs rhs] ...)
|
||||
body1 body ...))]))
|
||||
60
collects/unstable/scribblings/parameter-group.scrbl
Normal file
60
collects/unstable/scribblings/parameter-group.scrbl
Normal file
|
|
@ -0,0 +1,60 @@
|
|||
#lang scribble/manual
|
||||
|
||||
@(require scribble/eval "utils.rkt" (for-label racket unstable/parameter-group))
|
||||
|
||||
@title{Parameter Groups}
|
||||
|
||||
@unstable[@author+email["Neil Toronto" "ntoronto@racket-lang.org"]]
|
||||
|
||||
@defmodule[unstable/parameter-group]
|
||||
|
||||
Parameter groups are parameter-like @italic{views} that represent multiple parameters.
|
||||
|
||||
@(define evaluator (make-base-eval))
|
||||
|
||||
@examples[#:eval evaluator
|
||||
(require unstable/parameter-group)
|
||||
(define param1 (make-parameter 1))
|
||||
(define param2 (make-parameter 2))
|
||||
(define-parameter-group params (param1 param2))
|
||||
(params)
|
||||
(parameterize/group ([params (params-value 10 20)])
|
||||
(list (param1) (param2)))
|
||||
(params)
|
||||
(params (params-value 100 200))
|
||||
(list (param1) (param2))]
|
||||
|
||||
Use parameter groups to conveniently set multiple parameters.
|
||||
For example, the @racketmodname[plot] library uses parameter groups to save and restore appearance-controlling parameters when it must draw plots within a thunk.
|
||||
|
||||
@defproc[(parameter-group? [v any/c]) boolean?]{
|
||||
Returns @racket[#t] when @racket[v] is a parameter group.
|
||||
}
|
||||
|
||||
@defform/subs[(define-parameter-group name (param-or-group-expr ...) options)
|
||||
([options code:blank
|
||||
(code:line #:struct struct-name)])
|
||||
#:contracts ([param-or-group-expr (or/c parameter? parameter-group?)])]{
|
||||
Defines a new parameter group.
|
||||
|
||||
If @racket[struct-name] is not given, @racket[define-parameter-group] defines a new struct @racket[<name>-value] to hold the values of parameters.
|
||||
|
||||
If @racket[struct-name] is given, it must have a constructor @racket[(struct-name param-or-group-expr ...)] that accepts as many arguments as there are parameters in the group, and a @racket[struct-name] match expander that accepts as many patterns as there are parameters.
|
||||
|
||||
@examples[#:eval evaluator
|
||||
(struct two-params (p1 p2) #:transparent)
|
||||
(define-parameter-group params* (param1 param2) #:struct two-params)
|
||||
(params*)]
|
||||
}
|
||||
|
||||
@defform[(parameterize/group ([param-or-group-expr value-expr] ...)
|
||||
body-expr ...+)
|
||||
#:contracts ([param-or-group-expr (or/c parameter? parameter-group?)])]{
|
||||
Corresponds to @racket[parameterize], but can parameterize parameter groups as well as parameters.
|
||||
}
|
||||
|
||||
@defform[(parameterize*/group ([param-or-group-expr value-expr] ...)
|
||||
body-expr ...+)
|
||||
#:contracts ([param-or-group-expr (or/c parameter? parameter-group?)])]{
|
||||
Corresponds to @racket[parameterize*], but can parameterize parameter groups as well as parameters.
|
||||
}
|
||||
|
|
@ -92,6 +92,7 @@ Keep documentation and tests up to date.
|
|||
@include-section["list.scrbl"]
|
||||
@include-section["logging.scrbl"]
|
||||
@include-section["markparam.scrbl"]
|
||||
@include-section["parameter-group.scrbl"]
|
||||
@include-section["match.scrbl"]
|
||||
@include-section["net.scrbl"]
|
||||
@include-section["path.scrbl"]
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user