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

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

Browse Source
This commit is contained in:
Ryan Culpepper 2011-07-30 01:31:20 -05:00
parent d1fcbc0a7c
commit efa8051a57
6 changed files with 145 additions and 80 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
collects/unstable/gui/pict.rkt
View File

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

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

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

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

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

63
collects/unstable/gui/private/tag-pict.rkt Normal file
View File

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

53
collects/unstable/scribblings/gui/pict.scrbl
View File

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

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

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