suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

unstable/gui/ppict: add ppict-add*

Browse Source
This commit is contained in:
Ryan Culpepper 2011-07-16 01:05:23 -06:00
parent c06db14bfd
commit deb8c222d8
4 changed files with 64 additions and 53 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
collects/unstable/gui/ppict.rkt
View File

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

10
collects/unstable/gui/private/ppict-syntax.rkt
View File

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

86
collects/unstable/gui/private/ppict.rkt
View File

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

14
collects/unstable/scribblings/gui/pslide.scrbl
View File

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