split up slideshow/play so that the pict-only parts are

in pict-lib and don't depend on racket/gui/base
This commit is contained in:
Robby Findler 2013-11-05 15:11:25 -06:00
parent a1331fbd1f
commit 59e92d7d39
7 changed files with 628 additions and 565 deletions

View File

@ -0,0 +1,146 @@
#lang scribble/doc
@(require (for-label pict racket)
scribble/manual)
@title{Animation Helpers}
These functions are designed to work with the
slide constructors in @racketmodname[slideshow/play].
@declare-exporting[pict slideshow/play]
@section{Pict Interoplations}
@defproc[(fade-pict [n (real-in 0.0 1.0)] [p1 pict?] [p2 pict?]
[#:combine combine (pict? pict? . -> . pict?) cc-superimpose])
pict?]{
Interpolates @racket[p1] and @racket[p2], where the result with
@racket[n] as @racket[0.0] is @racket[p1], and the result with
@racket[n] as @racket[1.0] is @racket[p2]. For intermediate points,
@racket[p1] fades out while @racket[p2] fades in as @racket[n] changes
from @racket[0.0] to @racket[1.0]. At the same time, the width and
height of the generated pict are intermediate between
@racket[p1] and @racket[p2], and the relative baselines and last
pict correspondingly morph within the bounding box.
The @racket[combine] argument determines how @racket[p1] and
@racket[p2] are aligned for morphing. For example, if @racket[p1] and
@racket[p2] both contain multiple lines of text with the same line
height but different number of lines, then using
@racket[ctl-superimpose] would keep the ascent line in a fixed
location relative to the top of the resulting pict as the rest of the
shape morphs around it.}
@defproc[(fade-around-pict [n (real-in 0.0 1.0)]
[p1 pict?]
[make-p2 (pict? . -> . pict?)])
pict?]{
Similar to @racket[fade-pict], but the target is not a fixed
@racket[_p2], but instead a function @racket[make-p2] that takes a
@racket[launder]ed @racket[ghost] of @racket[p1] and places it into a
larger scene. Also, @racket[p1] does not fade out as @racket[n]
increases; instead, @racket[p1] is placed wherever its ghost appears
in the result of @racket[make-p2].
For example,
@RACKETBLOCK[
(lambda (n)
(fade-around-pict n
(code x)
(lambda (g) (code (+ #,x 1)))))
]
animates the wrapping of @racket[x] with a @racket[(+ .... 1)] form.}
@defproc[(slide-pict [base pict?]
[p pict?]
[p-from pict?]
[p-to pict?]
[n (real-in 0.0 1.0)])
pict?]{
Pins @racket[p] onto @racket[base], sliding from @racket[p-from] to
@racket[p-to] (which are picts within @racket[base]) as
@racket[n] goes from @racket[0.0] to @racket[1.0]. The top-left
locations of @racket[p-from] and @racket[p-to] determine the placement
of the top-left of @racket[p].
The @racket[p-from] and @racket[p-to] picts are typically
@racket[launder]ed @racket[ghost]s of @racket[p] within @racket[base],
but they can be any picts within @racket[base].}
@; --------------------------------------------------
@section{Merging Animations}
@defproc[(sequence-animations [gen (-> (real-in 0.0 1.0) pict?)]
...)
(-> (real-in 0.0 1.0) pict?)]{
Converts a list of @racket[gen] functions into a single function that
uses each @racket[gen] in sequence.}
@defproc[(reverse-animations [gen (-> (real-in 0.0 1.0) pict?)]
...)
(-> (real-in 0.0 1.0) pict?)]{
Converts a list of @racket[gen] functions into a single function that
run @racket[(sequence-animations gen ...)] in reverse.}
@; --------------------------------------------------
@section{Stretching and Squashing Time}
@deftogether[(
@defproc[(fast-start [n (real-in 0.0 1.0)]) (real-in 0.0 1.0)]
@defproc[(fast-end [n (real-in 0.0 1.0)]) (real-in 0.0 1.0)]
@defproc[(fast-edges [n (real-in 0.0 1.0)]) (real-in 0.0 1.0)]
@defproc[(fast-middle [n (real-in 0.0 1.0)]) (real-in 0.0 1.0)]
)]{
Monotonically but non-uniformly maps @racket[n] with fixed
points at @racket[0.0] and @racket[1.0].
The @racket[fast-start] mapping is convex, so that
@racketblock[(slide-pict _base p _p1 _p2 (fast-start n))]
appears to move quickly away from @racket[_p1] and then slowly as it
approaches @racket[_p2], assuming that @racket[n] increases uniformly.
The @racket[fast-end] mapping is concave, so that
@racketblock[(slide-pict _base _p _p1 _p2 (fast-end _n))]
appears to move slowly away from @racket[_p1] and then quicly as it
approaches @racket[_p2], assuming that @racket[_n] increases uniformly.
The @racket[fast-edges] mapping is convex at first and concave at the
end, so that
@racketblock[(slide-pict _base _p _p1 _p2 (fast-edges _n))]
appears to move quickly away from @racket[_p1], then more slowly, and
then quickly again near @racket[_p2], assuming that @racket[_n] increases
uniformly.
The @racket[fast-middle] mapping is concave at first and convex at the
end, so that
@racketblock[(slide-pict _base _p _p1 _p2 (fast-middle _n))]
appears to move slowly away from @racket[_p1], then more quickly, and
then slowly again near @racket[_p2], assuming that @racket[_n] increases
uniformly.}
@defproc[(split-phase [n (real-in 0.0 1.0)])
(values (real-in 0.0 1.0) (real-in 0.0 1.0))]{
Splits the progression of @racket[n] from @racket[0.0] to @racket[1.0]
into a progression from @racket[(values 0.0 0.0)] to @racket[(values
1.0 0.0)] and then @racket[(values 1.0 0.0)] to @racket[(values 1.0
1.0)].}

View File

@ -887,6 +887,10 @@ pict with the same shape and location.}
@; ----------------------------------------
@include-section["anim.scrbl"]
@; ----------------------------------------
@section{Miscellaneous}
@defproc[(hyperlinkize [pict pict?])

View File

@ -1,288 +1,28 @@
(module pict scheme/base
(require (rename-in texpict/mrpict
[hline t:hline]
[vline t:vline]
[frame t:frame])
(rename-in texpict/utils
[pin-line t:pin-line]
[pin-arrow-line t:pin-arrow-line]
[pin-arrows-line t:pin-arrows-line])
(only-in racket/draw dc-path% make-bitmap bitmap% bitmap-dc%)
(only-in racket/class new send make-object is-a?/c)
racket/contract)
(define (hline w h #:segment [seg #f])
(if seg
(dash-hline w h seg)
(t:hline w h)))
(define (vline w h #:segment [seg #f])
(if seg
(dash-vline w h seg)
(t:vline w h)))
(define (frame p
#:color [col #f]
#:line-width [lw #f]
#:segment [seg #f])
(let* ([f (if seg
(dash-frame (launder (ghost p)) seg)
(t:frame (launder (ghost p))))]
[f (if col
(colorize f col)
f)]
[f (if lw
(linewidth lw f)
f)])
(refocus (cc-superimpose p f)
p)))
(define (pict-path? p)
(or (pict? p)
(and (pair? p)
(list? p)
(andmap pict? p))))
(define (pin-line p
src src-find
dest dest-find
#:start-angle [sa #f] #:end-angle [ea #f]
#:start-pull [sp #f] #:end-pull [ep #f]
#:color [col #f]
#:alpha [alpha 1.0]
#:line-width [lw #f]
#:under? [under? #f]
#:solid? [solid? #t]
#:style [style #f])
(if (not (or sa ea))
(finish-pin (launder (t:pin-line (ghost p)
src src-find
dest dest-find
#:style style))
p lw col alpha under?)
(pin-curve* #f #f p src src-find dest dest-find
sa ea sp ep 0 col lw under? #t
style alpha)))
(define (pin-arrow-line sz p
src src-find
dest dest-find
#:start-angle [sa #f] #:end-angle [ea #f]
#:start-pull [sp #f] #:end-pull [ep #f]
#:color [col #f]
#:alpha [alpha 1.0]
#:line-width [lw #f]
#:under? [under? #f]
#:solid? [solid? #t]
#:style [style #f]
#:hide-arrowhead? [hide-arrowhead? #f])
(if (not (or sa ea))
(finish-pin (launder (t:pin-arrow-line sz (ghost p)
src src-find
dest dest-find
#f #f #f solid?
#:hide-arrowhead? hide-arrowhead?
#:style style))
p lw col alpha under?)
(pin-curve* #f (not hide-arrowhead?) p src src-find dest dest-find
sa ea sp ep sz col lw under? solid?
style alpha)))
#lang racket/base
(require "private/main.rkt"
racket/contract
racket/class
racket/draw)
(provide
(except-out (all-from-out "private/main.rkt")
pict->bitmap)
(contract-out
[pict->bitmap (->* (pict?)
((or/c 'unsmoothed 'smoothed 'aligned))
(is-a?/c bitmap%))]))
(define (pin-arrows-line sz p
src src-find
dest dest-find
#:start-angle [sa #f] #:end-angle [ea #f]
#:start-pull [sp #f] #:end-pull [ep #f]
#:color [col #f]
#:alpha [alpha 1.0]
#:line-width [lw #f]
#:under? [under? #f]
#:solid? [solid? #t]
#:style [style #f]
#:hide-arrowhead? [hide-arrowhead? #f])
(if (not (or sa ea))
(finish-pin (launder (t:pin-arrows-line sz (ghost p)
src src-find
dest dest-find
#f #f #f solid?
#:hide-arrowhead? hide-arrowhead?
#:style style))
p lw col alpha under?)
(pin-curve* (not hide-arrowhead?) (not hide-arrowhead?)
p src src-find dest dest-find
sa ea sp ep sz col lw under? solid?
style alpha)))
(define (pin-curve* start-arrow? end-arrow? p
src src-find
dest dest-find
sa ea sp ep
sz col lw
under? solid?
style alpha)
(let-values ([(sx0 sy0) (src-find p src)]
[(dx0 dy0) (dest-find p dest)])
(let* ([sa (or sa
(atan (- sy0 dy0) (- dx0 sx0)))]
[ea (or ea
(atan (- sy0 dy0) (- dx0 sx0)))]
[d (sqrt (+ (* (- dy0 sy0) (- dy0 sy0)) (* (- dx0 sx0) (- dx0 sx0))))]
[sp (* (or sp 1/4) d)]
[ep (* (or ep 1/4) d)])
(let ([dx (if end-arrow? (- dx0 (* sz (cos ea))) dx0)]
[dy (if end-arrow? (+ dy0 (* sz (sin ea))) dy0)]
[sx (if start-arrow? (+ sx0 (* sz (cos sa))) sx0)]
[sy (if start-arrow? (- sy0 (* sz (sin sa))) sy0)]
[path (new dc-path%)]
[maybe-pin-line
(lambda (arrow? p sx sy dx dy)
(if arrow?
(pin-arrow-line
sz
p
p (lambda (a b) (values sx sy))
p (lambda (a b) (values dx dy))
#:line-width lw
#:color col
#:under? under?
#:solid? solid?
#:style style)
p))])
(send path move-to sx sy)
(send path curve-to
(+ sx (* sp (cos sa)))
(- sy (* sp (sin sa)))
(- dx (* ep (cos ea)))
(+ dy (* ep (sin ea)))
dx
dy)
(maybe-pin-line
start-arrow?
(maybe-pin-line
end-arrow?
((if under? pin-under pin-over)
p
0 0
(let* ([p (dc (lambda (dc x y)
(let ([b (send dc get-brush)])
(send dc set-brush "white" 'transparent)
(send dc draw-path path x y)
(send dc set-brush b)))
0 0)]
[p (if col
(colorize p col)
p)]
[p (if (= alpha 1.0)
p
(cellophane p alpha))]
[p (if lw
(linewidth lw p)
p)]
[p (if style
(linestyle style p)
p)])
p))
dx dy dx0 dy0)
sx sy sx0 sy0)))))
(define (finish-pin l p lw col alpha under?)
(let* ([l (if lw
(linewidth lw l)
l)]
[l (if col
(colorize l col)
l)]
[l (if (= alpha 1.0)
l
(cellophane l alpha))])
(if under?
(cc-superimpose l p)
(cc-superimpose p l))))
(define fish
(let ([standard-fish
(lambda (w h
#:direction [direction 'left]
#:color [color "blue"]
#:eye-color [eye-color "black"]
#:open-mouth [open-mouth #f])
(standard-fish w h direction color eye-color open-mouth))])
standard-fish))
(define (pict->bitmap p [smoothing 'aligned])
(define w (pict-width p))
(define h (pict-height p))
(define bm (make-bitmap (max 1 (inexact->exact (ceiling w)))
(max 1 (inexact->exact (ceiling h)))))
(define dc (make-object bitmap-dc% bm))
(send dc set-smoothing smoothing)
(draw-pict p dc 0 0)
bm)
(provide hline vline
frame
pict-path?
pin-line pin-arrow-line pin-arrows-line
(except-out (all-from-out texpict/mrpict)
dash-hline dash-vline
dash-frame oval oval/radius
caps-text
big-circle
picture
cons-picture
cons-picture*
place-over
place-under
record
thick
thin
find-lt
find-lc
find-lb
find-ltl
find-lbl
find-ct
find-cc
find-cb
find-ctl
find-cbl
find-rt
find-rc
find-rb
find-rtl
find-rbl
drop
lift)
(rename-out [drop drop-below-ascent]
[lift lift-above-baseline])
(except-out (all-from-out texpict/utils)
color-frame color-dash-frame
round-frame color-round-frame
cons-colorized-picture
arrow-line
arrows-line
add-line
add-arrow-line
add-arrows-line
explode-star
standard-fish
find-pen find-brush)
(rename-out [fish standard-fish])
(contract-out [pict->bitmap ((pict?) ((one-of/c 'unsmoothed 'smoothed 'aligned))
. ->* . (is-a?/c bitmap%))])
))
(require "private/play-pict.rkt")
(provide
(contract-out
[fade-pict (->* ((real-in 0.0 1.0) pict? pict?) (#:combine (-> pict? pict? pict?)) pict?)]
[slide-pict (-> pict? pict? pict? pict? (real-in 0.0 1.0) pict?)]
[fade-around-pict (-> (real-in 0.0 1.0) pict? (-> pict? pict?) pict?)]
[sequence-animations (->* () #:rest (listof (-> (real-in 0.0 1.0) pict?))
(-> (real-in 0.0 1.0) pict?))]
[reverse-animations (->* () #:rest (listof (-> (real-in 0.0 1.0) pict?))
(-> (real-in 0.0 1.0) pict?))]
[fast-start (-> (real-in 0.0 1.0) (real-in 0.0 1.0))]
[fast-end (-> (real-in 0.0 1.0) (real-in 0.0 1.0))]
[fast-edges (-> (real-in 0.0 1.0) (real-in 0.0 1.0))]
[fast-middle (-> (real-in 0.0 1.0) (real-in 0.0 1.0))]
[split-phase (-> (real-in 0.0 1.0) (values (real-in 0.0 1.0) (real-in 0.0 1.0)))]))

View File

@ -0,0 +1,285 @@
(module pict scheme/base
(require (rename-in texpict/mrpict
[hline t:hline]
[vline t:vline]
[frame t:frame])
(rename-in texpict/utils
[pin-line t:pin-line]
[pin-arrow-line t:pin-arrow-line]
[pin-arrows-line t:pin-arrows-line])
(only-in racket/draw dc-path% make-bitmap bitmap% bitmap-dc%)
(only-in racket/class new send make-object is-a?/c))
(define (hline w h #:segment [seg #f])
(if seg
(dash-hline w h seg)
(t:hline w h)))
(define (vline w h #:segment [seg #f])
(if seg
(dash-vline w h seg)
(t:vline w h)))
(define (frame p
#:color [col #f]
#:line-width [lw #f]
#:segment [seg #f])
(let* ([f (if seg
(dash-frame (launder (ghost p)) seg)
(t:frame (launder (ghost p))))]
[f (if col
(colorize f col)
f)]
[f (if lw
(linewidth lw f)
f)])
(refocus (cc-superimpose p f)
p)))
(define (pict-path? p)
(or (pict? p)
(and (pair? p)
(list? p)
(andmap pict? p))))
(define (pin-line p
src src-find
dest dest-find
#:start-angle [sa #f] #:end-angle [ea #f]
#:start-pull [sp #f] #:end-pull [ep #f]
#:color [col #f]
#:alpha [alpha 1.0]
#:line-width [lw #f]
#:under? [under? #f]
#:solid? [solid? #t]
#:style [style #f])
(if (not (or sa ea))
(finish-pin (launder (t:pin-line (ghost p)
src src-find
dest dest-find
#:style style))
p lw col alpha under?)
(pin-curve* #f #f p src src-find dest dest-find
sa ea sp ep 0 col lw under? #t
style alpha)))
(define (pin-arrow-line sz p
src src-find
dest dest-find
#:start-angle [sa #f] #:end-angle [ea #f]
#:start-pull [sp #f] #:end-pull [ep #f]
#:color [col #f]
#:alpha [alpha 1.0]
#:line-width [lw #f]
#:under? [under? #f]
#:solid? [solid? #t]
#:style [style #f]
#:hide-arrowhead? [hide-arrowhead? #f])
(if (not (or sa ea))
(finish-pin (launder (t:pin-arrow-line sz (ghost p)
src src-find
dest dest-find
#f #f #f solid?
#:hide-arrowhead? hide-arrowhead?
#:style style))
p lw col alpha under?)
(pin-curve* #f (not hide-arrowhead?) p src src-find dest dest-find
sa ea sp ep sz col lw under? solid?
style alpha)))
(define (pin-arrows-line sz p
src src-find
dest dest-find
#:start-angle [sa #f] #:end-angle [ea #f]
#:start-pull [sp #f] #:end-pull [ep #f]
#:color [col #f]
#:alpha [alpha 1.0]
#:line-width [lw #f]
#:under? [under? #f]
#:solid? [solid? #t]
#:style [style #f]
#:hide-arrowhead? [hide-arrowhead? #f])
(if (not (or sa ea))
(finish-pin (launder (t:pin-arrows-line sz (ghost p)
src src-find
dest dest-find
#f #f #f solid?
#:hide-arrowhead? hide-arrowhead?
#:style style))
p lw col alpha under?)
(pin-curve* (not hide-arrowhead?) (not hide-arrowhead?)
p src src-find dest dest-find
sa ea sp ep sz col lw under? solid?
style alpha)))
(define (pin-curve* start-arrow? end-arrow? p
src src-find
dest dest-find
sa ea sp ep
sz col lw
under? solid?
style alpha)
(let-values ([(sx0 sy0) (src-find p src)]
[(dx0 dy0) (dest-find p dest)])
(let* ([sa (or sa
(atan (- sy0 dy0) (- dx0 sx0)))]
[ea (or ea
(atan (- sy0 dy0) (- dx0 sx0)))]
[d (sqrt (+ (* (- dy0 sy0) (- dy0 sy0)) (* (- dx0 sx0) (- dx0 sx0))))]
[sp (* (or sp 1/4) d)]
[ep (* (or ep 1/4) d)])
(let ([dx (if end-arrow? (- dx0 (* sz (cos ea))) dx0)]
[dy (if end-arrow? (+ dy0 (* sz (sin ea))) dy0)]
[sx (if start-arrow? (+ sx0 (* sz (cos sa))) sx0)]
[sy (if start-arrow? (- sy0 (* sz (sin sa))) sy0)]
[path (new dc-path%)]
[maybe-pin-line
(lambda (arrow? p sx sy dx dy)
(if arrow?
(pin-arrow-line
sz
p
p (lambda (a b) (values sx sy))
p (lambda (a b) (values dx dy))
#:line-width lw
#:color col
#:under? under?
#:solid? solid?
#:style style)
p))])
(send path move-to sx sy)
(send path curve-to
(+ sx (* sp (cos sa)))
(- sy (* sp (sin sa)))
(- dx (* ep (cos ea)))
(+ dy (* ep (sin ea)))
dx
dy)
(maybe-pin-line
start-arrow?
(maybe-pin-line
end-arrow?
((if under? pin-under pin-over)
p
0 0
(let* ([p (dc (lambda (dc x y)
(let ([b (send dc get-brush)])
(send dc set-brush "white" 'transparent)
(send dc draw-path path x y)
(send dc set-brush b)))
0 0)]
[p (if col
(colorize p col)
p)]
[p (if (= alpha 1.0)
p
(cellophane p alpha))]
[p (if lw
(linewidth lw p)
p)]
[p (if style
(linestyle style p)
p)])
p))
dx dy dx0 dy0)
sx sy sx0 sy0)))))
(define (finish-pin l p lw col alpha under?)
(let* ([l (if lw
(linewidth lw l)
l)]
[l (if col
(colorize l col)
l)]
[l (if (= alpha 1.0)
l
(cellophane l alpha))])
(if under?
(cc-superimpose l p)
(cc-superimpose p l))))
(define fish
(let ([standard-fish
(lambda (w h
#:direction [direction 'left]
#:color [color "blue"]
#:eye-color [eye-color "black"]
#:open-mouth [open-mouth #f])
(standard-fish w h direction color eye-color open-mouth))])
standard-fish))
(define (pict->bitmap p [smoothing 'aligned])
(define w (pict-width p))
(define h (pict-height p))
(define bm (make-bitmap (max 1 (inexact->exact (ceiling w)))
(max 1 (inexact->exact (ceiling h)))))
(define dc (make-object bitmap-dc% bm))
(send dc set-smoothing smoothing)
(draw-pict p dc 0 0)
bm)
(provide hline vline
frame
pict-path?
pin-line pin-arrow-line pin-arrows-line
(except-out (all-from-out texpict/mrpict)
dash-hline dash-vline
dash-frame oval oval/radius
caps-text
big-circle
picture
cons-picture
cons-picture*
place-over
place-under
record
thick
thin
find-lt
find-lc
find-lb
find-ltl
find-lbl
find-ct
find-cc
find-cb
find-ctl
find-cbl
find-rt
find-rc
find-rb
find-rtl
find-rbl
drop
lift)
(rename-out [drop drop-below-ascent]
[lift lift-above-baseline])
(except-out (all-from-out texpict/utils)
color-frame color-dash-frame
round-frame color-round-frame
cons-colorized-picture
arrow-line
arrows-line
add-line
add-arrow-line
add-arrows-line
explode-star
standard-fish
find-pen find-brush)
(rename-out [fish standard-fish])
pict->bitmap))

View File

@ -0,0 +1,166 @@
#lang racket/base
(require racket/list
racket/math
"main.rkt")
(provide fade-pict
slide-pict
fade-around-pict
sequence-animations
reverse-animations
fast-start
fast-end
fast-edges
fast-middle
split-phase)
(define (fail-gracefully t)
(with-handlers ([exn:fail? (lambda (x) (values 0 0))])
(t)))
(define single-pict (lambda (p) (if (list? p) (last p) p)))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Animation combinators
;; "Morph" from one pict to another. Use `combine' to align
;; the picts relative to another. Only the bounding box is
;; actually morphed; the drawing part transitions by fading
;; the original `a' out and the new `b' in. The `n' argument
;; ranges from 0.0 (= `a') to 1.0 (= `b').
(define (fade-pict #:combine [combine cc-superimpose] n a b)
;; Combine ghosts of scaled pictures:
(let ([orig (combine (cellophane a (- 1.0 n))
(cellophane b n))])
(cond
[(zero? n) (refocus orig a)]
[(= n 1.0) (refocus orig b)]
[else
(let-values ([(atx aty) (ltl-find orig a)]
[(abx aby) (rbl-find orig a)]
[(btx bty) (ltl-find orig b)]
[(bbx bby) (rbl-find orig b)])
(let ([da (+ aty (* (- bty aty) n))]
[dd (- (pict-height orig)
(+ aby (* (- bby aby) n)))]
[orig
;; Generate intermediate last-pict
(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))]
[bb (+ bt (pict-height be))])
(let ([atl (+ at (pict-ascent ae))]
[abl (- ab (pict-descent ae))]
[btl (+ bt (pict-ascent be))]
[bbl (- bb (pict-descent be))]
[btw (lambda (a b)
(+ a (* (- b a) n)))])
(let ([t (btw at bt)]
[l (btw al bl)])
(let ([b (max t (btw ab bb))]
[r (max l (btw ar br))])
(let ([tl (max t (min (btw atl btl) b))]
[bl (max t (min (btw abl bbl) b))])
(let ([p (blank (- r l) (- b t)
(- tl t) (- b bl))])
(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)
da
dd
(list (make-child orig 0 0 1 1 0 0))
#f
(pict-last orig))])
(let ([left (+ atx (* (- btx atx) n))]
[right (+ abx (* (- bbx abx) n))])
(let ([hp (inset p
(- left)
0
(- right (pict-width p))
0)])
(let-values ([(atx aty) (lt-find hp a)]
[(abx aby) (lb-find hp a)]
[(btx bty) (lt-find hp b)]
[(bbx bby) (lb-find hp b)])
(let ([top (+ aty (* (- bty aty) n))]
[bottom (+ aby (* (- bby aby) n))])
(inset hp
0
(- top)
0
(- bottom (pict-height hp))))))))))])))
;; Pin `p' into `base', sliding from `p-from' to `p-to'
;; (which are picts within `base') as `n' goes from 0.0 to 1.0.
;; The `p-from' and `p-to' picts are typically ghosts of
;; `p' within `base', but they can be any picts within
;; `base'. The top-left locations of `p-from' and `p-to'
;; determine the placement of the top-left of `p'.
(define (slide-pict base p p-from p-to n)
(let-values ([(x1 y1) (fail-gracefully (lambda () (lt-find base p-from)))]
[(x2 y2) (fail-gracefully (lambda () (lt-find base p-to)))])
(pin-over base
(+ x1 (* (- x2 x1) n))
(+ y1 (* (- y2 y1) n))
p)))
(define (fade-around-pict n base evolved)
(define tg1 (launder (ghost base)))
(define tg2 (launder (ghost base)))
(slide-pict
(fade-pict n
tg1
(evolved tg2))
base
tg1
tg2
n))
;; Concatenate a sequence of animations
(define (sequence-animations . l)
(let ([len (length l)])
(lambda (n)
(cond
[(zero? n)
((car l) 0.0)]
[(= n 1.0)
((list-ref l (sub1 len)) n)]
[else
(let ([pos (inexact->exact (floor (* n len)))])
((list-ref l pos) (* len (- n (* pos (/ len))))))]))))
;; Reverse a sequence of animations
(define (reverse-animations . l)
(let ([s (apply sequence-animations l)])
(lambda (n)
(s (- 1 n)))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; [0,1] -> [0,1] functions
(define (fast-start n)
(- 1 (* (- 1 n) (- 1 n))))
(define (fast-end n)
(* n n))
(define (fast-edges n)
(+ 0.5 (* (sin (- (* n pi) (/ pi 2))) 0.5)))
(define (fast-middle n)
(- 0.5 (/ (cos (* n pi)) 2)))
(define (split-phase opt-n)
(values (* 2 (min opt-n 0.5))
(* 2 (- (max opt-n 0.5) 0.5))))

View File

@ -135,139 +135,3 @@ and @racket['alts] and produces a procedure suitable for use with
with fades for @racket['next] and @racket['alts] transitions (to
better fit the style, perhaps, of surrounding animations).}
@; --------------------------------------------------
@section{Animation Helpers}
@defproc[(fade-pict [n (real-in 0.0 1.0)] [p1 pict?] [p2 pict?]
[#:combine combine (pict? pict? . -> . pict?) cc-superimpose])
pict?]{
Interpolates @racket[p1] and @racket[p2], where the result with
@racket[n] as @racket[0.0] is @racket[p1], and the result with
@racket[n] as @racket[1.0] is @racket[p2]. For intermediate points,
@racket[p1] fades out while @racket[p2] fades in as @racket[n] changes
from @racket[0.0] to @racket[1.0]. At the same time, the width and
height of the generated pict are intermediate between
@racket[p1] and @racket[p2], and the relative baselines and last
pict correspondingly morph within the bounding box.
The @racket[combine] argument determines how @racket[p1] and
@racket[p2] are aligned for morphing. For example, if @racket[p1] and
@racket[p2] both contain multiple lines of text with the same line
height but different number of lines, then using
@racket[ctl-superimpose] would keep the ascent line in a fixed
location relative to the top of the resulting pict as the rest of the
shape morphs around it.}
@defproc[(fade-around-pict [n (real-in 0.0 1.0)]
[p1 pict?]
[make-p2 (pict? . -> . pict?)])
pict?]{
Similar to @racket[fade-pict], but the target is not a fixed
@racket[_p2], but instead a function @racket[make-p2] that takes a
@racket[launder]ed @racket[ghost] of @racket[p1] and places it into a
larger scene. Also, @racket[p1] does not fade out as @racket[n]
increases; instead, @racket[p1] is placed wherever its ghost appears
in the result of @racket[make-p2].
For example,
@RACKETBLOCK[
(lambda (n)
(fade-around-pict n
(code x)
(lambda (g) (code (+ #,x 1)))))
]
animates the wrapping of @racket[x] with a @racket[(+ .... 1)] form.}
@defproc[(slide-pict [base pict?]
[p pict?]
[p-from pict?]
[p-to pict?]
[n (real-in 0.0 1.0)])
pict?]{
Pins @racket[p] onto @racket[base], sliding from @racket[p-from] to
@racket[p-to] (which are picts within @racket[base]) as
@racket[n] goes from @racket[0.0] to @racket[1.0]. The top-left
locations of @racket[p-from] and @racket[p-to] determine the placement
of the top-left of @racket[p].
The @racket[p-from] and @racket[p-to] picts are typically
@racket[launder]ed @racket[ghost]s of @racket[p] within @racket[base],
but they can be any picts within @racket[base].}
@; --------------------------------------------------
@section{Merging Animations}
@defproc[(sequence-animations [gen (-> (real-in 0.0 1.0) pict?)]
...)
(-> (real-in 0.0 1.0) pict?)]{
Converts a list of @racket[gen] functions into a single function that
uses each @racket[gen] in sequence.}
@defproc[(reverse-animations [gen (-> (real-in 0.0 1.0) pict?)]
...)
(-> (real-in 0.0 1.0) pict?)]{
Converts a list of @racket[gen] functions into a single function that
run @racket[(sequence-animations gen ...)] in reverse.}
@; --------------------------------------------------
@section{Stretching and Squashing Time}
@deftogether[(
@defproc[(fast-start [n (real-in 0.0 1.0)]) (real-in 0.0 1.0)]
@defproc[(fast-end [n (real-in 0.0 1.0)]) (real-in 0.0 1.0)]
@defproc[(fast-edges [n (real-in 0.0 1.0)]) (real-in 0.0 1.0)]
@defproc[(fast-middle [n (real-in 0.0 1.0)]) (real-in 0.0 1.0)]
)]{
Monotonically but non-uniformly maps @racket[n] with fixed
points at @racket[0.0] and @racket[1.0].
The @racket[fast-start] mapping is convex, so that
@racketblock[(slide-pict _base p _p1 _p2 (fast-start n))]
appears to move quickly away from @racket[_p1] and then slowly as it
approaches @racket[_p2], assuming that @racket[n] increases uniformly.
The @racket[fast-end] mapping is concave, so that
@racketblock[(slide-pict _base _p _p1 _p2 (fast-end _n))]
appears to move slowly away from @racket[_p1] and then quicly as it
approaches @racket[_p2], assuming that @racket[_n] increases uniformly.
The @racket[fast-edges] mapping is convex at first and concave at the
end, so that
@racketblock[(slide-pict _base _p _p1 _p2 (fast-edges _n))]
appears to move quickly away from @racket[_p1], then more slowly, and
then quickly again near @racket[_p2], assuming that @racket[_n] increases
uniformly.
The @racket[fast-middle] mapping is concave at first and convex at the
end, so that
@racketblock[(slide-pict _base _p _p1 _p2 (fast-middle _n))]
appears to move slowly away from @racket[_p1], then more quickly, and
then slowly again near @racket[_p2], assuming that @racket[_n] increases
uniformly.}
@defproc[(split-phase [n (real-in 0.0 1.0)])
(values (real-in 0.0 1.0) (real-in 0.0 1.0))]{
Splits the progression of @racket[n] from @racket[0.0] to @racket[1.0]
into a progression from @racket[(values 0.0 0.0)] to @racket[(values
1.0 0.0)] and then @racket[(values 1.0 0.0)] to @racket[(values 1.0
1.0)].}

View File

@ -97,130 +97,6 @@
(apply mid (append pre (list n) (cdr post)))))
(loop (cdr post) (cons 1.0 pre) #f (if (pair? Ns) (cdr Ns) Ns)))))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Animation combinators
;; "Morph" from one pict to another. Use `combine' to align
;; the picts relative to another. Only the bounding box is
;; actually morphed; the drawing part transitions by fading
;; the original `a' out and the new `b' in. The `n' argument
;; ranges from 0.0 (= `a') to 1.0 (= `b').
(define (fade-pict #:combine [combine cc-superimpose] n a b)
;; Combine ghosts of scaled pictures:
(let ([orig (combine (cellophane a (- 1.0 n))
(cellophane b n))])
(cond
[(zero? n) (refocus orig a)]
[(= n 1.0) (refocus orig b)]
[else
(let-values ([(atx aty) (ltl-find orig a)]
[(abx aby) (rbl-find orig a)]
[(btx bty) (ltl-find orig b)]
[(bbx bby) (rbl-find orig b)])
(let ([da (+ aty (* (- bty aty) n))]
[dd (- (pict-height orig)
(+ aby (* (- bby aby) n)))]
[orig
;; Generate intermediate last-pict
(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))]
[bb (+ bt (pict-height be))])
(let ([atl (+ at (pict-ascent ae))]
[abl (- ab (pict-descent ae))]
[btl (+ bt (pict-ascent be))]
[bbl (- bb (pict-descent be))]
[btw (lambda (a b)
(+ a (* (- b a) n)))])
(let ([t (btw at bt)]
[l (btw al bl)])
(let ([b (max t (btw ab bb))]
[r (max l (btw ar br))])
(let ([tl (max t (min (btw atl btl) b))]
[bl (max t (min (btw abl bbl) b))])
(let ([p (blank (- r l) (- b t)
(- tl t) (- b bl))])
(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)
da
dd
(list (make-child orig 0 0 1 1 0 0))
#f
(pict-last orig))])
(let ([left (+ atx (* (- btx atx) n))]
[right (+ abx (* (- bbx abx) n))])
(let ([hp (inset p
(- left)
0
(- right (pict-width p))
0)])
(let-values ([(atx aty) (lt-find hp a)]
[(abx aby) (lb-find hp a)]
[(btx bty) (lt-find hp b)]
[(bbx bby) (lb-find hp b)])
(let ([top (+ aty (* (- bty aty) n))]
[bottom (+ aby (* (- bby aby) n))])
(inset hp
0
(- top)
0
(- bottom (pict-height hp))))))))))])))
;; Pin `p' into `base', sliding from `p-from' to `p-to'
;; (which are picts within `base') as `n' goes from 0.0 to 1.0.
;; The `p-from' and `p-to' picts are typically ghosts of
;; `p' within `base', but they can be any picts within
;; `base'. The top-left locations of `p-from' and `p-to'
;; determine the placement of the top-left of `p'.
(define (slide-pict base p p-from p-to n)
(let-values ([(x1 y1) (fail-gracefully (lambda () (lt-find base p-from)))]
[(x2 y2) (fail-gracefully (lambda () (lt-find base p-to)))])
(pin-over base
(+ x1 (* (- x2 x1) n))
(+ y1 (* (- y2 y1) n))
p)))
(define (fade-around-pict n base evolved)
(define tg1 (launder (ghost base)))
(define tg2 (launder (ghost base)))
(slide-pict
(fade-pict n
tg1
(evolved tg2))
base
tg1
tg2
n))
;; Concatenate a sequence of animations
(define (sequence-animations . l)
(let ([len (length l)])
(lambda (n)
(cond
[(zero? n)
((car l) 0.0)]
[(= n 1.0)
((list-ref l (sub1 len)) n)]
[else
(let ([pos (inexact->exact (floor (* n len)))])
((list-ref l pos) (* len (- n (* pos (/ len))))))]))))
;; Reverse a sequence of animations
(define (reverse-animations . l)
(let ([s (apply sequence-animations l)])
(lambda (n)
(s (- 1 n)))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Like `slide', supports 'next and 'alts, but produces as a
@ -283,23 +159,5 @@
(k (if p2 (vc-append gap-size p p2) p) ns)))))])))
(sub1 n))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; [0,1] -> [0,1] functions
(define (fast-start n)
(- 1 (* (- 1 n) (- 1 n))))
(define (fast-end n)
(* n n))
(define (fast-edges n)
(+ 0.5 (* (sin (- (* n pi) (/ pi 2))) 0.5)))
(define (fast-middle n)
(- 0.5 (/ (cos (* n pi)) 2)))
(define (split-phase opt-n)
(values (* 2 (min opt-n 0.5))
(* 2 (- (max opt-n 0.5) 0.5))))