b098ca7aa6
A common Slideshow pattern is to put a subset of slides in its own module with a `run-slides' function, and then you'd (un)comment a `(run-slides)' call at the end of the module to work on the subset by itself. Now, you can write `(module+ main (run-slides))' atthe end of the module and not have to comment it out. Adding `main' support to the `slideshow' executable makes it more consistent with using `racket' directly. Checking first for a `slideshow' submodule makes it possible for `slideshow' and `racket' to do different things, in case that's useful.
127 lines
4.1 KiB
Racket
127 lines
4.1 KiB
Racket
(module start "slideshow.rkt"
|
|
(require "start-param.rkt"
|
|
planet/config
|
|
mred
|
|
mzlib/class)
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Path utilities
|
|
|
|
(define (resolve-path/complete p base)
|
|
(let ([p2 (resolve-path p)])
|
|
(if (complete-path? p2)
|
|
p2
|
|
(path->complete-path p2 base))))
|
|
|
|
(define (normal-path p)
|
|
(let loop ([p (simplify-path (expand-path (path->complete-path p)))])
|
|
(let-values ([(base name dir?) (split-path p)])
|
|
(if (path? base)
|
|
(let ([base (loop base)])
|
|
(let ([p (build-path base name)])
|
|
(resolve-path/complete p base)))
|
|
(resolve-path/complete p base)))))
|
|
|
|
(define (same-path? a b)
|
|
(let-values ([(abase aname adir?) (split-path a)]
|
|
[(bbase bname bdir?) (split-path b)])
|
|
(and (equal? aname bname)
|
|
(or (equal? abase bbase)
|
|
(and (path? abase)
|
|
(path? bbase)
|
|
(same-path? abase bbase))))))
|
|
|
|
(define (sub-path? a b)
|
|
(let-values ([(abase aname adir?) (split-path a)]
|
|
[(bbase bname bdir?) (split-path b)])
|
|
(or (and (equal? aname bname)
|
|
(or (and (not abase) (not bbase))
|
|
(and (path? abase)
|
|
(path? bbase)
|
|
(same-path? abase bbase))))
|
|
(and (path? abase)
|
|
(sub-path? abase b)))))
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Loader with security guard
|
|
|
|
(define (load-content content)
|
|
(unless (trust-me?)
|
|
(current-security-guard
|
|
(make-security-guard (current-security-guard)
|
|
(lambda (who what mode)
|
|
(when (memq 'write mode)
|
|
(unless (let ([np-what (normal-path what)])
|
|
(or (sub-path? np-what (normal-path (find-system-path 'temp-dir)))
|
|
(equal? np-what (normal-path (LINKAGE-FILE)))))
|
|
(error 'slideshow
|
|
"slide program attempted to write to filesystem: ~e"
|
|
what)))
|
|
(when (memq 'execute mode)
|
|
(error 'slideshow
|
|
"slide program attempted to execute external code: ~e"
|
|
what)))
|
|
(lambda (who where-name where-port-num mode)
|
|
(error 'slideshow
|
|
"slide program attempted to make a network connection")))))
|
|
(define content-path (path->complete-path content))
|
|
(dynamic-require content-path #f)
|
|
(ormap (lambda (sm)
|
|
(define submod-path `(submod ,content-path ,sm))
|
|
(and (module-declared? submod-path #t)
|
|
(begin
|
|
(dynamic-require submod-path #f)
|
|
#t)))
|
|
'(slideshow main)))
|
|
|
|
(when (file-to-load)
|
|
(load-content (string->path (file-to-load))))
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Run tutorial
|
|
|
|
(unless (most-recent-slide)
|
|
(let ([link (lambda (label thunk)
|
|
(clickback (colorize
|
|
(let ([p (t label)])
|
|
(refocus (vc-append p
|
|
(linewidth 2 (hline (pict-width p) 2)))
|
|
p))
|
|
"blue")
|
|
thunk))])
|
|
(slide/center
|
|
(hc-append
|
|
(* 4 gap-size)
|
|
(titlet "Welcome to Slideshow")
|
|
(vl-append
|
|
gap-size
|
|
(page-para* (link "Run Tutorial"
|
|
(lambda ()
|
|
(retract-most-recent-slide)
|
|
(load-content
|
|
(build-path (collection-path "slideshow")
|
|
"tutorial-show.rkt")))))
|
|
(page-para* (link "Open File..."
|
|
(lambda ()
|
|
(let ([file (get-file)])
|
|
(when file
|
|
(retract-most-recent-slide)
|
|
(let-values ([(base name dir?) (split-path file)])
|
|
(current-directory base))
|
|
(load-content file))))))
|
|
(blank)
|
|
(page-para* (link "Quit"
|
|
(lambda ()
|
|
(exit))))))
|
|
(blank)
|
|
(blank)
|
|
(parameterize ([current-main-font `(italic . ,main-font)]
|
|
[current-font-size (floor (* #e0.8 (current-font-size)))])
|
|
(if (eq? (system-type) 'unix)
|
|
(page-para* "To start a talk directly,"
|
|
"provide the talk file as a command-line"
|
|
"argument")
|
|
(page-para* "To start a talk directly,"
|
|
"drag the talk file onto the" (bt "Slideshow")
|
|
"application icon")))))))
|