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

unstable/gui/ppict:

Browse Source 
added #:set, #:alt to ppict-do
  added ppict-do-state
  added at-find-pict
  added tag-pict
  updated to slideshow changes
  changed placer rep, added merge-refpoints
This commit is contained in:
Ryan Culpepper 2011-07-04 08:49:20 -06:00
parent 1f7165df16
commit a34821ea4f
5 changed files with 490 additions and 259 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,5 +1,6 @@
#lang racket/base
(require (for-syntax racket/base
racket/syntax
syntax/parse
syntax/parse/experimental/contract
"private/ppict-syntax.rkt")
@ -7,29 +8,32 @@
slideshow/pict
"private/ppict.rkt")
(define-syntax (ppict-do stx)
(define-for-syntax (ppict-do*-transformer who stx)
(syntax-parse stx
[(_ base p ...)
[(_ base . fs)
#: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)]))
#:declare fs (fragment-sequence who #'xp #'rpss)
#'(let ([xp base.c] [rpss null])
fs.code)]))
(define-syntax (ppict-do stx)
#`(let-values ([(final _picts)
#,(ppict-do*-transformer 'ppict-do stx)])
final))
(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*-transformer 'ppict-do* stx))
;; ----
(provide ppict-do
ppict-do*)
ppict-do*
ppict-do-state)
(provide ppict?
placer?)
placer?
refpoint-placer?
tag-path?)
(provide/contract
[ppict-go
@ -41,15 +45,13 @@
pict?)]
[ppict-placer
(-> ppict? placer?)]
[placer
(-> any/c boolean?)]
[coord
(->* (real? real?)
(align/c
#:abs-x real?
#:abs-y real?
#:compose procedure?)
placer?)]
refpoint-placer?)]
[grid
(->* (exact-positive-integer? exact-positive-integer?
exact-integer? exact-integer?)
@ -57,8 +59,26 @@
#:abs-x real?
#:abs-y real?
#:compose procedure?)
placer?)]
refpoint-placer?)]
[cascade
(->* ()
((or/c real? 'auto) (or/c real? 'auto))
placer?)])
placer?)]
[at-find-pict
(->* ((or/c tag-path? pict-path?))
(procedure?
align/c
#:abs-x real?
#:abs-y real?
#:compose procedure?)
refpoint-placer?)]
[merge-refpoints
(-> refpoint-placer? refpoint-placer?
refpoint-placer?)]
[tag-pict
(-> pict? symbol? pict?)]
[pict-tag
(-> pict? (or/c symbol? #f))]
[find-tag
(-> pict? tag-path? (or/c pict-path? #f))])

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

@ -2,17 +2,107 @@
(require syntax/parse syntax/parse/experimental/contract
(for-template racket/base
racket/contract
racket/stxparam
slideshow/pict
"ppict.rkt"))
(provide fragment)
(provide fragment-sequence)
(define-splicing-syntax-class (fragment who)
#:description (format "~a fragment" who)
(define-syntax-class (fragment-sequence who xp-var rpss-var)
#:commit
#:local-conventions ([p (elem who)]
#|[b (bind-fragment who)]|#
[g (go-fragment who)]
[s (set-fragment who)]
[a (alt-fragment who)]
[fs (fragment-sequence who xp-var rpss-var)]
[pl (expr/c #'placer? #:name "argument to #:go")])
(pattern ()
#:with code
#`(values #,xp-var
(apply append (reverse #,rpss-var))))
(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 ...)))]
[(#,rpss-var)
(cons picts #,rpss-var)])
fs.code))
(pattern (g . fs)
#:with code
#`(let-values ([(#,xp-var)
(syntax-parameterize ([ppict-do-state
(make-rename-transformer #'#,xp-var)])
(ppict-go #,xp-var g.placer))])
fs.code))
#|
(pattern (b . fs)
#:with code
#`(let*-values ([(b.var ...)
(syntax-parameterize ([ppict-do-state
(make-rename-transformer #'#,xp-var)])
b.rhs)])
fs.code))
|#
(pattern (s . fs)
#:with code
#`(let*-values ([(#,xp-var picts)
(let ([pict-or-fun
(syntax-parameterize ([ppict-do-state
(make-rename-transformer #'#,xp-var)])
s.p)])
(if (pict? pict-or-fun)
(values pict-or-fun null)
(pict-or-fun)))]
[(#,rpss-var) (cons picts #,rpss-var)])
fs.code))
(pattern (a . fs)
#:with code
#`(let*-values ([(alt-final alt-picts) (a.code #,xp-var)]
[(#,rpss-var) (cons (append alt-picts (list alt-final)) #,rpss-var)])
;; Note: fs.code continues with new rpss-var (shadowed), old xp-var
fs.code)))
(define-splicing-syntax-class (go-fragment who)
#:description "#:go fragment"
(pattern (~seq #:go pl)
#:declare pl (expr/c #'placer? #:name "argument to #:go")
#:with code #'(p:go pl.c))
#:declare pl (expr/c #'placer? #:name "placer argument of #:go fragment")
#:with placer #'pl.c))
#|
(define-splicing-syntax-class (bind-fragment who)
#:description "#:bind fragment"
(pattern (~seq #:bind vs:var/vars rhs:expr)
#:with (var ...) #'(vs.var ...)))
|#
(define-splicing-syntax-class (set-fragment who)
#:description "#:set fragment"
(pattern (~seq #:set p0)
#:declare p0 (expr/c #'(or/c pict? (-> (values pict? (listof pict?))))
#:name "argument of #:set fragment")
#:with p #'p0.c))
(define-splicing-syntax-class (alt-fragment who)
#:description "#:alt fragment"
(pattern (~seq #:alt altfs)
#:declare altfs (fragment-sequence who #'alt-xp #'alt-rpss)
#:with code
#'(lambda (alt-xp) (let ([alt-rpss null]) altfs.code))))
(define-splicing-syntax-class (elem who)
#:description "element fragment"
(pattern (~seq #:next)
#:with code #'(p:out))
#:with code #''next)
(pattern (~seq e)
#:declare e (expr/c #'(or/c pict? real? #f) #:name "element")
#:with code #'(p:elem e.c)))
#:with code #'e.c))
(define-syntax-class var/vars
#:description "variable or sequence of variables"
(pattern var1:id
#:with (var ...) #'(var1))
(pattern (var:id ...)))

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

@ -1,14 +1,13 @@
#lang racket/base
(require racket/list
(require (for-syntax racket/base)
racket/list
racket/class
racket/stxparam
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
|#
@ -24,7 +23,6 @@ In a placer function's arguments:
FIXME: clarify, for following or including current gap?
|#
(struct ppict pict (placer))
(struct placer (fun))
(define (mk-ppict p placer)
(ppict (pict-draw p)
@ -32,7 +30,7 @@ In a placer function's arguments:
(pict-height p)
(pict-ascent p)
(pict-descent p)
(list (make-child p 0 0 1 1))
(list (make-child p 0 0 1 1 0 0))
#f
(pict-last p)
placer))
@ -45,7 +43,7 @@ In a placer function's arguments:
;; 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)))
(send pl place (ppict-pict dp) picts)))
;; ppict-go : pict placer -> ppict
(define (ppict-go dp pl)
@ -56,88 +54,150 @@ In a placer function's arguments:
;; ----
(define (placer? x) (is-a? x placer<%>))
(define (refpoint-placer? x) (is-a? x refpoint%))
(define (merge-refpoints x y)
(send x take-y-from y))
(define placer<%>
(interface ()
;; place : pict (listof (U pict real #f)) -> pict
place))
(define refpoint%
(class* object% (placer<%>)
(init-field xa ya depxy halign valign compose
[sep 0]
[cont? #f])
(super-new)
(define/public (place scene picts)
(define-values (dx dy)
(let-values ([(depx depy) (if depxy (depxy scene) (values 0 0))])
(values (+ depx xa)
(+ depy ya))))
(define-values (newpict newsep)
(apply-compose compose sep (cons (and cont? (blank 0)) picts)))
(define newpict-w (pict-width newpict))
(define newpict-h (pict-height newpict))
(define newscene
(let ([localrefx (* newpict-w (align->frac halign))]
[localrefy (* newpict-h (align->frac valign))])
(pin-over scene (- dx localrefx) (- dy localrefy) newpict)))
(cond [(and (eq? valign 't) (eq? compose (halign->vcompose halign)))
;; ie, going top-down and compose is the natural compose for this align
(mk-ppict newscene
(new refpoint%
(xa dx) (ya (+ dy newpict-h)) (depxy #f)
(halign halign) (valign valign)
(compose compose) (sep newsep) (cont? #t)))]
[(and (eq? halign 'l) (eq? compose (valign->hcompose valign)))
;; ie, going left-right and compose is the natural compose ...
(mk-ppict newscene
(new refpoint%
(xa (+ dx newpict-w)) (ya dy) (depxy #f)
(halign halign) (valign valign)
(compose compose) (sep newsep) (cont? #t)))]
[else newscene]))
(define/public (take-y-from other)
(new refpoint%
(xa xa)
(ya (get-field ya other))
(depxy (let ([odepxy (get-field depxy other)])
(lambda (base)
(let-values ([(x _y) (if depxy (depxy base) (values 0 0))]
[(_x y) (if odepxy (odepxy base) (values 0 0))])
(values x y)))))
(halign halign)
(valign valign)
(compose compose)
(sep sep)
(cont? cont?)))))
;; --
(define (grid cols rows col row [align 'cc]
#:abs-x [abs-x 0]
#:abs-y [abs-y 0]
#:compose [compose (halign->vcompose (align->h align))]
#:sep [sep 0])
#:compose [compose (halign->vcompose (align->h align))])
;; row, column indexes are 1-based
(define halign (align->h align))
(define valign (align->v align))
(define xfrac (/ (+ (sub1 col) (align->frac halign)) cols))
(define yfrac (/ (+ (sub1 row) (align->frac valign)) rows))
(refpoint* xfrac yfrac abs-x abs-y halign valign compose sep #f))
(new refpoint%
(xa abs-x) (ya abs-y)
(depxy (lambda (p)
(values (* xfrac (pict-width p))
(* yfrac (pict-height p)))))
(halign halign) (valign valign) (compose compose)))
(define (coord xfrac yfrac [align 'cc]
#:abs-x [abs-x 0]
#:abs-y [abs-y 0]
#:compose [compose (halign->vcompose (align->h align))]
#:sep [sep 0]
#:internal:skip [skip #f])
#:compose [compose (halign->vcompose (align->h align))])
(define halign (align->h align))
(define valign (align->v align))
(refpoint* xfrac yfrac abs-x abs-y halign valign compose sep #f))
(define (refpoint* xfrac yfrac dxabs dyabs
halign valign compose sep continued?)
(placer
(lambda (scene picts)
(define scene-w (pict-width scene))
(define scene-h (pict-height scene))
(define dx (+ (* scene-w xfrac) dxabs))
(define dy (+ (* scene-h yfrac) dyabs))
(define-values (newpict newsep)
(apply-compose compose sep (cons (and continued? (blank 0)) picts)))
(define newpict-w (pict-width newpict))
(define newpict-h (pict-height newpict))
(define newscene
(let ([localrefx (* newpict-w (align->frac halign))]
[localrefy (* newpict-h (align->frac valign))])
(lt-superimpose scene (inset newpict (- dx localrefx) (- dy localrefy) 0 0))))
(let ([result-pict (refocus newscene scene)])
(cond [(and (eq? valign 't) (eq? compose (halign->vcompose halign)))
;; ie, going top-down and compose is the natural compose for this align
(mk-ppict result-pict
(refpoint* 0 0 dx (+ dy newpict-h)
halign valign compose newsep #t))]
[(and (eq? halign 'l) (eq? compose (valign->hcompose valign)))
;; ie, going left-right and compose is the natural compose ...
(mk-ppict result-pict
(refpoint* 0 0 (+ dx newpict-w) dy
halign valign compose newsep #t))]
[else result-pict])))))
(new refpoint%
(xa abs-x) (ya abs-y)
(depxy (lambda (p)
(values (* xfrac (pict-width p))
(* yfrac (pict-height p)))))
(halign halign) (valign valign) (compose compose)))
;; ----
;; cascade : -> placer
(define cascade%
(class* object% (placer<%>)
(init-field step-x0 step-y0)
(super-new)
(define/public (place scene elems)
(for/or ([e (in-list elems)])
(when (real? e)
(error 'cascade "spacing changes not allowed: ~e" e)))
(let* ([picts (filter pict? elems)]
[max-w (apply max 1 (map pict-width picts))] ;; avoid 0
[max-h (apply max 1 (map pict-height picts))] ;; avoid 0
[auto-step-x (/ (- (pict-width scene) max-w) (+ 1 (length picts)))]
[auto-step-y (/ (- (pict-height scene) max-h) (+ 1 (length picts)))]
[step-x (if (eq? step-x0 'auto) auto-step-x step-x0)]
[step-y (if (eq? step-y0 'auto) auto-step-y step-y0)]
[bbox (blank max-w max-h)]
[newscene
(for/fold ([scene scene])
([pict (in-list picts)]
[i (in-naturals 1)])
(pin-over scene (* i step-x) (* i step-y) (cc-superimpose bbox pict)))])
;; Can't continue a cascade, since depends on number of picts.
;; FIXME: If step is given rather than computed, then we can.
newscene))))
;; cascade : ... -> placer
(define (cascade [step-x0 'auto] [step-y0 'auto])
;; Auto cascade by largest bounding box.
;; FIXME: add align arg, determines position of each pict w/in bbox
(placer
(lambda (scene elems)
(for/or ([e (in-list elems)])
(when (real? e)
(error 'cascade "spacing changes not allowed: ~e" e)))
(let* ([picts (filter pict? elems)]
[max-w (apply max 1 (map pict-width picts))] ;; avoid 0
[max-h (apply max 1 (map pict-height picts))] ;; avoid 0
[auto-step-x (/ (- (pict-width scene) max-w) (+ 1 (length picts)))]
[auto-step-y (/ (- (pict-height scene) max-h) (+ 1 (length picts)))]
[step-x (if (eq? step-x0 'auto) auto-step-x step-x0)]
[step-y (if (eq? step-y0 'auto) auto-step-y step-y0)]
[bbox (blank max-w max-h)]
[positioned-picts
(for/list ([pict (in-list picts)]
[i (in-naturals 1)])
(inset (cc-superimpose bbox pict)
(* i step-x) (* i step-y) 0 0))]
[newscene
(lt-superimpose scene
(apply lt-superimpose positioned-picts))]
[result-pict (refocus newscene scene)])
;; Can't continue a cascade, since depends on number of picts.
;; FIXME: If step is given rather than computed, then we can.
result-pict))))
(new cascade% (step-x0 step-x0) (step-y0 step-y0)))
;; at-find-pict : ... -> placer
(define (at-find-pict path
[find cc-find]
[align 'cc]
#:abs-x [abs-x 0]
#:abs-y [abs-y 0]
#:compose [compose (halign->vcompose (align->h align))])
(define halign (align->h align))
(define valign (align->v align))
(new refpoint%
(xa abs-x) (ya abs-y)
(depxy (lambda (p)
(let ([pict-path (if (tag-path? path) (find-tag p path) path)])
(unless pict-path
(error 'at-find-path "failed finding ~e" path))
(find p pict-path))))
(halign halign) (valign valign) (compose compose)))
;; ----
@ -196,97 +256,37 @@ In a placer function's arguments:
;; ----
#|
(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)]))))
|#
(define-syntax-parameter ppict-do-state
(lambda (stx)
(raise-syntax-error #f "used out of context" stx)))
;; ----
(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))
;; internal-ppict-do : pict (listof (U pict real #f 'next))
;; -> (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)))
(unless (ppict? base)
(error who "missing placer"))
(do-chunk base parts))
;; ----
;; A gochunk is (cons p:go (listof (U p:elem p:next)))
;; A chunk is (listof (U pict real #f '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.
;; 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 (p:out) in chunk
;; length is N+1, where N is number of 'next in chunk
;; ghosted before visible
(let elab ([chunk chunk])
(cond [(and (pair? chunk) (p:out? (car 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) (p:elem? (car 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 (p:elem-value (car chunk))
elem-chunk))]
[(null? chunk)
(list null)]))])
(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))
@ -296,20 +296,52 @@ In a placer function's arguments:
(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))
;; ============================================================
;; Tagged picts
(struct tagged-pict pict (tag))
;; tag is symbol
(define (tag-pict p tg)
(tagged-pict (pict-draw p)
(pict-width p)
(pict-height p)
(pict-ascent p)
(pict-descent p)
(list (make-child p 0 0 1 1 0 0))
#f
(pict-last p)
tg))
;; find-tag : pict tag-path -> pict-path
(define (find-tag p tagpath)
(let ([tagpath (if (symbol? tagpath) (list tagpath) tagpath)])
(define (loop p tagpath)
(cond [(pair? tagpath)
(childrenloop (pict-children p) tagpath)]
[(null? tagpath)
(list p)]))
(define (pairloop p tagpath)
(or (and (tagged-pict? p)
(eq? (tagged-pict-tag p) (car tagpath))
(let ([r (loop p (cdr tagpath))])
(and r (cons p r))))
(childrenloop (pict-children p) tagpath)))
(define (childrenloop children tagpath)
(for/or ([c (in-list children)])
(pairloop (child-pict c) tagpath)))
(loop p tagpath)))
(define (tag-path? x)
(or (symbol? x)
(and (list? x) (pair? x) (andmap symbol? x))))
(define (pict-tag p)
(and (tagged-pict? p) (tagged-pict-tag p)))
;; ============================================================
;; Exports

23
collects/unstable/gui/pslide.rkt
View File

@ -19,23 +19,26 @@
(define pslide-default-placer
(make-parameter (coord 1/2 1/2 'cc)))
;; pslide* : (U p:elem p:out p:go) ... -> void
(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)])
;; pslide* : symbol (pict -> (values pict (listof pict)) -> void
(define (pslide* who proc)
(let* ([init-pict ((pslide-base-pict))]
[init-placer (pslide-default-placer)])
(let-values ([(final picts)
(proc (ppict-go init-pict init-placer))])
(for-each slide picts)
(slide final)
(void))))
;; ----
(define-syntax (pslide stx)
(syntax-parse stx
[(_ p ...)
#:declare p (fragment 'pslide)
#'(pslide* 'pslide (list p.code ...))]))
[(_ . fs)
#:declare fs (fragment-sequence 'pslide #'xp #'rpss)
#'(pslide* 'pslide
(lambda (xp)
(let ([rpss null])
fs.code)))]))
;; ============================================================
;; Exports

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

@ -25,6 +25,45 @@ pict by calling @racket[ppict-add], and the placer can be updated by
calling @racket[ppict-go]. The @racket[ppict-do] form provides a
compact notation for sequences of those two operations.
@deftogether[[
@defform[(ppict-do base-expr ppict-do-fragment ...)]
@defform/subs[(ppict-do* base-expr ppic-do-fragment ...)
([ppict-do-fragment (code:line #:go placer-expr)
(code:line #:set pict-expr)
(code:line #:next)
(code:line #:alt (ppict-do-fragment ...))
(code:line elem-expr)])
#:contracts ([base-expr pict?]
[placer-expr placer?]
[pict-expr pict?]
[elem-expr (or/c pict? real? #f)])]]]{
Builds a pict (and optionally a list of intermediate picts)
progressively. 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 @racket[#:go] fragment changes the current placer. A @racket[#:set]
fragment replaces the current pict state altogether with a new
computed pict. A @racket[#:next] fragment saves a pict including only
the contents emitted so far (but whose alignment takes into account
picts yet to come). A @racket[#:alt] fragment saves the current pict
state, executes the sub-sequence that follows, saves the result (as if
the sub-sequence ended with @racket[#:next]), then restores the saved
pict state before continuing.
The @racket[elem-expr]s are interpreted by the current placer. A
numeric @racket[elem-expr] usually represents a spacing change, but
some placers do not support them. A spacing change only affects added
picts up until the next placer is installed; when a new placer is
installed, the spacing is reset, usually to @racket[0].
The @racket[ppict-do-state] form tracks the current state of the
pict. It is updated before a @racket[#:go] or @racket[#:set] fragment
or before a sequence of @racket[elem-expr]s. It is not updated in the
middle of a chain of @racket[elem-expr]s, however.
@examples[#:eval the-eval
(define base
(ppict-do (colorize (rectangle 200 200) "gray")
@ -33,6 +72,19 @@ compact notation for sequences of those two operations.
#:go (coord 1/2 1/2 'cc)
(colorize (vline 1 200) "gray")))
base
]
The use of @racket[ppict-do] in the defnition of @racket[base] above
is equivalent to
@racketblock[
(let* ([pp (colorize (rectangle 200 200) "gray")]
[pp (ppict-go pp (coord 1/2 1/2 'cc))]
[pp (ppict-add pp (colorize (hline 200 1) "gray"))]
[pp (ppict-go pp (coord 1/2 1/2 'cc))]
[pp (ppict-add pp (colorize (vline 1 200) "gray"))])
pp)
]
@examples[#:eval the-eval
(define circles-down-1
(ppict-do base
#:go (grid 2 2 2 1 'ct)
@ -49,8 +101,35 @@ circles-down-1
(colorize (circle 20) "red")))
(code:line (inset circles-down-2 20) (code:comment "draws outside its bounding box"))
(inset (clip circles-down-2) 20)
(ppict-do base
#:go (coord 0 0 'lt)
(tag-pict (circle 20) 'circA)
#:go (coord 1 1 'rb)
(tag-pict (circle 20) 'circB)
#:set (let ([p ppict-do-state])
(pin-arrow-line 10 p
(find-tag p 'circA) rb-find
(find-tag p 'circB) lt-find)))
(let-values ([(final intermediates)
(ppict-do* base
#:go (coord 1/4 1/2 'cb)
(text "shapes:")
#:go (coord 1/2 1/2 'lb)
#:alt [(circle 20)]
#:alt [(rectangle 20 20)]
(text "and more!"))])
(append intermediates (list final)))
]
More examples of @racket[ppict-do] are scattered throughout this
section.
}
@defidform[ppict-do-state]{
Tracks the current state of a @racket[ppict-do] or @racket[ppict-do*]
form.
}
@defproc[(ppict? [x any/c]) boolean?]{
@ -58,53 +137,6 @@ Returns @racket[#t] if @racket[x] is a @tech{progressive pict},
@racket[#f] otherwise.
}
@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[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
installed, the spacing is reset to @racket[0].
For example, the following code
@racketblock[
(ppict-do (colorize (rectangle 200 200) "gray")
#:go (coord 1/2 1/2 'cc)
(colorize (hline 200 1) "gray")
#:go (coord 1/2 1/2 'cc)
(colorize (vline 1 200) "gray"))
]
is equivalent to
@racketblock[
(let ([pp (colorize (rectangle 200 200) "gray")]
[pp (ppict-go pp (coord 1/2 1/2 'cc))]
[pp (ppict-add pp (colorize (hline 200 1) "gray"))]
[pp (ppict-go pp (coord 1/2 1/2 'cc))]
[pp (ppict-add pp (colorize (vline 1 200) "gray"))])
pp)
]
}
}
@defproc[(ppict-go [p pict?] [pl placer?]) ppict?]{
Creates a @tech{progressive pict} with the given base pict @racket[p]
@ -132,13 +164,19 @@ around it.
Returns @racket[#t] if @racket[x] is a placer, @racket[#f] otherwise.
}
@defproc[(refpoint-placer? [x any/c]) boolean?]{
Returns @racket[#t] if @racket[x] is a placer based on a reference
point, @racket[#f] otherwise.
}
@defproc[(coord [rel-x real?]
[rel-y real?]
[align (or/c 'lt 'ct 'rt 'lc 'cc 'rc 'lb 'cb 'rb) 'cc]
[#:abs-x abs-x real? 0]
[#:abs-y abs-y real? 0]
[#:compose composer procedure? #, @elem{computed from @racket[align]}])
placer?]{
refpoint-placer?]{
Returns a placer that places picts according to @racket[rel-x] and
@racket[rel-y], which are interpeted as fractions of the width and
@ -162,11 +200,6 @@ default @racket[composer] is @racket[vc-append]; for @racket['lt], the
default @racket[composer] is @racket[vl-append]. The spacing is
initially @racket[0].
@;{
The result of @racket[ppict-add] using a @racket[coord] placer is
another progressive pict only if
}
@examples[#:eval the-eval
(ppict-do base
#:go (coord 1/2 1/2 'rb)
@ -196,7 +229,7 @@ another progressive pict only if
[#:abs-x abs-x real? 0]
[#:abs-y abs-y real? 0]
[#:compose composer procedure? #, @elem{computed from @racket[align]}])
placer?]{
refpoint-placer?]{
Returns a placer that places picts according to a position in a
virtual grid. The @racket[row] and @racket[col] indexes are numbered
@ -255,27 +288,80 @@ spacing between the last pict and the base.
]
}
@defproc[(at-find-pict [find-path (or/c tag-path? pict-path?)]
[finder procedure? cc-find]
[align (or/c 'lt 'ct 'rt 'lc 'cc 'rc 'lb 'cb 'rb) 'cc]
[#:abs-x abs-x real? 0]
[#:abs-y abs-y real? 0]
[#:compose composer procedure? #, @elem{computed from @racket[align]}])
refpoint-placer?]{
Returns a placer that places picts according to a reference point
based on an existing pict within the base.
@examples[#:eval the-eval
(ppict-do base
#:go (cascade)
(tag-pict (standard-fish 40 20 #:direction 'right #:color "red") 'red-fish)
(tag-pict (standard-fish 50 30 #:direction 'left #:color "blue") 'blue-fish)
#:go (at-find-pict 'red-fish rc-find 'lc #:abs-x 10)
(text "red fish"))
]
}
@defproc[(merge-refpoints [x-placer refpoint-placer?]
[y-placer refpoint-placer?])
refpoint-placer?]{
Returns a placer like @racket[x-placer] except that the y-coordinate of its
reference point is computed by @racket[y-placer].
@examples[#:eval the-eval
(ppict-do base
#:go (cascade)
(tag-pict (standard-fish 40 20 #:direction 'right #:color "red") 'red-fish)
(tag-pict (standard-fish 50 30 #:direction 'left #:color "blue") 'blue-fish)
#:go (merge-refpoints (coord 1 0 'rc)
(at-find-pict 'red-fish))
(text "red fish"))
]
}
@subsection{Tagging picts}
@defproc[(tag-pict [p pict?] [tag symbol?]) pict?]{
Returns a pict like @racket[p] that carries a symbolic tag. The tag
can be used with @racket[find-tag] to locate the pict.
}
@defproc[(find-tag [p pict?] [find tag-path?])
(or/c pict-path? #f)]{
Locates a sub-pict of @racket[p]. Returns a pict-path that can be used
with functions like @racket[lt-find], etc.
}
@defproc[(tag-path? [x any/c]) boolean?]{
Returns @racket[#t] if @racket[x] is a symbol or a non-empty list of
symbols, @racket[#f] otherwise.
}
@section[#:tag "pslide"]{Progressive Slides}
@defmodule[unstable/gui/pslide]
@defform/subs[(pslide pslide-fragment ...)
([pslide-fragment (code:line #:go placer-expr)
(code:line #:next)
(code:line elem-expr)])
#:contracts ([placer-expr placer?]
[elem-expr (or/c pict? real? #f)])]{
@defform[(pslide ppict-do-fragment ...)]{
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].
Produce slide(s) using @tech{progressive picts}. See @racket[ppict-do]
for an explanation of @racket[ppict-do-fragment]s.
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.
@racket[#:next] uses; that is, 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.