suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

add items-slide

Browse Source
This commit is contained in:
Jon Rafkind 2012-10-02 12:40:55 -06:00
parent 6c20513587
commit fbf153a435
2 changed files with 45 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/unstable/gui/pict.rkt
View File

@ -20,6 +20,10 @@
(blank (or w (pict-width pict))
(or h (pict-height pict)))))
(provide colorize/alpha)
(define (colorize/alpha pict r g b a)
(colorize pict (make-object color% r g b a)))
(define (color c p) (colorize p c))
(define color/c

43
collects/unstable/gui/slideshow.rkt
View File

@ -2,7 +2,7 @@
(require slideshow/base slideshow/pict
racket/contract/base racket/list racket/match
racket/stxparam
(for-syntax racket/base racket/list racket/set)
(for-syntax racket/base racket/list racket/set syntax/parse)
"pict.rkt")
(provide (all-from-out "pict.rkt"))
@ -153,7 +153,7 @@
;; Revealing slides. Similar to staging slides, can probably be implemented
;; in terms of staged slides.
(provide reveal revealing-slide)
(provide reveal revealing-slide items-slide)
(define-syntax-parameter reveal (lambda (stx) (raise-syntax-error 'reveal "reveal")))
@ -188,3 +188,42 @@
(slide stuff ...))))))
(with-syntax ([(slides ...) slides])
#'(begin slides ...)))]))
;; (items-slide ("a" "b" "c") #:title "whatever" (reveal 0 ...) (reveal 1 ...) (reveal 2 ...)
;; this will show a, b, c on the left side with one of them highlighted at a time.
;; the first element, a, will be synchronized with showing the first reveal, then
;; the second element, b, will be synchronized with the second reveal, etc.
(define-syntax (items-slide stx)
(syntax-parse stx
[(_ (item ...) (~seq keyword-name:keyword keyword-value:expr) ... stuff:expr ...)
(let ()
(define max-reveals (length (syntax->list #'(item ...))))
(define slides (for/list ([i max-reveals])
(with-syntax ([i i]
[(keywords ...)
(apply append (syntax->list
#'((keyword-name keyword-value) ...)))])
(syntax (syntax-parameterize ([reveal (syntax-rules ()
[(reveal n pict)
(show pict (= i n))])])
(let ([show-items
(for/fold ([start (blank)])
([in '(item ...)]
[current (in-naturals)])
(vr-append start
(if (= current i)
(text in null (current-font-size))
(colorize/alpha (text in null (- (current-font-size) 3))
0 0 0 0.3))
(blank 1 10)))]
[data (for/fold ([start (blank)])
([thing (list stuff ...)])
(lt-superimpose start thing))])
(slide keywords ...
(ht-append
show-items
(blank 50 1)
data))))))))
(with-syntax ([(slides ...) slides])
#'(begin slides ...)))]))