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

change slideshow pict's 'last' field to contain a pict path

Browse Source 
svn: r15759
This commit is contained in:
Matthew Flatt 2009-08-17 12:51:04 +00:00
parent bb3818ee07
commit 1a37d891ac
4 changed files with 95 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
collects/scribblings/slideshow/picts.scrbl
View File

@ -73,7 +73,7 @@ information from a pict.
[descent real?]
[children (listof child?)]
[panbox (or/c #f any/c)]
[last (or/c #f pict?)])]{
[last (or/c #f pict-path?)])]{
A @scheme[pict] structure is normally not created directly with
@scheme[make-pict]. Instead, functions like @scheme[text],
@ -589,13 +589,14 @@ sub-pict) sub-pict)].}
Shifts the given pict's bounding box to enclose the bounding boxes of
all sub-picts (even @scheme[launder]ed picts).}
@defproc[(use-last [pict pict?] [sub-pict pict?]) pict?]{
@defproc[(use-last [pict pict?] [sub-pict pict-path?]) pict?]{
Returns a pict like @scheme[pict], but with the last element (as
reported by @scheme[pict-last]) set to @scheme[sub-pict]. The
@scheme[sub-pict] must exist as a sub-pict within @scheme[pict].}
@scheme[sub-pict] must exist as a sub-pict (or path of sub-picts)
within @scheme[pict].}
@defproc[(use-last* [pict pict?] [sub-pict pict?]) pict?]{
@defproc[(use-last* [pict pict?] [sub-pict pict-path?]) pict?]{
Propagates the last element of @scheme[sub-pict] to @scheme[pict].
@ -642,7 +643,9 @@ list of @scheme[pict]s.}
Creates a pict that has the same drawing and bounding box of
@scheme[pict], but which hides all of its sub-picts so that they
cannot be found with functions like @scheme[lt-find].}
cannot be found with functions like @scheme[lt-find]. If @scheme[pict]
has a last-line pict, then the laundered pict has a fresh last-line
pict with the same shape and location.}
@; ------------------------------------------------------------------------

25
collects/slideshow/play.ss
View File

