diff --git a/collects/unstable/gui/ppict.rkt b/collects/unstable/gui/ppict.rkt index 1d8da4cf67..f342d82aa1 100644 --- a/collects/unstable/gui/ppict.rkt +++ b/collects/unstable/gui/ppict.rkt @@ -41,8 +41,13 @@ [ppict-add (->* (ppict?) () - #:rest (listof (or/c pict? real? #f)) + #:rest (listof (or/c pict? real? #f 'next)) pict?)] + [ppict-add* + (->* (ppict?) + () + #:rest (listof (or/c pict? real? #f 'next)) + (values pict? (listof pict?)))] [ppict-placer (-> ppict? placer?)] [coord diff --git a/collects/unstable/gui/private/ppict-syntax.rkt b/collects/unstable/gui/private/ppict-syntax.rkt index 7f64bb2a34..13cd00bec6 100644 --- a/collects/unstable/gui/private/ppict-syntax.rkt +++ b/collects/unstable/gui/private/ppict-syntax.rkt @@ -23,11 +23,11 @@ (pattern (p ...+ . fs) #:with code #`(let*-values ([(#,xp-var picts) - (internal-ppict-do '#,who #,xp-var - (syntax-parameterize - ([ppict-do-state - (make-rename-transformer #'#,xp-var)]) - (list p.code ...)))] + (ppict-add/internal '#,who #,xp-var + (syntax-parameterize + ([ppict-do-state + (make-rename-transformer #'#,xp-var)]) + (list p.code ...)))] [(#,rpss-var) (cons picts #,rpss-var)]) fs.code)) diff --git a/collects/unstable/gui/private/ppict.rkt b/collects/unstable/gui/private/ppict.rkt index 89b65d6409..5c3db95ce0 100644 --- a/collects/unstable/gui/private/ppict.rkt +++ b/collects/unstable/gui/private/ppict.rkt @@ -43,10 +43,9 @@ In a placer function's arguments: ;; ---- -;; ppict-add : ppict (U pict real #f) ... -> ppict -(define (ppict-add dp . picts) - (let ([pl (ppict-placer dp)]) - (send pl place (ppict-pict dp) picts))) +(define-syntax-parameter ppict-do-state + (lambda (stx) + (raise-syntax-error #f "used out of context" stx))) ;; ppict-go : pict placer -> ppict (define (ppict-go dp pl) @@ -55,6 +54,45 @@ In a placer function's arguments: [(pict? dp) (mk-ppict dp pl)])) +;; ppict-add : ppict (U pict real #f 'next) ... -> ppict +(define (ppict-add dp . parts) + (let-values ([(final intermediates) + (ppict-add/internal 'ppict-add dp parts)]) + final)) + +;; ppict-add* : ppict (U pict real #f 'next) ... -> (values ppict (listof pict)) +(define (ppict-add* dp . parts) + (ppict-add/internal 'ppict-add* dp parts)) + +;; ppict-add/internal : symbol pict (listof (U pict real #f 'next)) +;; -> (values pict (listof pict) +;; In second return value, one pict per 'next occurrence. +;; FIXME: avoid applying ghost to previously ghosted pict? +(define (ppict-add/internal who base parts) + (unless (ppict? base) (error who "missing placer")) + (let ([placer (ppict-placer base)] + [base-pict (ppict-pict base)] + [elem-chunks + ;; (listof (listof pict?)) + ;; length is N+1, where N is number of 'next in chunk + ;; ghosted before visible + (let elab ([chunk parts]) + (cond [(and (pair? chunk) (eq? 'next (car chunk))) + (let ([elab-rest (elab (cdr chunk))]) + (cons (map ghost* (car elab-rest)) elab-rest))] + [(and (pair? chunk) (not (eq? 'next (car chunk)))) + (for/list ([elem-chunk (in-list (elab (cdr chunk)))]) + (cons (car chunk) elem-chunk))] + [(null? chunk) (list null)]))]) + (let out-loop ([chunks elem-chunks] [rpicts null]) + (cond [(null? (cdr chunks)) + (values (send placer place base-pict (car chunks)) + (reverse rpicts))] + [else + (out-loop (cdr chunks) + (cons (send placer place base-pict (car chunks)) + rpicts))])))) + ;; ---- (define (placer? x) (is-a? x placer<%>)) @@ -292,46 +330,6 @@ In a placer function's arguments: ;; ---- -(define-syntax-parameter ppict-do-state - (lambda (stx) - (raise-syntax-error #f "used out of context" stx))) - -;; internal-ppict-do : pict (listof (U pict real #f 'next)) -;; -> (values pict (listof pict)) -(define (internal-ppict-do who base parts) - (unless (ppict? base) - (error who "missing placer")) - (do-chunk base parts)) - -;; ---- - -;; A chunk is (listof (U pict real #f 'next)) - -;; do-chunk : ppict (listof (U pict real #f 'next)) -> (values ppict (listof pict)) -;; In second return value, one pict per 'next 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 'next in chunk - ;; ghosted before visible - (let elab ([chunk chunk]) - (cond [(and (pair? chunk) (eq? 'next (car chunk))) - (let ([elab-rest (elab (cdr chunk))]) - (cons (map ghost* (car elab-rest)) elab-rest))] - [(and (pair? chunk) (not (eq? 'next (car chunk)))) - (for/list ([elem-chunk (in-list (elab (cdr chunk)))]) - (cons (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 (ghost* x) (if (pict? x) (ghost x) x)) diff --git a/collects/unstable/scribblings/gui/pslide.scrbl b/collects/unstable/scribblings/gui/pslide.scrbl index acf46baf09..274aa13354 100644 --- a/collects/unstable/scribblings/gui/pslide.scrbl +++ b/collects/unstable/scribblings/gui/pslide.scrbl @@ -143,13 +143,21 @@ Creates a @tech{progressive pict} with the given base pict @racket[p] and the placer @racket[pl]. } +@deftogether[[ @defproc[(ppict-add [pp ppict?] - [elem (or/c pict? real? #f)] ...) - pict?]{ + [elem (or/c pict? real? #f 'next)] ...) + pict?] +@defproc[(ppict-add* [pp ppict?] + [elem (or/c pict? real? #f 'next)] ...) + (values pict? (listof pict?))]]]{ Creates a new pict by adding each @racket[elem] pict on top of @racket[pp] according to @racket[pp]'s placer. The result pict may or -may not be a @tech{progressive pict}, depending on the placer used. +may not be a @tech{progressive pict}, depending on the placer +used. The @racket[ppict-add] function only the final pict; any +occurrences of @racket['next] are ignored. The @racket[ppict-add*] +function returns two values: the final pict and a list of all partial +picts emitted due to @racket['next] (the final pict is not included). An @racket[elem] that is a real number changes the spacing for subsequent additions. A @racket[elem] that is @racket[#f] is