(module viewer mzscheme
(require (lib "class.ss")
(lib "unit.ss")
(lib "unitsig.ss")
(lib "file.ss")
(lib "etc.ss")
(lib "contract.ss")
(lib "mred.ss" "mred")
"private/fratpac.ss"
(lib "math.ss")
(lib "list.ss")
"sig.ss"
"core.ss"
"util.ss")
(require (rename "private/frtime/lang-ext.ss" frp:lift lift))
(require (rename "private/frtime/lang-ext.ss" frp:behavior? behavior?))
(require (rename "private/frtime/frp-core.ss" do-in-manager do-in-manager))
(require "private/picture-updater.ss")
(provide viewer@)
(define original-security-guard (current-security-guard))
(define viewer@
(unit/sig viewer^
(import (config : cmdline^) core^)
(rename (viewer:set-use-background-frame! set-use-background-frame!)
(viewer:enable-click-advance! enable-click-advance!)
(viewer:set-page-numbers-visible! set-page-numbers-visible!)
(viewer:done-making-slides done-making-slides))
(define-accessor margin get-margin)
(define-accessor client-w get-client-w)
(define-accessor client-h get-client-h)
(define target-page config:init-page)
(define current-page (if config:printing? config:init-page 0))
(define use-background-frame? #f)
(define show-page-numbers? #t)
(define click-to-advance? #t)
(define blank-cursor-allowed? #t)
(define click-regions null)
(define talk-slide-list null)
(define given-talk-slide-list null)
(define talk-slide-reverse-cell-list null)
(define given-slide-count 0)
(define slide-count 0)
(define error-on-slide? #f)
(define empty-slide
(make-sliderec (lambda (dc x y) (void))
"<Empty>"
#f
0
1
zero-inset
null))
(define (talk-list-ref n)
(if (n . < . slide-count)
(list-ref talk-slide-list n)
empty-slide))
(track-var! 'current-page-tag current-page)
(track-var! 'mouse-x 0)
(track-var! 'mouse-y 0)
(track-events! 'key-events)
(define set-cp! (lambda (n) (update-var! 'current-page-tag n) (set! current-page n)))
(define frtime-page? #f)
(track-var! 'refresh-trigger (sliderec-drawer (talk-list-ref current-page)))
(call-when-change! 'current-page-tag (lambda (x)
(let ([res (sliderec-drawer (talk-list-ref x))])
(set! frtime-page? (frp:behavior? res))
(update-var! 'refresh-trigger res))))
(define (given->main!)
(if config:quad-view?
(begin
(set! talk-slide-list (make-quad given-talk-slide-list))
(set! slide-count (length talk-slide-list)))
(begin
(set! talk-slide-list given-talk-slide-list)
(set! slide-count given-slide-count)
(do-in-manager (update-var! 'current-page-tag (+ 1024 slide-count)))
(do-in-manager (update-var! 'current-page-tag current-page))
)))
(define (add-talk-slide! s)
(when error-on-slide?
(error "slide window has been closed"))
(let ([p (cons s null)])
(if (null? talk-slide-reverse-cell-list)
(set! given-talk-slide-list p)
(set-cdr! (car talk-slide-reverse-cell-list) p))
(set! talk-slide-reverse-cell-list (cons p talk-slide-reverse-cell-list)))
(set! given-slide-count (add1 given-slide-count))
(given->main!)
(if config:printing?
(send progress-display set-label (number->string slide-count))
(begin
(send f slide-changed (sub1 slide-count))
(when (and target-page (= target-page (sub1 slide-count)))
(set-init-page! target-page)
(set! target-page #f))
(yield))))
(define (retract-talk-slide!)
(unless (null? talk-slide-reverse-cell-list)
(set! talk-slide-reverse-cell-list (cdr talk-slide-reverse-cell-list))
(if (null? talk-slide-reverse-cell-list)
(set! given-talk-slide-list null)
(set-cdr! (car talk-slide-reverse-cell-list) null)))
(set! given-slide-count (sub1 given-slide-count))
(given->main!)
(unless config:printing?
(send f slide-changed slide-count)
(yield)))
(define (most-recent-talk-slide)
(and (pair? talk-slide-reverse-cell-list)
(caar talk-slide-reverse-cell-list)))
(define (set-init-page! p)
(set-cp! p)
(refresh-page)
)
(define (viewer:set-use-background-frame! on?)
(set! use-background-frame? (and on? #t)))
(define (viewer:enable-click-advance! on?)
(set! click-to-advance? (and on? #t)))
(define (viewer:set-page-numbers-visible! on?)
(set! show-page-numbers? (and on? #t)))
(viewer:set-page-numbers-visible! config:show-page-numbers?)
(define adjust-cursor (lambda () (send f set-blank-cursor #f)))
(define (add-click-region! cr)
(adjust-cursor)
(set! click-regions (cons cr click-regions)))
(define (make-quad l)
(cond
[(null? l) null]
[(< (length l) 4)
(make-quad (append l (vector->list
(make-vector
(- 4 (length l))
(make-sliderec void #f #f
(sliderec-page (car (last-pair l)))
1
zero-inset
null)))))]
[else (let ([a (car l)]
[b (cadr l)]
[c (caddr l)]
[d (cadddr l)]
[untitled "(untitled)"])
(cons (make-sliderec
(lambda (dc x y)
(define-values (orig-sx orig-sy) (send dc get-scale))
(define-values (orig-ox orig-oy) (send dc get-origin))
(define scale (min (/ (- (/ client-h 2) margin) client-h)
(/ (- (/ client-w 2) margin) client-w)))
(define (set-origin x y)
(send dc set-origin (+ orig-ox (* x orig-sx)) (+ orig-oy (* y orig-sy))))
(send dc set-scale (* orig-sx scale) (* orig-sy scale))
(set-origin x y)
((sliderec-drawer a) dc 0 0)
(set-origin (+ x (/ client-w 2) margin) y)
((sliderec-drawer b) dc 0 0)
(set-origin x (+ y (/ client-h 2) margin))
((sliderec-drawer c) dc 0 0)
(set-origin (+ x (/ client-w 2) margin) (+ y (/ client-h 2) margin))
((sliderec-drawer d) dc 0 0)
(send dc set-scale orig-sx orig-sy)
(set-origin x y)
(send dc draw-line (/ client-w 2) 0 (/ client-w 2) client-h)
(send dc draw-line 0 (/ client-h 2) client-w (/ client-h 2))
(send dc set-origin orig-ox orig-oy))
(format "~a | ~a | ~a | ~a"
(or (sliderec-title a) untitled)
(or (sliderec-title b) untitled)
(or (sliderec-title c) untitled)
(or (sliderec-title d) untitled))
#f
(sliderec-page a)
(- (+ (sliderec-page d) (sliderec-page-count d)) (sliderec-page a))
zero-inset
null)
(make-quad (list-tail l 4))))]))
(define GAUGE-WIDTH 100)
(define GAUGE-HEIGHT 4)
(define talk-start-seconds (current-seconds))
(define slide-start-seconds (current-seconds))
(define blank-cursor (make-object cursor% 'blank))
(application-quit-handler (lambda ()
(send f stop-show)))
(define talk-frame%
(class frame%
(init-field closeable?)
(init-field close-bg?)
(define/augment can-close? (lambda () (and closeable? (inner #t can-close?))))
(define/override on-superwindow-show (lambda (on?)
(unless on?
(when (and close-bg? background-f)
(send background-f show #f)))))
(define/override (on-subwindow-event w e)
(case (send e get-event-type)
[(enter motion)
(update-var! 'mouse-x (send e get-x))
(update-var! 'mouse-y (send e get-y))])
(super on-subwindow-event w e))
(define/override on-subwindow-char
(lambda (w e)
(let ([k (send e get-key-code)])
(case k
[(right)
(shift e 1 0 (lambda () (next)))]
[(left)
(shift e -1 0 (lambda () (prev)))]
[(up)
(shift e 0 -1 void)]
[(down)
(shift e 0 1 void)]
[(#\space #\f #\n)
(next)
#t]
[(#\b #\backspace #\rubout)
(prev)
#t]
[(#\g)
(stop-transition)
(if (send e get-meta-down)
(get-page-from-user)
(begin
(set-cp! (max 0 (sub1 slide-count)))
(refresh-page)))
#t]
[(#\1)
(stop-transition)
(set-cp! 0)
(refresh-page)
#t]
[(#\q #\u0153) (stop-transition)
(when (or (send e get-meta-down)
(send e get-alt-down))
(stop-show))
#t]
[(escape)
(when (equal? 1 (message-box/custom
"Quit"
"Really quit the slide show?"
"&Quit"
"&Cancel"
#f
this
'(default=1 caution)))
(stop-show))
#t]
[(#\p)
(when (or (send e get-meta-down)
(send e get-alt-down))
(set! show-page-numbers? (not show-page-numbers?))
(stop-transition)
(refresh-page))
#t]
[(#\d)
(when (or (send e get-meta-down)
(send e get-alt-down))
(stop-transition)
(send f-both show (not (send f-both is-shown?)))
(refresh-page))
#t]
[(#\c)
(when (or (send e get-meta-down)
(send e get-alt-down))
(stop-transition)
(send c-frame show (not (send c-frame is-shown?))))
#t]
[(#\m)
(when (or (send e get-meta-down)
(send e get-alt-down))
(set! blank-cursor-allowed? (not blank-cursor-allowed?))
(send f set-blank-cursor blank-cursor-allowed?))]
[else
(begin
(event-occur! 'key-events e)
#f)]))))
(define/public (stop-show)
(send c-frame show #f)
(send f-both show #f)
(when use-background-frame?
(send f show #f))
(send f show #f)
(when config:print-slide-seconds?
(printf "Total Time: ~a seconds~n"
(- (current-seconds) talk-start-seconds)))
(set! error-on-slide? #t))
(define/private (shift e xs ys otherwise)
(cond
[(or (send e get-meta-down)
(send e get-alt-down))
(move-over (* xs 20) (* ys 20))]
[(send e get-shift-down)
(move-over xs ys)]
[else
(otherwise)])
#t)
(inherit get-x get-y move)
(define/private (move-over dx dy)
(let ([x (get-x)]
[y (get-y)])
(move (+ x dx) (+ y dy))))
(define/private (prev)
(stop-transition)
(set-cp! (max (sub1 current-page)
0))
(refresh-page))
(define/public (next)
(if (pair? current-transitions)
(stop-transition)
(change-slide 1)))
(define/public (slide-changed pos)
(when (or (= pos current-page)
(and (or config:use-prefetch?
(send f-both is-shown?))
(= pos (add1 current-page))))
(stop-transition)
(set! prefetched-page #f)
(change-slide 0)
(when (and (= pos 0)
(not config:printing?))
(when use-background-frame?
(send f show #f)
(yield)
(send background-f show #t))
(send f show #t)
(when config:two-frames?
(send f-both show #t)))))
(define/private (change-slide n)
(let ([old (talk-list-ref current-page)])
(set-cp! (max 0
(min (+ n current-page)
(sub1 slide-count))))
(when config:print-slide-seconds?
(let ([slide-end-seconds (current-seconds)])
(printf "Slide ~a: ~a seconds~n" current-page
(- slide-end-seconds slide-start-seconds))
(set! slide-start-seconds slide-end-seconds)))
(do-transitions (if config:use-transitions?
(sliderec-transitions old)
null)
(send c get-offscreen))))
(define blank-cursor? #f)
(define activated? #f)
(inherit set-cursor)
(define/override (on-activate on?)
(set! activated? on?)
(when blank-cursor?
(set-cursor (if (and blank-cursor? on? blank-cursor-allowed?)
blank-cursor
#f))))
(define/public (set-blank-cursor b?)
(set! blank-cursor? (and b? #t))
(when activated?
(set-cursor (if (and blank-cursor? blank-cursor-allowed?)
blank-cursor
#f))))
(super-new)))
(define-values (screen-left-inset screen-top-inset)
(if config:keep-titlebar?
(values 0 0)
(get-display-left-top-inset)))
(define background-f
(make-object (class frame%
(inherit is-shown?)
(define/override (on-activate on?)
(when (and on? (is-shown?))
(send f show #t)))
(super-new
[label "Slideshow Background"]
[x (- screen-left-inset)] [y (- screen-top-inset)]
[width (inexact->exact (floor config:actual-screen-w))]
[height (inexact->exact (floor config:actual-screen-h))]
[style '(no-caption no-resize-border hide-menu-bar)]))))
(send background-f enable #f)
(define f (new talk-frame%
[closeable? config:keep-titlebar?]
[close-bg? #t]
[label (if config:file-to-load
(format "~a: slideshow" (file-name-from-path config:file-to-load))
"Slideshow")]
[x (- screen-left-inset)] [y (- screen-top-inset)]
[width (inexact->exact (floor config:actual-screen-w))]
[height (inexact->exact (floor config:actual-screen-h))]
[style (if config:keep-titlebar?
null
'(no-caption no-resize-border hide-menu-bar))]))
(define f-both (new talk-frame%
[closeable? #t]
[close-bg? #f]
[label "Slideshow Preview"]
[x 0] [y 0]
[width (inexact->exact (floor config:actual-screen-w))]
[height (inexact->exact (quotient (floor config:actual-screen-h) 2))]
[style '()]))
(define current-sinset zero-inset)
(define resizing-frame? #f)
(define (reset-display-inset! sinset)
(unless (and (= (sinset-l current-sinset) (sinset-l sinset))
(= (sinset-t current-sinset) (sinset-t sinset))
(= (sinset-r current-sinset) (sinset-r sinset))
(= (sinset-b current-sinset) (sinset-b sinset)))
(set! resizing-frame? #t) (send f resize
(max 1 (- (inexact->exact (floor config:actual-screen-w))
(inexact->exact (floor (* (+ (sinset-l sinset) (sinset-r sinset))
(/ config:actual-screen-w config:screen-w))))))
(max 1 (- (inexact->exact (floor config:actual-screen-h))
(inexact->exact (floor (* (+ (sinset-t sinset) (sinset-b sinset))
(/ config:actual-screen-h config:screen-h)))))))
(send f move
(inexact->exact (- (floor (* (sinset-l sinset)
(/ config:actual-screen-w config:screen-w)))
screen-left-inset))
(inexact->exact (- (floor (* (sinset-t sinset)
(/ config:actual-screen-h config:screen-h)))
screen-top-inset)))
(set! current-sinset sinset)
(yield)
(set! resizing-frame? #f)))
(define c-frame (new (class talk-frame%
(define/override (on-move x y)
(super on-move x y)
(parameterize ([current-security-guard original-security-guard])
(with-handlers ([void raise]) (put-preferences '(slideshow:commentary-x slideshow:commentary-y)
(list x y)
void))))
(define/override (on-size w h)
(super on-size w h)
(parameterize ([current-security-guard original-security-guard])
(with-handlers ([void raise]) (put-preferences '(slideshow:commentary-width slideshow:commentary-height)
(list w h)
void))))
(super-new))
[closeable? #t]
[close-bg? #f]
[label "Commentary"]
[width (get-preference 'slideshow:commentary-width (lambda () 400))]
[height (get-preference 'slideshow:commentary-height (lambda () 100))]
[x (get-preference 'slideshow:commentary-x (lambda () #f))]
[y (get-preference 'slideshow:commentary-y (lambda () #f))]))
(define commentary (make-object text%))
(send (new (class editor-canvas%
(define/override (on-event e)
(super on-event e)
(when (and click-to-advance?
(send e button-up?))
(send f next)))
(super-new))
[parent c-frame]
[editor commentary]
[style (if (eq? (system-type) 'macosx)
'(auto-hscroll resize-corner)
'(auto-hscroll auto-vscroll))])
set-line-count 3)
(send commentary auto-wrap #t)
(send c-frame reflow-container)
(define SCROLL-STEP-SIZE 20)
(define pict-snip%
(class snip%
(init-field pict)
(define drawer (make-pict-drawer pict))
(define/override (draw dc x y left top right bottom dx dy draw-caret)
(drawer dc x y))
(define/private (set-box/f b v)
(when b (set-box! b v)))
(define/override (get-extent dc x y wbox hbox descent space lspace rspace)
(set-box/f wbox (pict-width pict))
(set-box/f hbox (pict-height pict))
(set-box/f descent (pict-descent pict))
(set-box/f space 0)
(set-box/f lspace 0)
(set-box/f rspace 0))
(define/override (get-num-scroll-steps)
(inexact->exact (ceiling (/ (pict-height pict) SCROLL-STEP-SIZE))))
(define/override (find-scroll-step y)
(inexact->exact (floor (/ (max 0 y) SCROLL-STEP-SIZE))))
(define/override (get-scroll-step-offset n)
(* n SCROLL-STEP-SIZE))
(super-new)
(inherit set-snipclass)
(set-snipclass pict-snipclass)))
(define pict-snipclass (new snip-class%))
(define start-time #f)
(define clear-brush (make-object brush% "WHITE" 'transparent))
(define white-brush (make-object brush% "WHITE" 'solid))
(define gray-brush (make-object brush% "GRAY" 'solid))
(define green-brush (make-object brush% "GREEN" 'solid))
(define red-brush (make-object brush% "RED" 'solid))
(define black-brush (make-object brush% "BLACK" 'solid))
(define black-pen (make-object pen% "BLACK" 1 'solid))
(define clear-pen (make-object pen% "BLACK" 1 'transparent))
(define red-color (make-object color% "RED"))
(define green-color (make-object color% "GREEN"))
(define black-color (make-object color% "BLACK"))
(define (slide-page-string slide)
(if (= 1 (sliderec-page-count slide))
(format "~a" (sliderec-page slide))
(format "~a-~a" (sliderec-page slide) (+ (sliderec-page slide)
(sliderec-page-count slide)
-1))))
(define (calc-progress)
(if (and start-time config:talk-duration-minutes)
(values (min 1 (/ (- (current-seconds) start-time) (* 60 config:talk-duration-minutes)))
(/ current-page (max 1 (sub1 slide-count))))
(values 0 0)))
(define (show-time dc w h)
(let* ([left (- w GAUGE-WIDTH)]
[top (- h GAUGE-HEIGHT)]
[b (send dc get-brush)]
[p (send dc get-pen)])
(send dc set-pen black-pen)
(send dc set-brush (if start-time gray-brush clear-brush))
(send dc draw-rectangle left top GAUGE-WIDTH GAUGE-HEIGHT)
(when start-time
(let-values ([(duration distance) (calc-progress)])
(send dc set-brush (if (< distance duration)
red-brush
green-brush))
(send dc draw-rectangle left top (floor (* GAUGE-WIDTH distance)) GAUGE-HEIGHT)
(send dc set-brush clear-brush)
(send dc draw-rectangle left top (floor (* GAUGE-WIDTH duration)) GAUGE-HEIGHT)))
(send dc set-pen p)
(send dc set-brush b)))
(define c%
(class canvas%
(inherit get-dc get-client-size)
(define clicking #f)
(define clicking-hit? #f)
(define/override (on-paint)
(let ([dc (get-dc)])
(stop-transition/no-refresh)
(cond
[config:use-offscreen?
(let ([bm (send offscreen get-bitmap)])
(send (get-dc) draw-bitmap bm 0 0))]
[else
(send dc clear)
(paint-slide dc)])))
(inherit get-top-level-window)
(define/override (on-event e)
(cond
[(send e button-down?)
(let ([c (ormap
(lambda (c) (and (click-hits? e c) c))
click-regions)])
(when c
(if (click-region-show-click? c)
(begin
(set! clicking c)
(set! clicking-hit? #t)
(invert-clicking! #t))
((click-region-thunk c)))))]
[(and clicking (send e dragging?))
(let ([hit? (click-hits? e clicking)])
(unless (eq? hit? clicking-hit?)
(set! clicking-hit? hit?)
(invert-clicking! hit?)))]
[(and clicking (send e button-up?))
(let ([hit? (click-hits? e clicking)]
[c clicking])
(unless (eq? hit? clicking-hit?)
(set! clicking-hit? hit?)
(invert-clicking! hit?))
(when clicking-hit?
(invert-clicking! #f))
(set! clicking #f)
(when hit?
((click-region-thunk c))))]
[(send e button-up?)
(when click-to-advance?
(send (get-top-level-window) next))]
[else
(when (and clicking clicking-hit?)
(invert-clicking! #f))
(set! clicking #f)]))
(define/private (click-hits? e c)
(let ([x (send e get-x)]
[y (send e get-y)])
(and (<= (click-region-left c) x (click-region-right c))
(<= (click-region-top c) y (click-region-bottom c)))))
(define/private (invert-clicking! on?)
(let ([dc (get-dc)]
[x (click-region-left clicking)]
[y (click-region-top clicking)]
[w (- (click-region-right clicking) (click-region-left clicking))]
[h (- (click-region-bottom clicking) (click-region-top clicking))])
(if (or on?
(not config:use-offscreen?)
(not offscreen))
(let* ([b (send dc get-brush)]
[p (send dc get-pen)])
(send dc set-pen (send the-pen-list find-or-create-pen "white" 1 'transparent))
(send dc set-brush (send the-brush-list find-or-create-brush "black"
(if config:use-offscreen?
'hilite
'xor)))
(send dc draw-rectangle x y w h)
(send dc set-pen p)
(send dc set-brush b))
(send dc draw-bitmap-section
(send offscreen get-bitmap)
x y x y
w h))))
(define offscreen #f)
(define/public get-offscreen (lambda () offscreen))
(define/private (shift-click-region cr dx dy)
(make-click-region (+ dx (click-region-left cr))
(+ dy (click-region-top cr))
(+ dx (click-region-right cr))
(+ dy (click-region-bottom cr))
(click-region-thunk cr)
(click-region-show-click? cr)))
(define/private (paint-prefetch dc)
(let-values ([(cw ch) (get-client-size)])
(paint-letterbox dc cw ch config:use-screen-w config:use-screen-h)
(let ([dx (floor (/ (- cw config:use-screen-w) 2))]
[dy (floor (/ (- ch config:use-screen-h) 2))])
(send dc draw-bitmap prefetch-bitmap dx dy)
(set! click-regions (map (lambda (cr)
(shift-click-region cr dx dy))
prefetched-click-regions))
(send f set-blank-cursor (null? click-regions)))))
(define/override (on-size w h)
(unless resizing-frame?
(redraw)))
(define/public (redraw)
(unless printing?
(reset-display-inset! (sliderec-inset (talk-list-ref current-page)))
(send commentary lock #f)
(send commentary begin-edit-sequence)
(send commentary erase)
(let ([s (talk-list-ref current-page)])
(when (just-a-comment? (sliderec-comment s))
(for-each (lambda (v)
(send commentary insert (if (string? v)
v
(make-object pict-snip% v))))
(just-a-comment-content (sliderec-comment s)))))
(send commentary scroll-to-position 0 #f 'same 'start)
(send commentary end-edit-sequence)
(send commentary lock #t)
(set! click-regions null)
(set! clicking #f)
(stop-transition/no-refresh)
(cond
[config:use-offscreen?
(let-values ([(cw ch) (get-client-size)])
(when (and offscreen
(let ([bm (send offscreen get-bitmap)])
(not (and (= cw (send bm get-width))
(= ch (send bm get-height))))))
(send offscreen set-bitmap #f)
(set! offscreen #f))
(unless offscreen
(set! offscreen (make-object bitmap-dc%
(make-bitmap cw ch)))
(printf "~a X ~a~n" cw ch)))
(send offscreen clear)
(cond
[(equal? prefetched-page current-page)
(paint-prefetch offscreen)]
[else
(paint-slide offscreen)])
(unless (frp:behavior? (sliderec-drawer (talk-list-ref current-page)))
(let ([bm (send offscreen get-bitmap)])
(send (get-dc) draw-bitmap bm 0 0))
)
]
[(equal? prefetched-page current-page)
(paint-prefetch (get-dc))]
[else
(let ([dc (get-dc)])
(send dc clear)
(paint-slide dc))])
))
(super-new [style '(no-autoclear)])))
(define two-c%
(class canvas%
(inherit get-dc)
(define/public (paint-prefetched)
(let ([dc (get-dc)])
(let*-values ([(cw ch) (send dc get-size)])
(send dc set-scale
(/ (/ cw 2) (send prefetch-bitmap get-width))
(/ ch (send prefetch-bitmap get-height)))
(send dc set-origin (/ cw 2) 0)
(send dc draw-bitmap prefetch-bitmap 0 0)
(send dc set-origin 0 0)
(send dc set-scale 1 1)
(send dc draw-line (/ cw 2) 0 (/ cw 2) ch))))
(define/override (on-paint)
(let ([dc (get-dc)])
(send dc clear)
(let*-values ([(cw ch) (send dc get-size)])
(cond
[(and config:use-prefetch? config:use-prefetch-in-preview?)
(let* ([now-bm (send (send c get-offscreen) get-bitmap)]
[bw (send now-bm get-width)]
[bh (send now-bm get-height)])
(send dc set-scale (/ (/ cw 2) bw) (/ ch bh))
(send dc draw-bitmap now-bm 0 0)
(cond
[(equal? prefetched-page (add1 current-page))
(send dc set-origin (/ cw 2) 0)
(send dc draw-bitmap prefetch-bitmap 0 0)]
[else
(when (< (add1 current-page) slide-count)
(let ([b (send dc get-brush)])
(send dc set-brush gray-brush)
(send dc draw-rectangle bw 0 bw bh)
(send dc set-brush b)))])
(send dc set-scale 1 1))]
[else
(paint-slide dc current-page 1/2 1/2 cw (* 2 ch) cw (* 2 ch) #f)
(send dc set-origin (/ cw 2) 0)
(when (< (add1 current-page) slide-count)
(paint-slide dc
(+ current-page 1)
1/2 1/2
cw (* 2 ch) cw (* 2 ch)
#f))])
(send dc set-origin 0 0)
(send dc draw-line (/ cw 2) 0 (/ cw 2) ch))))
(inherit get-top-level-window)
(define/override (on-event e)
(cond
[(send e button-up?)
(send (get-top-level-window) next)]))
(define/public (redraw) (unless printing? (on-paint)))
(super-new)))
(define (paint-letterbox dc cw ch usw ush)
(when (or (< usw cw)
(< ush ch))
(let ([b (send dc get-brush)]
[p (send dc get-pen)])
(send dc set-brush black-brush)
(send dc set-pen clear-pen)
(when (< usw cw)
(let ([half (/ (- cw usw) 2)])
(send dc draw-rectangle 0 0 half ch)
(send dc draw-rectangle (- cw half) 0 half ch)))
(when (< ush ch)
(let ([half (/ (- ch ush) 2)])
(send dc draw-rectangle 0 0 cw half)
(send dc draw-rectangle 0 (- ch half) cw half)))
(send dc set-brush b)
(send dc set-pen p))))
(define paint-slide
(case-lambda
[(dc) (paint-slide dc current-page)]
[(dc page)
(let-values ([(cw ch) (send dc get-size)])
(paint-slide dc page 1 1 cw ch config:use-screen-w config:use-screen-h #t))]
[(dc page extra-scale-x extra-scale-y cw ch usw ush to-main?)
(let* ([slide (talk-list-ref page)]
[ins (sliderec-inset slide)]
[cw (if to-main?
(+ cw (sinset-l ins) (sinset-r ins))
cw)]
[ch (if to-main?
(+ ch (sinset-t ins) (sinset-b ins))
ch)]
[sx (/ usw config:screen-w)]
[sy (/ ush config:screen-h)]
[mx (/ (- cw usw) 2)]
[my (/ (- ch ush) 2)])
(paint-letterbox dc cw ch usw ush)
(when config:smoothing?
(send dc set-smoothing 'aligned))
(send dc set-scale (* extra-scale-x sx) (* extra-scale-y sy))
(if (frp:behavior? (sliderec-drawer (talk-list-ref page)))
(begin
(update-var! 'current-page-tag page)
(update-var! 'refresh-trigger (sliderec-drawer (talk-list-ref page))))
(let-values ([(ox oy) (send dc get-origin)])
(send dc set-origin
(+ ox (* extra-scale-x (floor mx)))
(+ oy (* extra-scale-y (floor my))))
((sliderec-drawer slide) dc margin margin)
(send dc set-origin ox oy)))
(send dc set-scale 1 1)
(when (and to-main? show-page-numbers?)
(let ([f (send dc get-font)]
[s (slide-page-string slide)]
[c (send dc get-text-foreground)])
(send dc set-font (current-page-number-font))
(send dc set-text-foreground (current-page-number-color))
(let-values ([(w h d a) (send dc get-text-extent s)])
(send dc draw-text s
(- cw w 5 (* sx (sinset-r ins)) (/ (- cw usw) 2))
(- ch h 5 (* sy (sinset-b ins)) (/ (- ch ush) 2))))
(send dc set-text-foreground c)
(send dc set-font f)))
)
]))
(define prefetched-page #f)
(define prefetch-bitmap #f)
(define prefetch-dc #f)
(define prefetch-schedule-cancel-box (box #f))
(define prefetched-click-regions null)
(define (prefetch-slide n)
(set! prefetched-page #f)
(unless prefetch-dc
(set! prefetch-dc (new bitmap-dc%)))
(unless (and (is-a? prefetch-bitmap bitmap%)
(= config:use-screen-w (send prefetch-bitmap get-width))
(= config:use-screen-h (send prefetch-bitmap get-height)))
(send prefetch-dc set-bitmap #f)
(set! prefetch-bitmap (make-bitmap config:use-screen-w config:use-screen-h))
(when (send prefetch-bitmap ok?)
(send prefetch-dc set-bitmap prefetch-bitmap)))
(when (send prefetch-dc ok?)
(send prefetch-dc clear)
(let ([old-click-regions click-regions]
[old-adjust adjust-cursor])
(set! click-regions null)
(set! adjust-cursor void)
(unless (frp:behavior? (sliderec-drawer (talk-list-ref n)))
(paint-slide prefetch-dc n)
)
(set! prefetched-click-regions click-regions)
(set! click-regions old-click-regions)
(set! adjust-cursor old-adjust))
(set! prefetched-page n)
(when (and config:use-prefetch-in-preview?
(send f-both is-shown?))
(send c-both paint-prefetched))))
(define (schedule-slide-prefetch n delay-msec)
(cancel-prefetch)
(when (and config:use-prefetch?
(not (equal? n prefetched-page)))
(let ([b (box #t)])
(set! prefetch-schedule-cancel-box b)
(new timer% [interval delay-msec] [just-once? #t]
[notify-callback (lambda ()
(when (unbox b)
(if (pair? current-transitions)
(schedule-slide-prefetch n delay-msec)
(prefetch-slide n))))]))))
(define (cancel-prefetch)
(set-box! prefetch-schedule-cancel-box #f))
(define c (make-object c% f))
(define c-both (make-object two-c% f-both))
(define refresh-page
(opt-lambda ([immediate-prefetch? #f])
(hide-cursor-until-moved)
(send f set-blank-cursor #t)
(when (= current-page 0)
(set! start-time #f)
(unless start-time
(set! start-time (current-seconds))))
(send c redraw)
(when (and c-both (send f-both is-shown?))
(send c-both redraw))
(when (< current-page (- slide-count 1))
(schedule-slide-prefetch (+ current-page 1)
(if immediate-prefetch?
50
500)))))
(define current-transitions null)
(define current-transitions-key #f)
(define (do-transitions transes offscreen)
(let ([key (cons 1 2)])
(set! current-transitions (map (lambda (mk) (mk offscreen)) transes))
(set! current-transitions-key key)
(if (null? transes)
(refresh-page #t)
(let do-trans ()
(when (and (eq? current-transitions-key key)
(pair? current-transitions))
(let ([went ((car current-transitions) c offscreen)])
(if (eq? went 'done)
(begin
(set! current-transitions (cdr current-transitions))
(if (null? current-transitions)
(refresh-page #t)
(do-trans)))
(new timer%
[just-once? #t]
[interval (inexact->exact (floor (* 1000 went)))]
[notify-callback (lambda ()
(queue-callback
do-trans
#f))]))))))))
(define (shorten-string long-string)
(let loop ([acc '()]
[str-list (string->list long-string)]
[count 0])
(if (or (empty? str-list) (>= count 20))
(string-append (list->string acc)
(if (>= (string-length long-string) 20)
"..."
""))
(loop (append acc (list (car str-list))) (cdr str-list) (add1 count)))))
(define (stop-transition)
(cancel-prefetch)
(unless (null? current-transitions)
(stop-transition/no-refresh)
(refresh-page)))
(define (stop-transition/no-refresh)
(set! current-transitions null)
(set! current-transitions-key #f))
(define (get-page-from-user)
(unless (zero? slide-count)
(letrec ([d (make-object dialog% "Goto Page" f 200 250)]
[short-slide-list
(let loop ([slides talk-slide-list][n 1][last-title #f])
(cond
[(null? slides) null]
[(and last-title
(equal? last-title (or (sliderec-title (car slides))
"(untitled)")))
(loop (cdr slides) (+ n 1) last-title)]
[else
(let ([title (or (sliderec-title (car slides))
"(untitled)")])
(cons (cons
n
(format "~a. ~a"
(slide-page-string (car slides))
title))
(loop (cdr slides) (add1 n) title)))]))]
[long-slide-list (let loop ([slides talk-slide-list][n 1])
(if (null? slides)
null
(cons (cons
n
(format "~a. ~a"
(slide-page-string (car slides))
(or (sliderec-title (car slides))
"(untitled)")))
(loop (cdr slides) (add1 n)))))]
[slide-list short-slide-list]
[l (make-object list-box% #f (map (lambda (elt) (shorten-string (cdr elt)))
slide-list)
d (lambda (l e)
(when (eq? (send e get-event-type) 'list-box-dclick)
(ok-action))))]
[p (make-object horizontal-pane% d)]
[ok-action (lambda ()
(send d show #f)
(let ([i (send l get-selection)])
(when i
(set-cp! (sub1 (car (list-ref slide-list i))))
(refresh-page))))])
(send d center)
(send p stretchable-height #f)
(make-object check-box% "&All Pages" p
(lambda (c e)
(set! slide-list (if (send c get-value)
long-slide-list
short-slide-list))
(send l set (map (lambda (elt) (shorten-string (cdr elt))) slide-list))))
(make-object pane% p)
(make-object button% "Cancel" p (lambda (b e) (send d show #f)))
(make-object button% "Ok" p (lambda (b e) (ok-action)) '(border))
(send l focus)
(send d reflow-container)
(let ([now (let loop ([l slide-list][n 0])
(if (null? l)
(sub1 n)
(if (> (sub1 (caar l)) current-page)
(sub1 n)
(loop (cdr l) (add1 n)))))])
(send l set-selection (max 0 now))
(send l set-first-visible-item (max 0 (- now 3))))
(send d show #t))))
(send f reflow-container)
(send f-both reflow-container)
(refresh-page)
(define frtime-transition
(let-values ([(cw ch) (send c get-client-size)]) (let* ([tmp-dc (make-object bitmap-dc% (make-bitmap config:use-screen-w config:use-screen-h))]
[xs (/ config:use-screen-w config:screen-w)]
[ys (/ config:use-screen-h config:screen-h)] [border-extent-x (/ (- cw config:use-screen-w) 2)]
[border-extent-y (/ (- ch config:use-screen-h) 2)] [dc (send c get-dc)])
(when config:smoothing?
(send tmp-dc set-smoothing 'aligned))
(lambda (draw-proc)
(send tmp-dc set-scale xs ys) (send tmp-dc clear)
(when (frp:behavior? draw-proc)
(printf "draw-proc is a behavior sill! uh-oh!"))
(draw-proc tmp-dc margin margin)
(send tmp-dc set-scale 1 1)
(when show-page-numbers?
(let ([f (send tmp-dc get-font)]
[s (number->string (add1 current-page))]
[c (send tmp-dc get-text-foreground)])
(send tmp-dc set-font (current-page-number-font))
(send tmp-dc set-text-foreground (current-page-number-color))
(let-values ([(w h d a) (send tmp-dc get-text-extent s)])
(send tmp-dc draw-text s
(- config:use-screen-w w 5)
(- config:use-screen-h h 5)))
(send tmp-dc set-text-foreground c)
(send tmp-dc set-font f)))
(when config:smoothing?
(send dc set-smoothing 'aligned))
(send dc draw-bitmap-section
(send tmp-dc get-bitmap)
border-extent-x border-extent-y
0 0
config:use-screen-w
config:use-screen-h
) ))))
(call-when-change! 'refresh-trigger (lambda (x)
(when frtime-page?
(frtime-transition x))))
(define (get-current-page) (frp:lift #t add1 (get-behavior 'current-page-tag)))
(define (get-current-mouse-x/b) (get-behavior 'mouse-x))
(define (get-current-mouse-y/b) (get-behavior 'mouse-y))
(define (get-key-events) (get-events 'key-events))
(let* ([bm (make-object bitmap% "slideshow.png")]
[mbm (make-object bitmap% "mask.xbm")])
(when (send bm ok?)
(send f set-icon bm (and (send mbm ok?) mbm) 'both)))
(when config:commentary?
(send c-frame show #t)
(message-box "Instructions"
(format "Keybindings:~
~n {Meta,Alt}-q - quit~
~n Right, Space, f or n - next slide~
~n Left, b - prev slide~
~n g - last slide~
~n 1 - first slide~
~n {Meta,Alt}-g - select slide~
~n p - show/hide slide number~
~n {Meta,Alt}-c - show/hide commentary~
~n {Meta,Alt,Shift}-{Right,Left,Up,Down} - move window~
~nAll bindings work in all windows")))
(define (do-print)
(let ([ps-dc (dc-for-text-size)])
(let loop ([start? #f][l (list-tail talk-slide-list current-page)][n current-page])
(unless (null? l)
(set-cp! n)
(refresh-page)
(when start?
(send ps-dc start-page))
(let ([slide (car l)])
(let ([xs (/ config:use-screen-w config:screen-w)]
[ys (/ config:use-screen-h config:screen-h)])
(send ps-dc set-scale xs ys)
((sliderec-drawer slide) ps-dc
(+ margin (/ (- config:actual-screen-w config:use-screen-w) 2 xs))
(+ margin (/ (- config:actual-screen-h config:use-screen-h) 2 ys))))
(when show-page-numbers?
(send ps-dc set-scale 1 1)
(let ([s (slide-page-string slide)])
(let-values ([(w h) (send ps-dc get-size)]
[(sw sh sd sa) (send ps-dc get-text-extent s)]
[(hm vm) (values margin margin)])
(send ps-dc draw-text s (- w hm sw) (- h vm sh))))))
(send ps-dc end-page)
(loop #t (cdr l) (add1 n))))
(parameterize ([current-security-guard original-security-guard])
(send ps-dc end-doc))
(exit)))
(define-values (progress-window progress-display)
(if config:printing?
(parameterize ([current-eventspace (make-eventspace)])
(let* ([f (make-object (class frame%
(define/augment (on-close) (exit))
(super-instantiate ()))
"Progress")]
[h (instantiate horizontal-panel% (f)
(stretchable-width #f)
(stretchable-height #f))])
(make-object message% "Building slide: " h)
(let ([d (make-object message% "0000" h)])
(send d set-label "1")
(send f center)
(send f show #t)
(values f d))))
(values #f #f)))
(define (viewer:done-making-slides)
(when config:printing?
(do-print)))
(let ([eh (current-exception-handler)])
(current-exception-handler
(lambda (exn)
(send f show #f)
(when f-both
(send f-both show #f))
(when background-f
(send background-f show #f))
(eh exn))))
)))