@ -1,6 +1,7 @@
#lang scheme/base
(require slideshow/base
slideshow/pict)
slideshow/pict
scheme/list)
(provide play play-n
fade-pict
@ -12,6 +13,8 @@
(with-handlers ([exn:fail? (lambda (x) (values 0 0))])
(t)))
(define single-pict (lambda (p) (if (list? p) (last p) p)))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Animation player
@ -36,12 +39,15 @@
;; arguments will be 0.0. The first argument goes from 0.0 to 1.0
;; for the first `play' sequence, and then it stays at 1.0 while
;; the second goes from 0.0 to 1.0 for the second sequence, etc.
(define (play-n #:title [title #f] #:layout [layout 'auto] mid)
(define (play-n #:title [title #f] #:layout [layout 'auto]
mid
#:skip-last? [skip-last? #f])
(let ([n (procedure-arity mid)])
(let loop ([post (vector->list (make-vector n))]
[pre null])
(if (null? post)
(slide #:title title #:layout layout (apply mid pre))
(unless skip-last?
(slide #:title title #:layout layout (apply mid pre)))
(begin
(play #:title title
#:layout layout
@ -75,10 +81,12 @@
(+ aby (* (- bby aby) n)))]
[orig
;; Generate intermediate last-pict
(let ([ae (or (pict-last a) a)]
[be (or (pict-last b) b)])
(let-values ([(al at) (lt-find orig ae)]
[(bl bt) (lt-find orig be)])
(let ([ap (or (pict-last a) a)]
[bp (or (pict-last b) b)])
(let-values ([(al at) (lt-find orig (if (pair? ap) (cons a ap) (list a ap)))]
[(bl bt) (lt-find orig (if (pair? bp) (cons b bp) (list b bp)))]
[(ae) (single-pict ap)]
[(be) (single-pict bp)])
(let ([ar (+ al (pict-width ae))]
[ab (+ at (pict-height ae))]
[br (+ bl (pict-width be))]
@ -97,7 +105,8 @@
[bl (max t (min (btw abl bbl) b))])
(let ([p (blank (- r l) (- b t)
(- tl t) (- b bl))])
(use-last (pin-over orig l t p) p)))))))))])
(let ([orig+p (pin-over orig l t p)])
(use-last orig+p p))))))))))])
(let ([p (make-pict (pict-draw orig)
(pict-width orig)
(pict-height orig)

16
collects/texpict/code.ss
View File

@ -2,6 +2,7 @@
(require "mrpict.ss"
mzlib/class
mzlib/list
(only scheme/list last)
mred
mzlib/unit)
@ -14,15 +15,21 @@
(and (pict-last p) #t))
(define (code-pict-bottom-line p)
(pict-last p))
(single-pict (pict-last p)))
(define (single-pict p)
(if (list? p)
(last p)
p))
(define (make-code-append htl-append)
(case-lambda
[(a b) (let ([a-last (pict-last a)])
(if a-last
(let ([extension (htl-append (ghost a-last) b)])
(let* ([a-dup (launder (ghost (single-pict a-last)))]
[extension (htl-append a-dup b)])
(let ([p (let-values ([(x y) (lt-find a a-last)]
[(dx dy) (lt-find extension a-last)])
[(dx dy) (lt-find extension a-dup)])
(let ([ex (- x dx)]
[ey (- y dy)])
(if (negative? ey)
@ -505,6 +512,9 @@
[id
(identifier? stx)
(add-close (colorize-id (symbol->string (syntax-e stx)) mode) closes)]
[kw
(keyword? (syntax-e #'kw))
(add-close (mode-colorize mode #f (tt (format "~s" (syntax-e stx)))) closes)]
[(a . b)
;; Build a list that makes the "." explicit.
(let ([p (let loop ([a (syntax-e stx)])

77
collects/texpict/private/common-unit.ss
View File

@ -171,8 +171,26 @@
(let ([b (extend-pict box 0 0 0 0 0 #f)])
(set-pict-children! b null)
(set-pict-panbox! b (pict-panbox box))
(set-pict-last! b #f)
b))
;; After laundering, we can't find the last-pos box.
;; So create a new last-position box to preserve the
;; original shape:
(let ([l (pict-last box)])
(set-pict-last! box #f) ; preserve invariants
(cond
[(not l) b]
[else
(let-values ([(x y) (lt-find box l)]
[(l) (let loop ([l l])
(if (pair? l)
(if (null? (cdr l))
(car l)
(loop (cdr l)))
l))])
(let ([b (blank (pict-width l) (pict-height l)
(pict-ascent l) (pict-descent l))])
(use-last/unchecked
(pin-over box x y b)
b)))]))))
(define (lift p n)
(let* ([dh (- (max 0 (- n (pict-descent p))))]
@ -227,7 +245,7 @@
(pict-ascent c) (pict-descent c)
(pict-children p)
#f
(or (pict-last c) c)))))
(last* c)))))
(define (panorama-box! p)
(let ([bb (pict-panbox p)])
@ -305,24 +323,44 @@
(put ,l ,b ,(pict-draw box)))))]))
(define (use-last* p sub-p)
(use-last p (or (pict-last sub-p) sub-p)))
(use-last p (last* sub-p)))
(define (last* sub-p)
;; Either use `sub-p' for last or create a path though `sub-p'
;; to the last of `sub-p' (in case the last of `sub-p' is also
;; in other places within `p')
(let ([l (pict-last sub-p)])
(cond
[(not l) sub-p]
[(eq? l sub-p) sub-p]
[(pair? l) (if (eq? (car l) sub-p)
l
(cons sub-p l))]
[else (list sub-p l)])))
(define (use-last p sub-p)
(if (let floop ([p p])
(if (let floop ([p p] [sub-p sub-p])
(or (eq? p sub-p)
(ormap (lambda (c) (floop (child-pict c)))
(and (pair? sub-p)
(eq? p (car sub-p))
(or (null? (cdr sub-p))
(floop p (cdr sub-p))))
(ormap (lambda (c) (floop (child-pict c) sub-p))
(pict-children p))))
(make-pict (pict-draw p)
(pict-width p) (pict-height p)
(pict-ascent p) (pict-descent p)
(list (make-child p 0 0 1 1))
#f
sub-p)
(use-last/unchecked p sub-p)
(error 'use-last
"given new last pict: ~e not in the base pict: ~e"
"given new last-pict path: ~e not in the base pict: ~e"
sub-p
p)))
(define (use-last/unchecked p sub-p)
(make-pict (pict-draw p)
(pict-width p) (pict-height p)
(pict-ascent p) (pict-descent p)
(list (make-child p 0 0 1 1))
#f
sub-p))
(define dash-frame
(case-lambda
[(box) (dash-frame box default-seg)]
@ -487,7 +525,7 @@
(list (make-child first dx1 dy1 1 1)
(make-child rest dx2 dy2 1 1))
#f
(or (pict-last rest) rest)))])))])
(last* rest)))])))])
*-append))]
[2max (lambda (a b c . rest) (max a b))]
[zero (lambda (fw fh rw rh sep fd1 fd2 rd1 rd2 . args) 0)]
@ -612,8 +650,7 @@
;; Find bottomost, rightmost of old last picts to be the
;; new last pict.
(let ([subs (map (lambda (box)
(let ([last (or (pict-last box)
box)])
(let ([last (last* box)])
(let-values ([(x y) (rb-find p last)])
(list last x y))))
boxes)])
@ -873,10 +910,10 @@
[else
(error who
"expects two numbers or a sub-pict and a find procedure")])])
(use-last (cons-picture*
base
`((place ,dx ,(- dy (pict-height target)) ,target)))
(or (pict-last base) base))))
(use-last/unchecked (cons-picture*
base
`((place ,dx ,(- dy (pict-height target)) ,target)))
(last* base))))
(define (place-over base dx dy target)
(place-it 'place-over #f base dx dy target))