From ae64e8683a366c28620ccb692ac127feaf9ab474 Mon Sep 17 00:00:00 2001 From: Neil Toronto Date: Sun, 23 Oct 2011 10:31:57 -0700 Subject: [PATCH] Parameter groups --- collects/plot/common/parameters.rkt | 165 +++++++++--------- collects/plot/common/ticks.rkt | 2 +- collects/plot/plot2d/plot.rkt | 8 +- collects/plot/plot3d/plot.rkt | 11 +- collects/plot/tests/low-level-tests.rkt | 117 +------------ collects/tests/unstable/parameter-group.rkt | 81 +++++++++ collects/unstable/parameter-group.rkt | 88 ++++++++++ .../scribblings/parameter-group.scrbl | 60 +++++++ collects/unstable/scribblings/unstable.scrbl | 1 + 9 files changed, 327 insertions(+), 206 deletions(-) create mode 100644 collects/tests/unstable/parameter-group.rkt create mode 100644 collects/unstable/parameter-group.rkt create mode 100644 collects/unstable/scribblings/parameter-group.scrbl diff --git a/collects/plot/common/parameters.rkt b/collects/plot/common/parameters.rkt index 4949213864..e98cc7a5a1 100644 --- a/collects/plot/common/parameters.rkt +++ b/collects/plot/common/parameters.rkt @@ -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?)) diff --git a/collects/plot/common/ticks.rkt b/collects/plot/common/ticks.rkt index f6d3d490ea..29d2e68916 100644 --- a/collects/plot/common/ticks.rkt +++ b/collects/plot/common/ticks.rkt @@ -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 diff --git a/collects/plot/plot2d/plot.rkt b/collects/plot/plot2d/plot.rkt index 51512b7d0d..9048768072 100644 --- a/collects/plot/plot2d/plot.rkt +++ b/collects/plot/plot2d/plot.rkt @@ -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))) diff --git a/collects/plot/plot3d/plot.rkt b/collects/plot/plot3d/plot.rkt index a3decd2d87..2df3581559 100644 --- a/collects/plot/plot3d/plot.rkt +++ b/collects/plot/plot3d/plot.rkt @@ -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 diff --git a/collects/plot/tests/low-level-tests.rkt b/collects/plot/tests/low-level-tests.rkt index 65f3aaf3d8..d4194e329a 100755 --- a/collects/plot/tests/low-level-tests.rkt +++ b/collects/plot/tests/low-level-tests.rkt @@ -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))) diff --git a/collects/tests/unstable/parameter-group.rkt b/collects/tests/unstable/parameter-group.rkt new file mode 100644 index 0000000000..b87654a4f1 --- /dev/null +++ b/collects/tests/unstable/parameter-group.rkt @@ -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) diff --git a/collects/unstable/parameter-group.rkt b/collects/unstable/parameter-group.rkt new file mode 100644 index 0000000000..5394bb0ddc --- /dev/null +++ b/collects/unstable/parameter-group.rkt @@ -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 ...))])) diff --git a/collects/unstable/scribblings/parameter-group.scrbl b/collects/unstable/scribblings/parameter-group.scrbl new file mode 100644 index 0000000000..ec54a565f9 --- /dev/null +++ b/collects/unstable/scribblings/parameter-group.scrbl @@ -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[-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. +} diff --git a/collects/unstable/scribblings/unstable.scrbl b/collects/unstable/scribblings/unstable.scrbl index 61ca638b48..5050319901 100644 --- a/collects/unstable/scribblings/unstable.scrbl +++ b/collects/unstable/scribblings/unstable.scrbl @@ -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"]