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}
|
||||
|
||||
@defproc[(hyperlinkize [pict pict?])
|
||||
|
|
|
|||
|
|
@ -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)))]))
|
||||
|
|
|
|||
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
|
||||
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)))))
|
||||
(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))))
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user