From 59e92d7d3983feb3c4635f5c28171f256d95ff84 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 5 Nov 2013 15:11:25 -0600 Subject: [PATCH] split up slideshow/play so that the pict-only parts are in pict-lib and don't depend on racket/gui/base --- .../pict-doc/pict/scribblings/anim.scrbl | 146 ++++++++ .../pict-doc/pict/scribblings/pict.scrbl | 4 + pkgs/pict-pkgs/pict-lib/pict/main.rkt | 314 ++---------------- pkgs/pict-pkgs/pict-lib/pict/private/main.rkt | 285 ++++++++++++++++ .../pict-lib/pict/private/play-pict.rkt | 166 +++++++++ .../scribblings/slideshow/play.scrbl | 136 -------- .../slideshow-lib/slideshow/play.rkt | 142 -------- 7 files changed, 628 insertions(+), 565 deletions(-) create mode 100644 pkgs/pict-pkgs/pict-doc/pict/scribblings/anim.scrbl create mode 100644 pkgs/pict-pkgs/pict-lib/pict/private/main.rkt create mode 100644 pkgs/pict-pkgs/pict-lib/pict/private/play-pict.rkt diff --git a/pkgs/pict-pkgs/pict-doc/pict/scribblings/anim.scrbl b/pkgs/pict-pkgs/pict-doc/pict/scribblings/anim.scrbl new file mode 100644 index 0000000000..5079d767be --- /dev/null +++ b/pkgs/pict-pkgs/pict-doc/pict/scribblings/anim.scrbl @@ -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)].} diff --git a/pkgs/pict-pkgs/pict-doc/pict/scribblings/pict.scrbl b/pkgs/pict-pkgs/pict-doc/pict/scribblings/pict.scrbl index cba1ed1d07..9770ce94e9 100644 --- a/pkgs/pict-pkgs/pict-doc/pict/scribblings/pict.scrbl +++ b/pkgs/pict-pkgs/pict-doc/pict/scribblings/pict.scrbl @@ -887,6 +887,10 @@ pict with the same shape and location.} @; ---------------------------------------- +@include-section["anim.scrbl"] + +@; ---------------------------------------- + @section{Miscellaneous} @defproc[(hyperlinkize [pict pict?]) diff --git a/pkgs/pict-pkgs/pict-lib/pict/main.rkt b/pkgs/pict-pkgs/pict-lib/pict/main.rkt index 98eb6d9330..91e919a5a7 100644 --- a/pkgs/pict-pkgs/pict-lib/pict/main.rkt +++ b/pkgs/pict-pkgs/pict-lib/pict/main.rkt @@ -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)))])) diff --git a/pkgs/pict-pkgs/pict-lib/pict/private/main.rkt b/pkgs/pict-pkgs/pict-lib/pict/private/main.rkt new file mode 100644 index 0000000000..8c7f0081b2 --- /dev/null +++ b/pkgs/pict-pkgs/pict-lib/pict/private/main.rkt @@ -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)) diff --git a/pkgs/pict-pkgs/pict-lib/pict/private/play-pict.rkt b/pkgs/pict-pkgs/pict-lib/pict/private/play-pict.rkt new file mode 100644 index 0000000000..5546861dd9 --- /dev/null +++ b/pkgs/pict-pkgs/pict-lib/pict/private/play-pict.rkt @@ -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)))) + diff --git a/pkgs/slideshow-pkgs/slideshow-doc/scribblings/slideshow/play.scrbl b/pkgs/slideshow-pkgs/slideshow-doc/scribblings/slideshow/play.scrbl index 8c91d44a8a..1db2ced46d 100644 --- a/pkgs/slideshow-pkgs/slideshow-doc/scribblings/slideshow/play.scrbl +++ b/pkgs/slideshow-pkgs/slideshow-doc/scribblings/slideshow/play.scrbl @@ -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)].} diff --git a/pkgs/slideshow-pkgs/slideshow-lib/slideshow/play.rkt b/pkgs/slideshow-pkgs/slideshow-lib/slideshow/play.rkt index a9d630a08a..1d2c6ac6f8 100644 --- a/pkgs/slideshow-pkgs/slideshow-lib/slideshow/play.rkt +++ b/pkgs/slideshow-pkgs/slideshow-lib/slideshow/play.rkt @@ -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))))