From 1a37d891ac0525725e760a5a1a91fa6cb44b1280 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 17 Aug 2009 12:51:04 +0000 Subject: [PATCH] change slideshow pict's 'last' field to contain a pict path svn: r15759 --- collects/scribblings/slideshow/picts.scrbl | 13 ++-- collects/slideshow/play.ss | 25 ++++--- collects/texpict/code.ss | 16 ++++- collects/texpict/private/common-unit.ss | 77 ++++++++++++++++------ 4 files changed, 95 insertions(+), 36 deletions(-) diff --git a/collects/scribblings/slideshow/picts.scrbl b/collects/scribblings/slideshow/picts.scrbl index b1e0a8a10e..7f1f2ce336 100644 --- a/collects/scribblings/slideshow/picts.scrbl +++ b/collects/scribblings/slideshow/picts.scrbl @@ -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.} @; ------------------------------------------------------------------------ diff --git a/collects/slideshow/play.ss b/collects/slideshow/play.ss index 873cdc8888..a629bcf4c9 100644 --- a/collects/slideshow/play.ss +++ b/collects/slideshow/play.ss @@ -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) diff --git a/collects/texpict/code.ss b/collects/texpict/code.ss index 32b3cd94e3..e6c7b659a0 100644 --- a/collects/texpict/code.ss +++ b/collects/texpict/code.ss @@ -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)]) diff --git a/collects/texpict/private/common-unit.ss b/collects/texpict/private/common-unit.ss index e17d620eee..7bdc81171c 100644 --- a/collects/texpict/private/common-unit.ss +++ b/collects/texpict/private/common-unit.ss @@ -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))