moved tag-pict, etc from unstable/gui/ppict to unstable/gui/pict

collects/unstable/gui/pict.rkt

@@ -355,3 +355,24 @@
        pict?)]
  [pin-arrow-label-line pin-arrow-label-line-contract]
  [pin-arrows-label-line pin-arrow-label-line-contract])
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;  Tagged picts
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(require "private/tag-pict.rkt")
+
+(provide/contract
+ [tag-path?
+  (-> any/c boolean?)]
+ [tag-pict
+  (-> pict? symbol? pict?)]
+ [pict-tag
+  (-> pict? (or/c symbol? #f))]
+ [find-tag
+  (-> pict? tag-path? (or/c pict-path? #f))]
+ [find-tag*
+  (-> pict? tag-path?
+      (listof pict-path?))])

collects/unstable/gui/ppict.rkt

@@ -6,7 +6,8 @@
                      "private/ppict-syntax.rkt")
          racket/contract
          slideshow/pict
-         "private/ppict.rkt")
+         "private/ppict.rkt"
+         "private/tag-pict.rkt")
 
 (define-for-syntax (ppict-do*-transformer who stx)
   (syntax-parse stx
@@ -32,8 +33,7 @@
 
 (provide ppict?
          placer?
-         refpoint-placer?
+         refpoint-placer?)
-         tag-path?)
 
 (provide/contract
  [ppict-go
@@ -82,11 +82,4 @@
        refpoint-placer?)]
  [merge-refpoints
   (-> refpoint-placer? 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.rkt

@@ -4,7 +4,8 @@
          racket/class
          racket/stxparam
          racket/contract
-         slideshow/pict)
+         slideshow/pict
+         "tag-pict.rkt")
 
 #|
 TODO
@@ -333,49 +334,6 @@ In a placer function's arguments:
 (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/private/tag-pict.rkt

@@ -0,0 +1,63 @@
+#lang racket/base
+(require slideshow/pict)
+(provide tag-pict
+         find-tag
+         find-tag*
+         tag-path?
+         pict-tag)
+
+(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 boolean -> (listof pict-path)
+(define (find-tag** p tagpath all?)
+  (let ([tagpath (if (symbol? tagpath) (list tagpath) tagpath)])
+    (define-syntax-rule (append* e1 e2)
+      (let ([x e1])
+        (cond [(or all? (null? x)) (append x e2)]
+              [else x])))
+    (define (loop p tagpath)
+      (cond [(pair? tagpath)
+             (childrenloop (pict-children p) tagpath)]
+            [(null? tagpath)
+             (list (list p))]))
+    (define (pairloop p tagpath)
+      (append*
+       (cond [(and (tagged-pict? p)
+                   (eq? (tagged-pict-tag p) (car tagpath)))
+              (for/list ([r (in-list (loop p (cdr tagpath)))])
+                (cons p r))]
+             [else null])
+       (childrenloop (pict-children p) tagpath)))
+    (define (childrenloop children tagpath)
+      (cond [(pair? children)
+             (append* (pairloop (child-pict (car children)) tagpath)
+                      (childrenloop (cdr children) tagpath))]
+            [(null? children)
+             null]))
+    (loop p tagpath)))
+
+(define (find-tag p tagpath)
+  (let ([r (find-tag** p tagpath #f)])
+    (and (pair? r) (car r))))
+
+(define (find-tag* p tagpath)
+  (find-tag** p tagpath #t))
+
+(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)))

collects/unstable/scribblings/gui/pict.scrbl

@@ -13,7 +13,7 @@
 @(define the-eval (make-base-eval))
 @(the-eval '(require racket/math slideshow/pict unstable/gui/pict))
 
-@title{Pict Utilities}
+@title[#:tag "pict"]{Pict Utilities}
 
 @unstable[@author+email["Carl Eastlund" "cce@racket-lang.org"]]
 
@@ -432,4 +432,55 @@ Blurs @racket[bitmap] using blur radii @racket[h-radius] and
 }
 
 
+@subsection{Tagged 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.
+
+@examples[#:eval the-eval
+(let* ([a (tag-pict (red (disk 20)) 'a)]
+       [b (tag-pict (blue (filled-rectangle 20 20)) 'b)]
+       [p (vl-append a (hb-append (blank 100) b))])
+  (pin-arrow-line 10 p
+                  (find-tag p 'a) rb-find
+                  (find-tag p 'b) lt-find))
+]
+}
+
+@defproc[(find-tag* [p pict?] [find tag-path?])
+         (listof pict-path?)]{
+
+Like @racket[find-tag], but returns all pict-paths corresponding to
+the given tag-path.
+
+@examples[#:eval the-eval
+(let* ([a (lambda () (tag-pict (red (disk 20)) 'a))]
+       [b (lambda () (tag-pict (blue (filled-rectangle 20 20)) 'b))]
+       [as (vc-append 10 (a) (a) (a))]
+       [bs (vc-append 10 (b) (b) (b))]
+       [p (hc-append as (blank 60 0) bs)])
+  (for*/fold ([p p])
+      ([apath (in-list (find-tag* p 'a))]
+       [bpath (in-list (find-tag* p 'b))])
+    (pin-arrow-line 10 p
+                    apath rc-find
+                    bpath lc-find)))
+]
+}
+
+@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.
+}
+
 @(close-eval the-eval)

collects/unstable/scribblings/gui/pslide.scrbl

@@ -6,13 +6,14 @@
           (for-label racket/base
                      slideshow
                      unstable/gui/ppict
-                     unstable/gui/pslide))
+                     unstable/gui/pslide
+                     unstable/gui/pict))
 
 @title[#:tag "ppict"]{Progressive Picts and Slides}
 @unstable[@author+email["Ryan Culpepper" "ryanc@racket-lang.org"]]
 
 @(define the-eval (make-base-eval))
-@(the-eval '(require slideshow/pict unstable/gui/ppict))
+@(the-eval '(require slideshow/pict unstable/gui/ppict unstable/gui/private/tag-pict))
 
 @section[#:tag "ppicts"]{Progressive Picts}
 
@@ -353,28 +354,6 @@ reference point is computed by @racket[y-placer].
 }
 
 
-@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]