unstable/gui/ppict:

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

collects/unstable/gui/ppict.rkt

@@ -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)
+     #:declare fs (fragment-sequence who #'xp #'rpss)
-     #'(let-values ([(final _picts)
+     #'(let ([xp base.c] [rpss null])
-                     (internal-ppict-do 'ppict-do base.c (list p.code ...))])
+         fs.code)]))
-         final)]))
+
+(define-syntax (ppict-do stx)
+  #`(let-values ([(final _picts)
+                  #,(ppict-do*-transformer 'ppict-do stx)])
+      final))
 
 (define-syntax (ppict-do* stx)
-  (syntax-parse stx
+  (ppict-do*-transformer 'ppict-do* stx))
-    [(_ base p ...)
-     #:declare base (expr/c #'pict?)
-     #:declare p (fragment 'ppict-do)
-     #'(internal-ppict-do 'ppict-do* base.c (list p.code ...))]))
 
 ;; ----
 
 (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))])

collects/unstable/gui/private/ppict-syntax.rkt

@@ -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)
+(define-syntax-class (fragment-sequence who xp-var rpss-var)
-  #:description (format "~a fragment" who)
+  #: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")
+           #:declare pl (expr/c #'placer? #:name "placer argument of #:go fragment")
-           #:with code #'(p:go pl.c))
+           #: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 ...)))

collects/unstable/gui/private/ppict.rkt

@@ -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))]
+              #:compose [compose (halign->vcompose (align->h align))])
-              #:sep [sep 0])
   ;; 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))]
+               #:compose [compose (halign->vcompose (align->h align))])
-               #:sep [sep 0]
-               #:internal:skip [skip #f])
   (define halign (align->h align))
   (define valign (align->v align))
-  (refpoint* xfrac yfrac abs-x abs-y halign valign compose sep #f))
+  (new refpoint%
-
+       (xa abs-x) (ya abs-y)
-(define (refpoint* xfrac yfrac dxabs dyabs
+       (depxy (lambda (p)
-                   halign valign compose sep continued?)
+                (values (* xfrac (pict-width p))
-  (placer
+                        (* yfrac (pict-height p)))))
-   (lambda (scene picts)
+       (halign halign) (valign valign) (compose compose)))
-     (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])))))
 
 ;; ----
 
-;; 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
+  (new cascade% (step-x0 step-x0) (step-y0 step-y0)))
-   (lambda (scene elems)
+
-     (for/or ([e (in-list elems)])
+;; at-find-pict : ... -> placer
-       (when (real? e)
+(define (at-find-pict path
-         (error 'cascade "spacing changes not allowed: ~e" e)))
+                      [find cc-find]
-     (let* ([picts (filter pict? elems)]
+                      [align 'cc]
-            [max-w (apply max 1 (map pict-width picts))]  ;; avoid 0
+                      #:abs-x [abs-x 0]
-            [max-h (apply max 1 (map pict-height picts))] ;; avoid 0
+                      #:abs-y [abs-y 0]
-            [auto-step-x (/ (- (pict-width scene) max-w) (+ 1 (length picts)))]
+                      #:compose [compose (halign->vcompose (align->h align))])
-            [auto-step-y (/ (- (pict-height scene) max-h) (+ 1 (length picts)))]
+  (define halign (align->h align))
-            [step-x (if (eq? step-x0 'auto) auto-step-x step-x0)]
+  (define valign (align->v align))
-            [step-y (if (eq? step-y0 'auto) auto-step-y step-y0)]
+  (new refpoint%
-            [bbox (blank max-w max-h)]
+       (xa abs-x) (ya abs-y)
-            [positioned-picts
+       (depxy (lambda (p)
-             (for/list ([pict (in-list picts)]
+                (let ([pict-path (if (tag-path? path) (find-tag p path) path)])
-                        [i (in-naturals 1)])
+                  (unless pict-path
-               (inset (cc-superimpose bbox pict)
+                    (error 'at-find-path "failed finding ~e" path))
-                      (* i step-x) (* i step-y) 0 0))]
+                  (find p pict-path))))
-            [newscene
+       (halign halign) (valign valign) (compose compose)))
-             (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))))
 
 ;; ----
 
@@ -196,97 +256,37 @@ In a placer function's arguments:
 
 ;; ----
 
-#|
+(define-syntax-parameter ppict-do-state
-(define (ppict-do* base elems)
+  (lambda (stx)
-  (define (loop elems rchunks)
+    (raise-syntax-error #f "used out of context" stx)))
-    (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)]))))
-|#
 
-;; ----
+;; internal-ppict-do : pict (listof (U pict real #f 'next))
-
+;;                  -> (values pict (listof pict))
-(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
+  (unless (ppict? base)
-          (cond [(ppict? base) (p:go (ppict-placer base))]
+    (error who "missing placer"))
-                [else #f])]
+  (do-chunk base parts))
-         [gochunks (get-gochunks who init-go parts)])
-    (do-gochunks base gochunks)))
 
 ;; ----
 
-;; 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)
+;; do-chunk : ppict (listof (U pict real #f 'next)) -> (values ppict (listof pict))
-(define (get-gochunks who init-go elems)
+;; In second return value, one pict per 'next occurrence.
-  (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
+         ;;   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))
+                    (cons (map ghost* (car elab-rest)) elab-rest))]
-                          elab-rest))]
+                 [(and (pair? chunk) (not (eq? 'next (car chunk))))
-                 [(and (pair? chunk) (p:elem? (car chunk)))
                   (for/list ([elem-chunk (in-list (elab (cdr chunk)))])
-                    (cons (p:elem-value (car chunk))
+                    (cons (car chunk) elem-chunk))]
-                          elem-chunk))]
+                 [(null? chunk) (list null)]))])
-                 [(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
 

collects/unstable/gui/pslide.rkt

@@ -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
+;; pslide* : symbol (pict -> (values pict (listof pict)) -> void
-(define (pslide* who parts)
+(define (pslide* who proc)
-  (let* ([init-go (p:go (pslide-default-placer))]
+  (let* ([init-pict ((pslide-base-pict))]
-         [init-pict ((pslide-base-pict))]
+         [init-placer (pslide-default-placer)])
-         [gochunks
+    (let-values ([(final picts)
-          (get-gochunks who init-go (append parts (list (p:out))))])
+                  (proc (ppict-go init-pict init-placer))])
-    (let-values ([(final picts) (do-gochunks init-pict gochunks)])
       (for-each slide picts)
+      (slide final)
       (void))))
 
 ;; ----
 
 (define-syntax (pslide stx)
   (syntax-parse stx
-    [(_ p ...)
+    [(_ . fs)
-     #:declare p (fragment 'pslide)
+     #:declare fs (fragment-sequence 'pslide #'xp #'rpss)
-     #'(pslide* 'pslide (list p.code ...))]))
+     #'(pslide* 'pslide
+                (lambda (xp)
+                  (let ([rpss null])
+                    fs.code)))]))
 
 ;; ============================================================
 ;; Exports

collects/unstable/scribblings/gui/pslide.scrbl

@@ -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 ...)
+@defform[(pslide ppict-do-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)])]{
 
-Produce slide(s) using @tech{progressive picts}. A @racket[#:go]
+Produce slide(s) using @tech{progressive picts}. See @racket[ppict-do]
-directive updates the current placer; a @racket[#:next] directive
+for an explanation of @racket[ppict-do-fragment]s.
-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.
+@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.