diff --git a/collects/unstable/gui/pict.rkt b/collects/unstable/gui/pict.rkt index 34c42a4bed..73f2b71447 100644 --- a/collects/unstable/gui/pict.rkt +++ b/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?))]) diff --git a/collects/unstable/gui/ppict.rkt b/collects/unstable/gui/ppict.rkt index f342d82aa1..7f333ccf20 100644 --- a/collects/unstable/gui/ppict.rkt +++ b/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? - tag-path?) + refpoint-placer?) (provide/contract [ppict-go @@ -82,11 +82,4 @@ 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))]) + refpoint-placer?)]) diff --git a/collects/unstable/gui/private/ppict.rkt b/collects/unstable/gui/private/ppict.rkt index 5c3db95ce0..323528fad4 100644 --- a/collects/unstable/gui/private/ppict.rkt +++ b/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 diff --git a/collects/unstable/gui/private/tag-pict.rkt b/collects/unstable/gui/private/tag-pict.rkt new file mode 100644 index 0000000000..a58d15ae79 --- /dev/null +++ b/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))) diff --git a/collects/unstable/scribblings/gui/pict.scrbl b/collects/unstable/scribblings/gui/pict.scrbl index 61c5ee9902..770bf90fd4 100644 --- a/collects/unstable/scribblings/gui/pict.scrbl +++ b/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) diff --git a/collects/unstable/scribblings/gui/pslide.scrbl b/collects/unstable/scribblings/gui/pslide.scrbl index 274aa13354..4efd4659a4 100644 --- a/collects/unstable/scribblings/gui/pslide.scrbl +++ b/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]