#lang slideshow
(require "castle.ss"
"princess.ss"
"well.ss"
"thought.ss"
"poster.ss"
"things.ss"
slideshow/play)
(provide movie-slides
kingdom
million-well
plt-bm
play-it)
(define (princess-in-castle n)
(let-values ([(x y w h) (send window-path get-bounding-box)]
[(p) (make-princess)])
(let ([pw (pict-width p)]
[ph (pict-height p)])
(let ([dx (/ (- w pw) 2)]
[dy (* n -15)])
(pin-over castle
(+ x dx) (+ y dy)
(make-princess #:clip-body window-path
#:clip-dx (- (+ x dx))
#:clip-dy (- (+ y dy))))))))
(define kingdom
(let ([well (scale well 0.25)])
(cb-superimpose
(inset castle 0 0 0 40)
(hc-append
gap-size
well
(vc-append
(hc-append
(* 8 gap-size)
well
(inset well 0 20 0 0))
(hc-append
(* 2 gap-size)
(inset well 0 -30 0 0)
well
(inset well 0 20 0 0)
well))
(inset well 0 0 0 40)))))
(slide (hb-append gap-size
(frame (scale (make-princess #:side 'right) 2))
(frame (scale (make-princess #:side 'left) 2))
castle
(scale (make-princess) 2)
well+sign))
(define p (make-princess))
(define (play-it #:name [name #f] times proc #:skip-last? [skip-last? #f])
(let loop ([times times]
[ns (map (lambda (n) 0.0) times)]
[prevs null])
(if (null? ns)
(unless skip-last?
(slide #:name name (apply proc prevs)))
(let* ([a (car times)]
[ns (cdr ns)]
[N (car a)])
(for ([i (in-range N)])
(slide (apply proc (append prevs (list (/ i N)) ns))
#:name name
#:timeout (cadr a)))
(let ([prevs (cons 1.0 prevs)])
(loop (cdr times) ns prevs))))))
(define-syntax-rule (play-all #:name t ([id0 steps0 delay0] ...) ([id steps delay] ...) expr . rest)
(play-it
#:name t
'([steps delay] ...)
(lambda (id ...)
(let ([id0 1.0] ...)
expr))
. rest))
(define plt-bm (bitmap (build-path (collection-path "icons") "PLT-206.png")))
(define (person s where)
(vc-append
(current-line-sep)
(colorize (t s) "blue")
(scale (t where) 0.8)))
(define (toward-well* title? sign-n hooray-n n01 n01.5 n02 n03 n n2 n3 n4 extra-dx leg-n catch? step? make-princess f)
(define n0 (+ n01 n02 n03))
(let* ([princess (make-princess #:side (if (or (= n4 1.0)
(< 0.0 n01.5 1.0)
(and (= 1.0 n01) (= 0.0 n01.5)))
'front
'right)
#:arm-angle (if (or (= n 1.0) (> n2 0.0))
(if (= n3 0.0)
0.0
(if catch?
(* pi 4/10)
(* (/ pi 10) (sin (* 10 leg-n)))))
(* (/ pi 10) (sin (* 10 (if (= 3.0 n0) n n0)))))
#:front-arm-angle (if (zero? hooray-n)
0.0
(/ pi 2))
#:leg-angle (if (= leg-n 1.0)
0.0
(* (/ pi 10) (sin (* 10 (if (or step? (= 3.0 n0)) leg-n n0))))))]
[princess (inset princess 0 (- (* 10 (sin (* pi hooray-n)))) 0 0)])
(values
(let ([p (hb-append
gap-size
(scale
(pin-over
(ht-append (blank 120 0) (ghost p))
(+ (* n 100) extra-dx (* (- 1 n01) -175))
(* (sin (* n3 pi)) -10)
(f princess))
2.0)
(let ([target (ghost (launder well+sign))])
(refocus
(lc-superimpose
target
(inset (well+sign* sign-n) (* (- 1 n03) 440) 0 0 0))
target)))])
(if title?
(refocus
(cc-superimpose
(let* ([title (vc-append
(* gap-size 4)
(vc-append
(* 2 (current-line-sep))
(titlet "Scribble")
(scale
(titlet "Closing the Book on Ad Hoc Documentaton Tools")
0.8))
plt-bm
(hbl-append
(* 3 gap-size)
(person "Matthew Flatt" "University of Utah")
(person "Eli Barzilay" "Northeastern University")
(person "Robert Bruce Findler" "Northwestern University")))]
[title-slide (cc-superimpose
full-page
title)]
[target (ghost title-slide)]
[offset (* n02 -1024)])
(if (= n02 1.0)
target
(refocus
(lc-superimpose
target
(inset title-slide offset 0 0 0))
target)))
p)
p)
p))
princess)))
(define (toward-well title? sign-n hooray-n n01 n01.5 n02 n03 n n2 n3 n4 extra-dx leg-n catch? step? make-princess f)
(let-values ([(p princess) (toward-well* title? sign-n hooray-n n01 n01.5 n02 n03 n n2 n3 n4 extra-dx leg-n
catch? step? make-princess f)])
p))
(define-syntax-rule (play-all/well #:name t (pre-step ...) (n02 n03 n n2 n3 n4) (step ...) (more-step ...) expr ...)
(play-all #:name t
()
(pre-step
...
[n02 20 0.05]
[n03 22 0.05]
[n 20 0.05]
[n2 1 0.65]
[n3 5 0.05]
[n4 1 0.5]
step ...
more-step ...)
expr ...))
(define (castle-thought princess castle wish-n castle-n wish-granted-n fade-n)
(thought
(pin-over
princess
(- (* 1.5 (pict-width castle)))
(- (* 0.5 (pict-height castle)))
(cellophane castle (min castle-n (- 1 fade-n))))
princess
castle
wish-n
(fast-start wish-granted-n)
#:wrap-thought (lambda (t)
(cellophane t (- 1 fade-n)))))
(define (million-thought p princess amt thought-grow-n million-thought-n thought-gone-n fade-n)
(let-values ([(cx cy) (cc-find p one-in-sign)]
[(million) (let ([p (million-text (/ pi 10))]
[p2 (million-text (/ pi 10) #:amt amt)])
(cc-superimpose
(poster (million-text 0) p (/ pi 10))
p2))])
(thought (pin-over p
(- cx (/ (pict-width million) 2))
(- cy (/ (pict-height million) 2))
(cellophane million (min million-thought-n (- 1 fade-n))))
princess
million
thought-grow-n
thought-gone-n
#:wrap-thought (lambda (t)
(cellophane t (- 1 fade-n))))))
(define (white-out p n)
(if (zero? n)
p
(cc-superimpose
p
(cellophane (colorize (filled-rectangle client-w client-h) "white")
n))))
(define (princess1-slides)
(play-all/well
#:name "Princess 1"
([n00 1 #f]
[n01 17 0.05]
[pause1-n 1 #f]
[n01.5 10 0.05])
(n02
n03
n
n2
n3
n4)
()
([pre-sign-pause 1 #f]
[sign-n 10 0.05]
[pre-wish-pause-n 1 #f]
[thought1-n 10 0.05]
[castle-thought-n 10 0.05]
[castle-wish-wait 1 0.5]
[thought3-n 10 0.05]
[to-castle-n 20 0.05]
[castle-pause-n 1 0.25]
[in-castle-n 10 0.05]
[the-end 1 #f]
[fade-out-n 5 0.05]
[final-pause-n 1 0.25])
(white-out
(toward-well
#t sign-n 0.0
n01 n01.5 n02 n03 n n2 n3 n4
0 n #t #f
make-princess
(lambda (princess)
(let* ([castle (scale (if (= in-castle-n 0.0)
castle
(princess-in-castle (fast-start in-castle-n)))
0.5)]
[pre-wish (castle-thought princess castle
thought1-n castle-thought-n thought3-n
0.0)])
(cond
[(zero? to-castle-n) pre-wish]
[else (let ([p (ghost pre-wish)])
(let-values ([(cx cy) (lt-find p castle)]
[(px py) (lb-find p princess)]
[(p2) (make-princess #:side 'left
#:arm-angle (* (/ pi 10) (sin (* 10 to-castle-n)))
#:leg-angle (* (/ pi 10) (sin (* 20 to-castle-n))))])
((if (to-castle-n . > . 0.8)
(if (= to-castle-n 1.0)
(lambda (p p2 x y) p)
pin-under )
pin-over)
(pin-over
p
(+ cx (* to-castle-n (pict-width castle) 1/4))
(- cy (* to-castle-n (pict-height castle) 1/4))
(scale castle (+ (* to-castle-n 0.5) 1.0)))
(- px (* to-castle-n (- px (+ cx (* (pict-width castle) 0.75)))))
(+ py (* to-castle-n 0.25 gap-size))
(scale (inset p2 0 (- (pict-height p2)) 0 0) (- 1 (* to-castle-n 0.75))))))]))))
fade-out-n)
#:skip-last? #t))
(define (princess3-slides)
(play-all/well
#:name "Princess 3"
([fade-in-n 5 0.05]
[pre-walk-pause-n 1 0.5]
[n01.5 1 0.25])
(n02
n03
n
n2
n3
n4)
([wish-pause-n 1 #f]
[castle-wish-n 10 0.05]
[castle-wish-no-n 10 0.05]
[castle-wish-fade-n 5 0.05]
[no-pause1-n 1 0.5]
[million-wish-n 10 0.05]
[million-wish-no-n 10 0.05]
[million-wish-fade-n 5 0.05]
[no-pause2-n 1 0.5]
[kingdom-wish-pause 1 #f]
[kingdom-wish-thought-n 10 0.05]
[kingdom-wish-n 10 0.05]
[kingdom-wish-pause-n 1 0.5])
([kingdom-wish-granted-n 10 0.05]
[kingdom-pause-n 1 #f]
[walk1-n 20 0.05]
[wish1-grow-n 10 0.05]
[wish1-done-n 10 0.05]
[wish1-drop-n 10 0.05]
[wish1-walk-n 10 0.05]
[wish2-grow-n 10 0.05]
[wish2-done-n 10 0.05]
[wish2-drop-n 10 0.05]
[wish2-walk-n 10 0.05]
[wish3-grow-n 10 0.05]
[wish3-done-n 10 0.05]
[wish3-drop-n 10 0.05]
[wish3-walk-n 10 0.05]
[jump-pause-n 1 0.75]
[hooray-n 10 0.05]
[the-end-n 1 #f]
[the-end-in-n 5 0.05]
[fade-out-n 5 0.05])
(cc-superimpose
(white-out
(let-values ([(wish-no-n wish-fade-n)
(if (zero? million-wish-n)
(values castle-wish-no-n castle-wish-fade-n)
(values million-wish-no-n million-wish-fade-n))])
(let-values ([(p princess)
(toward-well*
#f 1.0 hooray-n
1.0 n01.5 n02
(if (= 1.0 n4)
(- 1 walk1-n)
n03)
n
n2 n3 n4
0 (+ n
walk1-n
(/ (+ wish1-grow-n wish1-done-n
wish1-drop-n wish1-walk-n
wish2-grow-n wish2-done-n
wish2-drop-n wish2-walk-n
wish3-grow-n wish3-done-n
wish3-drop-n wish3-walk-n)
2))
(or (< 0.0 wish1-walk-n 1.0)
(< 0.0 wish2-walk-n 1.0)
(< 0.0 wish3-walk-n 1.0))
(positive? walk1-n)
(make-keyword-procedure
(lambda (kws kw-vals . args)
(keyword-apply make-princess
(remq '#:side kws)
(remk #'side kws kw-vals)
#:dress "violet"
#:hair "gold"
#:smile? (not (and (< 0.0 wish-no-n)
(< wish-fade-n 1.0)))
#:shake (* 2 (sin (* 2 pi wish-no-n)))
#:side (if (or (zero? walk1-n)
(= 1 wish3-walk-n))
(assk '#:side kws kw-vals)
'left)
args)))
(lambda (princess)
(let* ([castle (scale castle 0.5)]
[pre-wish (castle-thought princess castle
castle-wish-n castle-wish-n 0.0
castle-wish-fade-n)]
[drop-n (+ wish1-drop-n wish1-walk-n)]
[focus-pre-wish pre-wish]
[pre-wish (inset pre-wish
(* (pict-width princess) 2)
(* (pict-height princess) 0.5)
0
0)]
[pre-wish (wish-thought pre-wish
princess
(scale diamond 0.5)
wish1-grow-n
wish1-done-n
drop-n
drop-n)]
[drop-n (+ wish2-drop-n wish2-walk-n)]
[pre-wish (wish-thought pre-wish
princess
(scale ice-cream 0.5)
wish2-grow-n
wish2-done-n
drop-n
drop-n)]
[drop-n (+ wish3-drop-n wish3-walk-n)]
[pre-wish (wish-thought pre-wish
princess
(scale fishbowl 0.5)
wish3-grow-n
wish3-done-n
drop-n
drop-n)])
(refocus pre-wish focus-pre-wish))))])
(let ([p (million-thought p
princess
"1,000,000"
million-wish-n
million-wish-n
0.0
million-wish-fade-n)]
[kingdom (let* ([k (scale kingdom 0.5)]
[target (ghost (launder k))])
(if (= walk1-n 1.0)
target
(refocus
(lt-superimpose
target
(inset k (* walk1-n -350) (* walk1-n -100) 0 0))
target)))])
(let ([p2 (castle-thought (ghost princess) kingdom
kingdom-wish-thought-n kingdom-wish-n
kingdom-wish-granted-n
0.0)])
(let-values ([(x y) (lt-find p princess)])
(add-well
(add-well
(add-well (pin-under p x y p2)
(+ wish1-grow-n wish1-done-n
wish1-drop-n wish1-walk-n))
(+ wish2-grow-n wish2-done-n
wish2-drop-n wish2-walk-n))
(+ wish3-grow-n wish3-done-n
wish3-drop-n wish3-walk-n)))))))
(if (= 1 fade-in-n n)
fade-out-n
(- 1 fade-in-n)))
(cellophane
(scale
(vc-append
(- (/ gap-size 2))
(text "The End" "Brush Script MT Italic" 42))
2)
the-end-in-n))))
(define (add-well p n)
(if (or (zero? n)
(n . > . 4.0))
p
(let ([well (scale well 0.75)])
(refocus
(cc-superimpose
(pin-over titleless-page
(- (* n 3/8 client-w) (pict-width well) 10)
(- (/ client-h 2) (pict-height well))
well)
p)
p))))
(define (million-text rotation #:amt [amt "1,000,000"])
(text amt 'roman (current-font-size) rotation))
(define-syntax play-all/well/cycle
(syntax-rules ()
[(_ #:name t (pre ...) (id ...) (post ...) () (after ...) expr ...)
(play-all/well #:name t (pre ...) (id ...) () (post ... after ...) expr ...)]
[(_ #:name t (pre ...) (id ...) (post ...) ([return-n] . rest) (after ...) expr ...)
(play-all/well/cycle
#:name t
(pre ...)
(id ...)
(post ...
[return-n 10 0.05])
rest
(after ...)
expr ...)]
[(_ #:name t (pre ...) (id ...) (post ...) (wish-grow-n wish-gone-n wish-drop-n wish-back-n . rest) (after ...) expr ...)
(play-all/well/cycle
#:name t
(pre ...)
(id ...)
(post ...
[wish-grow-n 10 0.05]
[wish-gone-n 10 0.05]
[wish-drop-n 10 0.05]
[wish-back-n 10 0.05])
rest
(after ...)
expr ...)]))
(define (pick n n2 a b c)
(if (zero? n) a (if (zero? n2) b c)))
(define (remk kw kws kw-vals)
(let loop ([kws kws][kw-vals kw-vals])
(if (null? kws)
null
(if (eq? (car kws) kw)
(cdr kw-vals)
(cons (car kw-vals) (loop (cdr kws) (cdr kw-vals)))))))
(define (assk kw kws kw-vals)
(let loop ([kws kws][kw-vals kw-vals])
(if (eq? (car kws) kw)
(car kw-vals)
(loop (cdr kws) (cdr kw-vals)))))
(define (princess2-slides)
(play-all/well/cycle
#:name "Princess 2"
([fade-in-n 5 0.05]
[pre-walk-pause-n 1 0.5]
[n01.5 1 0.5])
(n02
n03
n
n2
n3
n4)
([wish-pause-n 1 #f]
[thought-grow-n 10 0.05]
[million-thought-n 10 0.05]
[million-wish-wait 1 1.0]
[thought-gone-n 10 0.05])
(wish1-grow-n
wish1-gone-n
wish1-drop-n
wish1-back-n
[wish2-return-n]
wish2-grow-n
wish2-gone-n
wish2-drop-n
wish2-back-n
[wish3-return-n]
wish3-grow-n
wish3-gone-n
wish3-drop-n
wish3-back-n
[wish4-return-n])
([jump-pause-n 1 0.75]
[hooray-n 10 0.05]
[pause-n 1 #f]
[fade-out-n 5 0.05]
[transition-pause-n 1 0.25])
(white-out
(let* ([wish-grow-n (if (zero? wish4-return-n)
(pick wish2-return-n wish3-return-n wish1-grow-n wish2-grow-n wish3-grow-n)
0.0)]
[wish-gone-n (pick wish2-return-n wish3-return-n wish1-gone-n wish2-gone-n wish3-gone-n)]
[drop-n (if (zero? wish4-return-n)
(pick wish2-return-n wish3-return-n wish1-drop-n wish2-drop-n wish3-drop-n)
0.0)]
[back-n (if (zero? wish4-return-n)
(pick wish2-return-n wish3-return-n wish1-back-n wish2-back-n wish3-back-n)
0.0)]
[returning? (or (< 0.0 wish2-return-n 1.0)
(< 0.0 wish3-return-n 1.0))]
[return-n (if (< 0.0 wish2-return-n 1.0)
wish2-return-n
wish3-return-n)]
[gen-n (if (zero? wish4-return-n)
(if returning?
return-n
(min n (- 1 back-n)))
0.0)])
(let-values ([(p princess) (toward-well* #f 1.0 hooray-n
1.0 n01.5 n02 n03
gen-n
n2 n3 n4
(+ (* back-n -100)
(* drop-n -70)
(if returning?
(* (- 1 return-n) -170)
0.0)
(if (zero? wish4-return-n)
0.0
(* (- 1 wish4-return-n) -170)))
(if (= gen-n 1.0) drop-n gen-n)
#t #f
(make-keyword-procedure
(lambda (kws kw-vals . args)
(keyword-apply make-princess
(remq '#:side kws)
(remk #'side kws kw-vals)
#:side (if (or returning?
(< 0.0 wish4-return-n 1.0))
'right
(if (zero? drop-n)
(assk '#:side kws kw-vals)
'left))
#:dress "lightblue"
#:hair "peru"
args)))
values)])
(let ([p (million-thought
p
princess
(cond
[(positive? wish3-gone-n) "999,997"]
[(positive? wish2-gone-n) "999,998"]
[(positive? wish1-gone-n) "999,999"]
[else "1,000,000"])
thought-grow-n
million-thought-n
thought-gone-n
0.0)])
(wish-thought
p
princess
(cond
[(zero? wish2-return-n) diamond]
[(zero? wish3-return-n) ice-cream]
[else fishbowl])
wish-grow-n
wish-gone-n
drop-n
0.0))))
(max (- 1 fade-in-n)
fade-out-n))
#:skip-last? #t))
(define (wish-thought p princess wish wish-grow-n wish-gone-n drop-n x-drop-n)
(let-values ([(wish-x princess-x)
(let-values ([(x y) (lt-find p princess)])
(values (* x x-drop-n 0.5)
(- x (/ (pict-width wish) 2))))])
(if (and (positive? x-drop-n)
(wish-x . > . princess-x))
p
(let* ([wish-y (* drop-n (- (pict-height p) (* (pict-height princess) 3/4) (pict-height wish)))]
[wish-x (min wish-x princess-x)]
[wish-n (max 0.0 (- (* 2 wish-grow-n) 1.0))])
(thought
(pin-over
p
wish-x wish-y
(cellophane wish wish-n))
princess
wish
wish-grow-n
wish-gone-n)))))
(define million-well
(million-thought well+sign well+sign "1,000,000" 0.0 1.0 0.0 0.0))
(define (movie-slides)
(princess1-slides)
(princess2-slides)
(princess3-slides))
![[logo]](/logo.png){kind=logo}