305 lines
11 KiB
Racket
305 lines
11 KiB
Racket
#lang scheme/base
|
|
(require slideshow/base
|
|
slideshow/pict
|
|
scheme/list
|
|
scheme/math)
|
|
|
|
(provide play play-n
|
|
fade-pict
|
|
slide-pict
|
|
fade-around-pict
|
|
sequence-animations
|
|
reverse-animations
|
|
animate-slide
|
|
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 player
|
|
|
|
;; Create a slide sequence where `mid' takes a number from 0.0 to 1.0.
|
|
;; The 0.0 slide will wit until you advance, but the remaining ones will
|
|
;; time out automatically to create the animation.
|
|
(define (play #:title [title #f]
|
|
#:name [name title]
|
|
#:layout [layout 'auto]
|
|
#:steps [N 10]
|
|
#:delay [secs 0.05]
|
|
#:skip-first? [skip-first? #f]
|
|
mid)
|
|
(unless skip-first?
|
|
(slide #:title (if (procedure? title) (title 0) title)
|
|
#:name (if (procedure? name) (name 0) name)
|
|
#:layout layout
|
|
(mid 0)))
|
|
(if condense?
|
|
(skip-slides N)
|
|
(map (lambda (n)
|
|
(slide #:title (if (procedure? title) (title n) title)
|
|
#:name (if (procedure? name) (name n) name)
|
|
#:layout layout
|
|
#:timeout secs
|
|
(mid n)))
|
|
(let ([cnt N])
|
|
(let loop ([n cnt])
|
|
(if (zero? n)
|
|
null
|
|
(cons (/ (- cnt -1 n) 1.0 cnt)
|
|
(loop (sub1 n)))))))))
|
|
|
|
;; Create a sequences of N `play' sequences, where `mid' takes
|
|
;; N arguments, each a number between 0.0 and 1.0. Initially, all
|
|
;; arguments will be 0.0. The first argument goes from 0.0 to 1.0
|
|
;; for the first `play' sequence, and then it stays at 1.0 while
|
|
;; the second goes from 0.0 to 1.0 for the second sequence, etc.
|
|
(define (play-n #:title [title #f]
|
|
#:name [name title]
|
|
#:layout [layout 'auto]
|
|
#:steps [N 10]
|
|
#:delay [secs 0.05]
|
|
#:skip-last? [skip-last? #f]
|
|
#:skip-first? [skip-first? #f]
|
|
mid)
|
|
(let ([n (procedure-arity mid)])
|
|
(let loop ([post (vector->list (make-vector n))]
|
|
[pre null]
|
|
[skip? skip-first?])
|
|
(if (null? post)
|
|
(unless skip-last?
|
|
(slide #:title (if (procedure? title) (apply title pre) title)
|
|
#:name (if (procedure? name) (apply name pre) name)
|
|
#:layout layout
|
|
(apply mid pre)))
|
|
(begin
|
|
(play #:title (if (procedure? title)
|
|
(lambda (n)
|
|
(apply title (append pre (list n) (cdr post))))
|
|
title)
|
|
#:name (if (procedure? name)
|
|
(lambda (n)
|
|
(apply name (append pre (list n) (cdr post))))
|
|
name)
|
|
#:layout layout
|
|
#:steps N
|
|
#:delay secs
|
|
#:skip-first? skip?
|
|
(lambda (n)
|
|
(apply mid (append pre (list n) (cdr post)))))
|
|
(loop (cdr post) (cons 1.0 pre) #f))))))
|
|
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; 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))
|
|
#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
|
|
;; function of N number arguments (for N stages)
|
|
(define (animate-slide . content)
|
|
(let ([n (let loop ([content content])
|
|
(cond
|
|
[(null? content) 1]
|
|
[(eq? (car content) 'next)
|
|
(add1 (loop (cdr content)))]
|
|
[(eq? (car content) 'alts)
|
|
(+ (apply + (map (lambda (alt)
|
|
(loop alt))
|
|
(cadr content)))
|
|
(sub1 (loop (cddr content))))]
|
|
[else (loop (cdr content))]))])
|
|
(procedure-reduce-arity
|
|
(lambda ns
|
|
(let loop ([content content]
|
|
[ns (cons 1.0 ns)]
|
|
[k (lambda (p ns) (or p (blank)))])
|
|
(cond
|
|
[(null? content) (k #f ns)]
|
|
[(eq? 'next (car content))
|
|
(loop (cdr content)
|
|
(cdr ns)
|
|
k)]
|
|
[(eq? 'alts (car content))
|
|
(let aloop ([l (cadr content)]
|
|
[p (blank)]
|
|
[ns ns])
|
|
(if (null? l)
|
|
(loop (cddr content)
|
|
ns
|
|
(lambda (p2 ns)
|
|
(k (if p2 (vc-append gap-size p p2) p) ns)))
|
|
(loop (car l)
|
|
ns
|
|
(lambda (p2 ns2)
|
|
(aloop (cdr l)
|
|
(cellophane
|
|
(if p2
|
|
(ct-superimpose
|
|
p
|
|
p2)
|
|
p)
|
|
(if (null? (cdr l))
|
|
1.0
|
|
(- 1.0 (min 1.0 (* 2 (cadr ns2))))))
|
|
(if (null? (cdr l))
|
|
ns2
|
|
(let ([ns (cdr ns2)])
|
|
(cons (max 0.0 (* 2 (- (car ns) 0.5)))
|
|
(cdr ns)))))))))]
|
|
[else (vc-append
|
|
gap-size
|
|
(let ([p (cellophane (car content) (car ns))])
|
|
(loop (cdr content) ns
|
|
(lambda (p2 ns)
|
|
(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))))
|
|
|