From e38843618d90084c238615f89df04eedfd9be2ce Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Sun, 3 Jul 2011 03:38:25 -0600 Subject: [PATCH] unstable: better ppict-do, absorbed code from pslide --- collects/unstable/gui/ppict.rkt | 234 ++------------- .../unstable/gui/private/ppict-syntax.rkt | 18 ++ collects/unstable/gui/private/ppict.rkt | 284 ++++++++++++++++++ collects/unstable/gui/pslide.rkt | 118 +------- .../unstable/scribblings/gui/pslide.scrbl | 111 ++++--- 5 files changed, 405 insertions(+), 360 deletions(-) create mode 100644 collects/unstable/gui/private/ppict-syntax.rkt create mode 100644 collects/unstable/gui/private/ppict.rkt diff --git a/collects/unstable/gui/ppict.rkt b/collects/unstable/gui/ppict.rkt index bd58ef926e..0d9be445e8 100644 --- a/collects/unstable/gui/ppict.rkt +++ b/collects/unstable/gui/ppict.rkt @@ -1,227 +1,37 @@ #lang racket/base -(require racket/list +(require (for-syntax racket/base + syntax/parse + syntax/parse/experimental/contract + "private/ppict-syntax.rkt") racket/contract - slideshow/pict) + slideshow/pict + "private/ppict.rkt") -#| -TODO +(define-syntax (ppict-do stx) + (syntax-parse stx + [(_ base p ...) + #:declare base (expr/c #'pict?) + #:declare p (fragment 'ppict-do) + #'(let-values ([(final _picts) + (internal-ppict-do 'ppict-do base.c (list p.code ...))]) + final)])) -- need a way to express "dependent" additions, when need to find a - pict within a ppict, eg for lines, balloons, etc. - -- [lcr]bl alignments... not sure about [lcr]tl - -- make ppict-do macro, move functionality from pslide to ppict-do - eg require #:go for placers, use #:next to return multiple picts -|# - -;; ============================================================ -;; Progressive Picts - -#| -A ppict contains a pict and a placer (or #f). -A placer = (placer (pict (listof (U pict real #f)) -> ppict)) -In a placer function's arguments: - a number means to change the separation spacing - a #f is just ignored - FIXME: clarify, for following or including current gap? -|# -(struct ppict pict (placer)) -(struct placer (fun)) - -(define (mk-ppict p placer) - (ppict (pict-draw p) - (pict-width p) - (pict-height p) - (pict-ascent p) - (pict-descent p) - (list (make-child p 0 0 1 1)) - #f - (pict-last p) - placer)) - -(define (ppict-pict dp) - (child-pict (car (pict-children dp)))) +(define-syntax (ppict-do* stx) + (syntax-parse stx + [(_ base p ...) + #:declare base (expr/c #'pict?) + #:declare p (fragment 'ppict-do) + #'(internal-ppict-do 'ppict-do* base.c (list p.code ...))])) ;; ---- -;; ppict-do : pict (U pict real #f placer) ... -> pict -(define (ppict-do base . elems) - (define (loop elems rchunks) - (cond [(and (pair? elems) (placer? (car elems))) - (loop (cdr elems) (cons (car elems) rchunks))] - [(and (pair? elems)) - (loop* (cdr elems) rchunks (list (car elems)))] - [(null? elems) - (reverse rchunks)])) - (define (loop* elems rchunks rchunk) - (cond [(and (pair? elems) (placer? (car elems))) - (loop elems (cons (reverse rchunk) rchunks))] - [(and (pair? elems)) - (loop* (cdr elems) rchunks (cons (car elems) rchunk))] - [(null? elems) - (loop elems (cons (reverse rchunk) rchunks))])) - (let ([chunks (loop elems null)]) - (for/fold ([acc base]) ([chunk (in-list chunks)]) - (cond [(placer? chunk) - (ppict-go acc chunk)] - [(list? chunk) - (apply ppict-add acc chunk)])))) - -;; ppict-add : ppict (U pict real #f) ... -> ppict -(define (ppict-add dp . picts) - (let ([pl (ppict-placer dp)]) - ((placer-fun pl) (ppict-pict dp) picts))) - -;; ppict-go : pict placer -> ppict -(define (ppict-go dp pl) - (cond [(ppict? dp) - (mk-ppict (ppict-pict dp) pl)] - [(pict? dp) - (mk-ppict dp pl)])) - -;; ---- - -;; row, column indexes are 0-based -(define (grid cols rows col row [align 'cc] - #:compose [composer (align->vcomposer align)] - #:sep [sep 0]) - (define halign (align->h align)) - (define valign (align->v align)) - (define refxfrac (/ (+ col (align->frac halign)) cols)) - (define refyfrac (/ (+ row (align->frac valign)) rows)) - (coord refxfrac refyfrac align #:compose composer #:sep sep)) - -(define (coord refxfrac refyfrac [align 'cc] - #:compose [composer (align->vcomposer align)] - #:sep [sep 0] - #:internal:skip [skip #f]) - (define halign (align->h align)) - (define valign (align->v align)) - (placer - (lambda (scene picts) - (define scene-w (pict-width scene)) - (define scene-h (pict-height scene)) - (define refx (* scene-w refxfrac)) - (define refy (* scene-h refyfrac)) - (define-values (newpict newsep) - (apply-composer composer sep (cons skip picts))) - (define newpict-w (pict-width newpict)) - (define newpict-h (pict-height newpict)) - (define localrefx (* newpict-w (align->frac halign))) - (define localrefy (* newpict-h (align->frac valign))) - (define newscene - (lt-superimpose scene (inset newpict (- refx localrefx) (- refy localrefy) 0 0))) - (let ([result-pict (refocus newscene scene)]) - (cond [(and (eq? valign 't) (eq? composer (align->vcomposer align))) - ;; ie, going top-down and composer is the natural composer for this align - (mk-ppict result-pict - (coord refxfrac refyfrac align - #:compose composer - #:sep newsep - #:internal:skip (blank 0 newpict-h)))] - [(and (eq? halign 'l) (eq? composer (align->hcomposer align))) - (mk-ppict result-pict - (coord refxfrac refyfrac align - #:compose composer - #:sep newsep - #:internal:skip (blank newpict-w 0)))] - [else result-pict]))))) - -;; ---- - -;; apply-composer : composer real (listof (U #f pict real)) -> (values pict real) -;; Returns composed pict and last given separator num in elems (or init-sep, if none) -(define (apply-composer composer init-sep elems) - (define (start-loop sep elems) - (cond [(and (pair? elems) (real? (car elems))) - (start-loop (car elems) (cdr elems))] - [(and (pair? elems) (pict? (car elems))) - (join-loop (car elems) sep (cdr elems))] - [(null? elems) - (blank 0)])) - (define (join-loop base sep elems) - (cond [(and (pair? elems) (real? (car elems))) - (join-loop base (car elems) (cdr elems))] - [(and (pair? elems) (pict? (car elems))) - (join-loop (composer sep base (car elems)) - sep - (cdr elems))] - [(null? elems) base])) - (values (start-loop init-sep (filter values elems)) - (last (cons init-sep (filter real? elems))))) - -;; ---- - -(define (align->frac align) - (case align - ((t l) 0) - ((c) 1/2) - ((b r) 1))) - -(define (align->h align) - (case align - ((lt lc lb) 'l) - ((ct cc cb) 'c) - ((rt rc rb) 'r))) - -(define (align->v align) - (case align - ((lt ct rt) 't) - ((lc cc rc) 'c) - ((lb cb rb) 'r))) - -(define (align->vcomposer align) - (case align - ((lt lc lb) vl-append) - ((ct cc cb) vc-append) - ((rt rc rb) vr-append))) - -(define (align->hcomposer align) - (case align - ((lt ct rt) ht-append) - ((lc cc rc) hc-append) - ((lb cb rb) hb-append))) - -;; ==== Some examples ==== - -#| -(slide - (let* ([dp (colorize (rectangle 200 200) "gray")] - [dp (ppict-go dp (grid 2 2 1 0 'ct))] - [dp (ppict-add dp (circle 20) (circle 20) (circle 20))]) - (vc-append gap-size - (shframe dp) - (shframe - (ppict-add dp (colorize (circle 20) "red")))))) - -(slide - (let* ([dp (colorize (rectangle 200 200) "gray")] - [dp (ppict-go dp (grid 2 2 0 0 'lb #:compose hbl-append))] - [dp (ppict-add dp (circle 20) (circle 20) (circle 20))]) - (vc-append gap-size - (shframe dp) - (shframe - (ppict-add dp (colorize (circle 20) "red")))))) -|# - -;; ============================================================ -;; Exports - -(define align/c - (or/c 'lt 'ct 'rt - 'lc 'cc 'rc - 'lb 'cb 'rb)) +(provide ppict-do + ppict-do*) (provide ppict? placer?) (provide/contract - [ppict-do - (->* (pict?) - () - #:rest (listof (or/c pict? real? #f placer?)) - pict?)] [ppict-go (-> pict? placer? ppict?)] [ppict-add diff --git a/collects/unstable/gui/private/ppict-syntax.rkt b/collects/unstable/gui/private/ppict-syntax.rkt new file mode 100644 index 0000000000..8cb1021972 --- /dev/null +++ b/collects/unstable/gui/private/ppict-syntax.rkt @@ -0,0 +1,18 @@ +#lang racket/base +(require syntax/parse syntax/parse/experimental/contract + (for-template racket/base + racket/contract + slideshow/pict + "ppict.rkt")) +(provide fragment) + +(define-splicing-syntax-class (fragment who) + #:description (format "~a fragment" who) + (pattern (~seq #:go pl) + #:declare pl (expr/c #'placer? #:name "argument to #:go") + #:with code #'(p:go pl.c)) + (pattern (~seq #:next) + #:with code #'(p:out)) + (pattern (~seq e) + #:declare e (expr/c #'(or/c pict? real? #f) #:name "element") + #:with code #'(p:elem e.c))) diff --git a/collects/unstable/gui/private/ppict.rkt b/collects/unstable/gui/private/ppict.rkt new file mode 100644 index 0000000000..e0eabba0e8 --- /dev/null +++ b/collects/unstable/gui/private/ppict.rkt @@ -0,0 +1,284 @@ +#lang racket/base +(require racket/list + racket/contract + slideshow/pict) + +#| +TODO + +- need a way to express "dependent" additions, when need to find a + pict within a ppict, eg for lines, balloons, etc. + +- [lcr]bl alignments... not sure about [lcr]tl +|# + +;; ============================================================ +;; Progressive Picts + +#| +A ppict contains a pict and a placer (or #f). +A placer = (placer (pict (listof (U pict real #f)) -> ppict)) +In a placer function's arguments: + a number means to change the separation spacing + a #f is just ignored + FIXME: clarify, for following or including current gap? +|# +(struct ppict pict (placer)) +(struct placer (fun)) + +(define (mk-ppict p placer) + (ppict (pict-draw p) + (pict-width p) + (pict-height p) + (pict-ascent p) + (pict-descent p) + (list (make-child p 0 0 1 1)) + #f + (pict-last p) + placer)) + +(define (ppict-pict dp) + (child-pict (car (pict-children dp)))) + +;; ---- + +;; ppict-add : ppict (U pict real #f) ... -> ppict +(define (ppict-add dp . picts) + (let ([pl (ppict-placer dp)]) + ((placer-fun pl) (ppict-pict dp) picts))) + +;; ppict-go : pict placer -> ppict +(define (ppict-go dp pl) + (cond [(ppict? dp) + (mk-ppict (ppict-pict dp) pl)] + [(pict? dp) + (mk-ppict dp pl)])) + +;; ---- + +;; row, column indexes are 0-based +(define (grid cols rows col row [align 'cc] + #:compose [composer (align->vcomposer align)] + #:sep [sep 0]) + (define halign (align->h align)) + (define valign (align->v align)) + (define refxfrac (/ (+ col (align->frac halign)) cols)) + (define refyfrac (/ (+ row (align->frac valign)) rows)) + (coord refxfrac refyfrac align #:compose composer #:sep sep)) + +(define (coord refxfrac refyfrac [align 'cc] + #:compose [composer (align->vcomposer align)] + #:sep [sep 0] + #:internal:skip [skip #f]) + (define halign (align->h align)) + (define valign (align->v align)) + (placer + (lambda (scene picts) + (define scene-w (pict-width scene)) + (define scene-h (pict-height scene)) + (define refx (* scene-w refxfrac)) + (define refy (* scene-h refyfrac)) + (define-values (newpict newsep) + (apply-composer composer sep (cons skip picts))) + (define newpict-w (pict-width newpict)) + (define newpict-h (pict-height newpict)) + (define localrefx (* newpict-w (align->frac halign))) + (define localrefy (* newpict-h (align->frac valign))) + (define newscene + (lt-superimpose scene (inset newpict (- refx localrefx) (- refy localrefy) 0 0))) + (let ([result-pict (refocus newscene scene)]) + (cond [(and (eq? valign 't) (eq? composer (align->vcomposer align))) + ;; ie, going top-down and composer is the natural composer for this align + (mk-ppict result-pict + (coord refxfrac refyfrac align + #:compose composer + #:sep newsep + #:internal:skip (blank 0 newpict-h)))] + [(and (eq? halign 'l) (eq? composer (align->hcomposer align))) + (mk-ppict result-pict + (coord refxfrac refyfrac align + #:compose composer + #:sep newsep + #:internal:skip (blank newpict-w 0)))] + [else result-pict]))))) + +;; ---- + +;; apply-composer : composer real (listof (U #f pict real)) -> (values pict real) +;; Returns composed pict and last given separator num in elems (or init-sep, if none) +(define (apply-composer composer init-sep elems) + (define (start-loop sep elems) + (cond [(and (pair? elems) (real? (car elems))) + (start-loop (car elems) (cdr elems))] + [(and (pair? elems) (pict? (car elems))) + (join-loop (car elems) sep (cdr elems))] + [(null? elems) + (blank 0)])) + (define (join-loop base sep elems) + (cond [(and (pair? elems) (real? (car elems))) + (join-loop base (car elems) (cdr elems))] + [(and (pair? elems) (pict? (car elems))) + (join-loop (composer sep base (car elems)) + sep + (cdr elems))] + [(null? elems) base])) + (values (start-loop init-sep (filter values elems)) + (last (cons init-sep (filter real? elems))))) + +;; ---- + +(define (align->frac align) + (case align + ((t l) 0) + ((c) 1/2) + ((b r) 1))) + +(define (align->h align) + (case align + ((lt lc lb) 'l) + ((ct cc cb) 'c) + ((rt rc rb) 'r))) + +(define (align->v align) + (case align + ((lt ct rt) 't) + ((lc cc rc) 'c) + ((lb cb rb) 'r))) + +(define (align->vcomposer align) + (case align + ((lt lc lb) vl-append) + ((ct cc cb) vc-append) + ((rt rc rb) vr-append))) + +(define (align->hcomposer align) + (case align + ((lt ct rt) ht-append) + ((lc cc rc) hc-append) + ((lb cb rb) hb-append))) + +;; ---- + +#| +(define (ppict-do* base elems) + (define (loop elems rchunks) + (cond [(and (pair? elems) (placer? (car elems))) + (loop (cdr elems) (cons (car elems) rchunks))] + [(and (pair? elems)) + (loop* (cdr elems) rchunks (list (car elems)))] + [(null? elems) + (reverse rchunks)])) + (define (loop* elems rchunks rchunk) + (cond [(and (pair? elems) (placer? (car elems))) + (loop elems (cons (reverse rchunk) rchunks))] + [(and (pair? elems)) + (loop* (cdr elems) rchunks (cons (car elems) rchunk))] + [(null? elems) + (loop elems (cons (reverse rchunk) rchunks))])) + (let ([chunks (loop elems null)]) + (for/fold ([acc base]) ([chunk (in-list chunks)]) + (cond [(placer? chunk) + (ppict-go acc chunk)] + [(list? chunk) + (apply ppict-add acc chunk)])))) +|# + +;; ---- + +(struct p:elem (value)) +(struct p:out ()) +(struct p:go (placer)) + +;; internal-ppict-do : pict (listof (U p:go p:out p:elem)) -> (values pict (listof pict)) +(define (internal-ppict-do who base parts) + (let* ([init-go + (cond [(ppict? base) (p:go (ppict-placer base))] + [else #f])] + [gochunks (get-gochunks who init-go parts)]) + (do-gochunks base gochunks))) + +;; ---- + +;; A gochunk is (cons p:go (listof (U p:elem p:next))) + +;; get-gochunks : (U p:go #f) (listof (U p:elem p:out p:go)) -> (listof gochunk) +(define (get-gochunks who init-go elems) + (define (loop init-go elems) + (cond [(and (pair? elems) (p:go? (car elems))) + (loop (car elems) (cdr elems))] + [(pair? elems) + (unless init-go + (error who "missing initial placer")) + (let-values ([(chunk tail) (split-until p:go? elems)]) + (cons (cons init-go chunk) + (if (pair? tail) + (loop (car tail) (cdr tail)) + null)))] + [(null? elems) null])) + (loop init-go elems)) + +;; do-gochunks : pict (listof gochunk) -> (values pict (listof pict)) +(define (do-gochunks base gochunks) + (let-values ([(pict rpictss) + (for/fold ([base base] [rpictss null]) ([gochunk (in-list gochunks)]) + (let* ([placer (p:go-placer (car gochunk))] + [chunk (cdr gochunk)] + [base (ppict-go base placer)]) + (let-values ([(pict picts) + (do-chunk base chunk)]) + (values pict (cons picts rpictss)))))]) + (values pict (apply append (reverse rpictss))))) + +;; A chunk is (listof (U p:elem p:out)) + +;; do-chunk : ppict (listof (U p:elem p:out)) -> (values ppict (listof pict)) +;; In second return value, one pict per p:out occurrence. +;; FIXME: avoid applying ghost to previously ghosted pict? +(define (do-chunk base chunk) + (let ([elem-chunks + ;; (listof (listof pict?)) + ;; length is N+1, where N is number of (p:out) in chunk + ;; ghosted before visible + (let elab ([chunk chunk]) + (cond [(and (pair? chunk) (p:out? (car chunk))) + (let ([elab-rest (elab (cdr chunk))]) + (cons (map ghost* (car elab-rest)) + elab-rest))] + [(and (pair? chunk) (p:elem? (car chunk))) + (for/list ([elem-chunk (in-list (elab (cdr chunk)))]) + (cons (p:elem-value (car chunk)) + elem-chunk))] + [(null? chunk) + (list null)]))]) + (let out-loop ([chunks elem-chunks] [rpicts null]) + (cond [(null? (cdr chunks)) + (values (apply ppict-add base (car chunks)) + (reverse rpicts))] + [else + (out-loop (cdr chunks) + (cons (apply ppict-add base (car chunks)) + rpicts))])))) + +;; ---- + +(define (split-until stop? elems) + (let loop ([elems elems] [rprefix null]) + (cond [(and (pair? elems) (stop? (car elems))) + (values (reverse rprefix) elems)] + [(pair? elems) + (loop (cdr elems) (cons (car elems) rprefix))] + [(null? elems) + (values (reverse rprefix) null)]))) + +(define (ghost* x) + (if (pict? x) (ghost x) x)) + +;; ============================================================ +;; Exports + +(define align/c + (or/c 'lt 'ct 'rt + 'lc 'cc 'rc + 'lb 'cb 'rb)) + +(provide (all-defined-out)) diff --git a/collects/unstable/gui/pslide.rkt b/collects/unstable/gui/pslide.rkt index 341392a85a..99b5b825a5 100644 --- a/collects/unstable/gui/pslide.rkt +++ b/collects/unstable/gui/pslide.rkt @@ -1,21 +1,18 @@ #lang racket/base (require (for-syntax racket/base syntax/parse - syntax/parse/experimental/contract) + syntax/parse/experimental/contract + "private/ppict-syntax.rkt") racket/list racket/contract racket/gui/base slideshow/base slideshow/pict - "ppict.rkt") + "private/ppict.rkt") ;; ============================================================ ;; Progressive Slides -(struct p:elem (value)) -(struct p:out ()) -(struct p:go (placer)) - (define pslide-base-pict (make-parameter (lambda () (blank client-w client-h)))) @@ -23,109 +20,22 @@ (make-parameter (coord 1/2 1/2 'cc))) ;; pslide* : (U p:elem p:out p:go) ... -> void -(define (pslide* . elems) - (let ([gochunks - (get-gochunks (p:go (pslide-default-placer)) - (append elems (list (p:out))))]) - (do-gochunks ((pslide-base-pict)) gochunks) - (void))) - -;; ---- - -;; A gochunk is (cons p:go (listof (U p:elem p:next))) - -;; get-gochunks : p:go (listof (U p:elem p:out p:go)) -> (listof gochunk) -(define (get-gochunks init-go elems) - (define (loop init-go elems) - (cond [(and (pair? elems) (p:go? (car elems))) - (loop (car elems) (cdr elems))] - [(pair? elems) - (let-values ([(chunk tail) (split-until p:go? elems)]) - (cons (cons init-go chunk) - (if (pair? tail) - (loop (car tail) (cdr tail)) - null)))] - [(null? elems) null])) - (loop init-go elems)) - -(define (do-gochunks base gochunks) - (for/fold ([base base]) ([gochunk (in-list gochunks)]) - (let* ([placer (p:go-placer (car gochunk))] - [chunk (cdr gochunk)] - [base (ppict-go base placer)]) - (do-chunk base chunk)))) - -;; do-chunk : ppict (listof (U p:elem p:out)) -> ppict -(define (do-chunk base chunk) - (let ([elem-chunks - ;; (listof (listof pict?)) - ;; length is N+1, where N is number of (p:out) in chunk - ;; ghosted before visible - (let elab ([chunk chunk]) - (cond [(and (pair? chunk) (p:out? (car chunk))) - (let ([elab-rest (elab (cdr chunk))]) - (cons (map ghost* (car elab-rest)) - elab-rest))] - [(and (pair? chunk) (p:elem? (car chunk))) - (for/list ([elem-chunk (in-list (elab (cdr chunk)))]) - (cons (p:elem-value (car chunk)) - elem-chunk))] - [(null? chunk) - (list null)]))]) - (let out-loop ([chunks elem-chunks]) - (cond [(null? (cdr chunks)) - (apply ppict-add base (car chunks))] - [else - (slide (apply ppict-add base (car chunks))) - (out-loop (cdr chunks))])))) - -;; ---- - -(define (split-until stop? elems) - (let loop ([elems elems] [rprefix null]) - (cond [(and (pair? elems) (stop? (car elems))) - (values (reverse rprefix) elems)] - [(pair? elems) - (loop (cdr elems) (cons (car elems) rprefix))] - [(null? elems) - (values (reverse rprefix) null)]))) - -(define (ghost* x) - (if (pict? x) (ghost x) x)) +(define (pslide* who parts) + (let* ([init-go (p:go (pslide-default-placer))] + [init-pict ((pslide-base-pict))] + [gochunks + (get-gochunks who init-go (append parts (list (p:out))))]) + (let-values ([(final picts) (do-gochunks init-pict gochunks)]) + (for-each slide picts) + (void)))) ;; ---- (define-syntax (pslide stx) - - (define-splicing-syntax-class fragment - #:description "pslide fragment" - (pattern (~seq #:go pl) - #:declare pl (expr/c #'placer? #:name "argument to #:go") - #:with code #'(p:go pl.c)) - (pattern (~seq #:next) - #:with code #'(p:out)) - (pattern (~seq e) - #:declare e (expr/c #'(or/c pict? real? #f) #:name "element") - #:with code #'(p:elem e.c))) - (syntax-parse stx - [(_ p:fragment ...) - #'(pslide* p.code ...)])) - -;; ---- Example ---- - -#| -(pslide* (p:elem (t "this is the time to remember")) - (p:out) - (p:elem (t "because it will not last forever")) - (p:out) - (p:go (coord 1 0 'rt)) - (p:elem 50) - (p:elem #f) - (p:elem (t "this is the time")) - (p:elem (t "because it will"))) -|# - + [(_ p ...) + #:declare p (fragment 'pslide) + #'(pslide* 'pslide (list p.code ...))])) ;; ============================================================ ;; Exports diff --git a/collects/unstable/scribblings/gui/pslide.scrbl b/collects/unstable/scribblings/gui/pslide.scrbl index fa384c7717..9391d3f099 100644 --- a/collects/unstable/scribblings/gui/pslide.scrbl +++ b/collects/unstable/scribblings/gui/pslide.scrbl @@ -22,20 +22,20 @@ A @deftech{progressive pict} or ``ppict'' is a kind of @racket[pict] that has an associated ``pict placer,'' which generally represents a position and alignment. New picts can be placed on the progressive pict by calling @racket[ppict-add], and the placer can be updated by -calling @racket[ppict-go]. The @racket[ppict-do] function provides a +calling @racket[ppict-go]. The @racket[ppict-do] form provides a compact notation for sequences of those two operations. @examples[#:eval the-eval (define base (ppict-do (colorize (rectangle 200 200) "gray") - (coord 1/2 1/2 'cc) + #:go (coord 1/2 1/2 'cc) (colorize (hline 200 1) "gray") - (coord 1/2 1/2 'cc) + #:go (coord 1/2 1/2 'cc) (colorize (vline 1 200) "gray"))) base (define circles-down-1 (ppict-do base - (grid 2 2 1 0 'ct) + #:go (grid 2 2 1 0 'ct) 10 (circle 20) (circle 20) @@ -58,14 +58,28 @@ Returns @racket[#t] if @racket[x] is a @tech{progressive pict}, @racket[#f] otherwise. } -@defproc[(ppict-do [p pict?] - [cmd (or/c pict? real? #f placer?)] ...) - pict?]{ +@deftogether[[ +@defform[(ppict-do base-expr ppict-do-fragment ...)] +@defform/subs[(ppict-do* base-expr do-fragment ...) + ([ppict-do-fragment (code:line #:go placer-expr) + (code:line #:next) + (code:line elem-expr)]) + #:contracts ([base-expr pict?] + [placer-expr placer?] + [elem-expr (or/c pict? real? #f)])]]]{ -Starting with @racket[p], applies @racket[ppict-go] for every -@racket[cmd] that is a placer and @racket[ppict-add] for every -sequence of @racket[cmd]s that are picts, real numbers, and -@racket[#f]. +Starting with @racket[base-expr], applies @racket[ppict-go] for every +@racket[#:go] directive and @racket[ppict-add] for every sequence of +@racket[elem-expr]s. If @racket[base-expr] is not a @tech{progressive +pict}, a use of @racket[#:go] must precede the first +@racket[elem-expr]. The @racket[#:next] directive saves a pict +including only the contents emitted so far (but whose alignment takes +into account picts yet to come). + +The @racket[ppict-do] form returns only the final pict; any uses of +@racket[#:next] are ignored. The @racket[ppict-do*] form returns two +values: the final pict and a list of all partial picts emitted due to +@racket[#:next] (the final pict is not included). A spacing change, represented by a real number, only affects added picts up until the next placer is installed; when a placer is @@ -74,9 +88,9 @@ installed, the spacing is reset to @racket[0]. For example, the following code @racketblock[ (ppict-do (colorize (rectangle 200 200) "gray") - (coord 1/2 1/2 'cc) + #:go (coord 1/2 1/2 'cc) (colorize (hline 200 1) "gray") - (coord 1/2 1/2 'cc) + #:go (coord 1/2 1/2 'cc) (colorize (vline 1 200) "gray")) ] is equivalent to @@ -89,6 +103,7 @@ is equivalent to pp) ] } +} @defproc[(ppict-go [p pict?] [pl placer?]) ppict?]{ @@ -149,17 +164,17 @@ another progressive pict only if @examples[#:eval the-eval (ppict-do base - (coord 1/3 3/4 'cc) + #:go (coord 1/3 3/4 'cc) (circle 20)) (ppict-do base - (coord 1 0 'rt) + #:go (coord 1 0 'rt) 50 (code:comment "change spacing") (text "abc") (text "12345") 0 (code:comment "and again") (text "ok done")) (ppict-do base - (coord 0 0 'lt #:compose ht-append) + #:go (coord 0 0 'lt #:compose ht-append) (circle 10) (circle 20) (circle 30)) @@ -186,12 +201,12 @@ but @racket[(grid 2 2 0 0 'rt)] is equivalent to @racket[(coord 1/2 0 'rt)]. @examples[#:eval the-eval (define none-for-me-thanks (ppict-do base - (grid 2 2 0 0 'lt) + #:go (grid 2 2 0 0 'lt) (text "You do not like") (colorize (text "green eggs and ham?") "darkgreen"))) none-for-me-thanks (ppict-do none-for-me-thanks - (grid 2 2 1 0 'rb) + #:go (grid 2 2 1 0 'rb) (colorize (text "I do not like them,") "red") (text "Sam-I-am.")) ] @@ -209,11 +224,15 @@ none-for-me-thanks #:contracts ([placer-expr placer?] [elem-expr (or/c pict? real? #f)])]{ -Constructs a slide using the @tech{progressive pict} mechanism. A -@racket[#:go] directive updates the current placer; a @racket[#:next] -directive causes a slide to be emitted with the contents thus far (but -whose alignment takes into account contents yet to be added); and -other elements have the same meaning as in @racket[ppict-add]. +Produce slide(s) using @tech{progressive picts}. A @racket[#:go] +directive updates the current placer; a @racket[#:next] directive +causes a slide to be emitted with the contents thus far (but whose +alignment takes into account contents yet to be added); and other +elements have the same meaning as in @racket[ppict-add]. + +Note that like @racket[slide] but unlike @racket[ppict-do*], the +number of slides produced is one greater than the number of +@racket[#:next] uses; a slide is created for the final pict. Remember to include @racket[gap-size] after updating the current placer if you want @racket[slide]-like spacing. @@ -226,28 +245,32 @@ placer if you want @racket[slide]-like spacing. #:go (coord 1 1 'rb) (colorize (t "I do not like them,") "red") (t "Sam-I-am.")) - (let* ([slide1 - (ppict-do (colorize (filled-rectangle 200 150) "white") - (coord 1/20 1/20 'lt) ;; for margins - (text "You do not like") - (colorize (text "green eggs and ham?") - "darkgreen"))] - [slide2 - (ppict-do slide1 - (coord 19/20 19/20 'rb) ;; for margins - (colorize (text "I do not like them,") "red") - (text "Sam-I-am."))] - [slides - (inset - (vl-append -5 - (colorize (text "slides" '(bold . roman)) "white") - (inset (hc-append 20 slide1 slide2) 15)) - 5)]) - (cc-superimpose - (colorize (filled-rectangle (pict-width slides) (pict-height slides)) - "darkgray") - slides))) + (let-values ([(final slides0) + (ppict-do* (colorize (filled-rectangle 200 150) "white") + #:go (coord 1/20 1/20 'lt) ;; for margins + (text "You do not like") + (colorize (text "green eggs and ham?") + "darkgreen") + #:next + #:go (coord 19/20 19/20 'rb) ;; for margins + (colorize (text "I do not like them,") "red") + (text "Sam-I-am.") + #:next)]) + (let ([slides + (inset + (vl-append -10 + (colorize (text "slides" '(bold . roman)) "white") + (inset (apply hc-append 20 slides0) 15)) + 5)]) + (cc-superimpose + (colorize (filled-rectangle (pict-width slides) (pict-height slides)) + "darkgray") + slides)))) ] + +Note that the text is not flush against the sides of the slide, +because @racket[pslide] uses a base pict the size of the client +area, excluding the margins. } @defparam[pslide-base-pict make-base-pict (-> pict)]{