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
parent
a1331fbd1f
commit
59e92d7d39
146
pkgs/pict-pkgs/pict-doc/pict/scribblings/anim.scrbl
Normal file
146
pkgs/pict-pkgs/pict-doc/pict/scribblings/anim.scrbl
Normal 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)].}
|
||||||
|
|
@ -887,6 +887,10 @@ pict with the same shape and location.}
|
||||||
|
|
||||||
@; ----------------------------------------
|
@; ----------------------------------------
|
||||||
|
|
||||||
|
@include-section["anim.scrbl"]
|
||||||
|
|
||||||
|
@; ----------------------------------------
|
||||||
|
|
||||||
@section{Miscellaneous}
|
@section{Miscellaneous}
|
||||||
|
|
||||||
@defproc[(hyperlinkize [pict pict?])
|
@defproc[(hyperlinkize [pict pict?])
|
||||||
|
|
|
||||||
|
|
@ -1,288 +1,28 @@
|
||||||
(module pict scheme/base
|
#lang racket/base
|
||||||
(require (rename-in texpict/mrpict
|
(require "private/main.rkt"
|
||||||
[hline t:hline]
|
racket/contract
|
||||||
[vline t:vline]
|
racket/class
|
||||||
[frame t:frame])
|
racket/draw)
|
||||||
(rename-in texpict/utils
|
(provide
|
||||||
[pin-line t:pin-line]
|
(except-out (all-from-out "private/main.rkt")
|
||||||
[pin-arrow-line t:pin-arrow-line]
|
pict->bitmap)
|
||||||
[pin-arrows-line t:pin-arrows-line])
|
(contract-out
|
||||||
(only-in racket/draw dc-path% make-bitmap bitmap% bitmap-dc%)
|
[pict->bitmap (->* (pict?)
|
||||||
(only-in racket/class new send make-object is-a?/c)
|
((or/c 'unsmoothed 'smoothed 'aligned))
|
||||||
racket/contract)
|
(is-a?/c bitmap%))]))
|
||||||
|
|
||||||
(define (hline w h #:segment [seg #f])
|
(require "private/play-pict.rkt")
|
||||||
(if seg
|
(provide
|
||||||
(dash-hline w h seg)
|
(contract-out
|
||||||
(t:hline w h)))
|
[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?)]
|
||||||
(define (vline w h #:segment [seg #f])
|
[fade-around-pict (-> (real-in 0.0 1.0) pict? (-> pict? pict?) pict?)]
|
||||||
(if seg
|
[sequence-animations (->* () #:rest (listof (-> (real-in 0.0 1.0) pict?))
|
||||||
(dash-vline w h seg)
|
(-> (real-in 0.0 1.0) pict?))]
|
||||||
(t:vline w h)))
|
[reverse-animations (->* () #:rest (listof (-> (real-in 0.0 1.0) pict?))
|
||||||
|
(-> (real-in 0.0 1.0) pict?))]
|
||||||
(define (frame p
|
[fast-start (-> (real-in 0.0 1.0) (real-in 0.0 1.0))]
|
||||||
#:color [col #f]
|
[fast-end (-> (real-in 0.0 1.0) (real-in 0.0 1.0))]
|
||||||
#:line-width [lw #f]
|
[fast-edges (-> (real-in 0.0 1.0) (real-in 0.0 1.0))]
|
||||||
#:segment [seg #f])
|
[fast-middle (-> (real-in 0.0 1.0) (real-in 0.0 1.0))]
|
||||||
(let* ([f (if seg
|
[split-phase (-> (real-in 0.0 1.0) (values (real-in 0.0 1.0) (real-in 0.0 1.0)))]))
|
||||||
(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])
|
|
||||||
(contract-out [pict->bitmap ((pict?) ((one-of/c 'unsmoothed 'smoothed 'aligned))
|
|
||||||
. ->* . (is-a?/c bitmap%))])
|
|
||||||
))
|
|
||||||
|
|
|
||||||
285
pkgs/pict-pkgs/pict-lib/pict/private/main.rkt
Normal file
285
pkgs/pict-pkgs/pict-lib/pict/private/main.rkt
Normal 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))
|
||||||
166
pkgs/pict-pkgs/pict-lib/pict/private/play-pict.rkt
Normal file
166
pkgs/pict-pkgs/pict-lib/pict/private/play-pict.rkt
Normal 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))))
|
||||||
|
|
||||||
|
|
@ -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
|
with fades for @racket['next] and @racket['alts] transitions (to
|
||||||
better fit the style, perhaps, of surrounding animations).}
|
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)].}
|
|
||||||
|
|
|
||||||
|
|
@ -97,130 +97,6 @@
|
||||||
(apply mid (append pre (list n) (cdr post)))))
|
(apply mid (append pre (list n) (cdr post)))))
|
||||||
(loop (cdr post) (cons 1.0 pre) #f (if (pair? Ns) (cdr Ns) Ns)))))))
|
(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
|
;; 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)))))])))
|
(k (if p2 (vc-append gap-size p p2) p) ns)))))])))
|
||||||
(sub1 n))))
|
(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))))
|
|
||||||
|
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user