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

add optional `#:fit?' argument

Browse Source
This commit is contained in:
Matthew Flatt 2013-03-06 11:01:11 -07:00
parent 6f551d4c9d
commit e2603d4376
1 changed files with 19 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
lang-slide/main.rkt
View File

@ -75,21 +75,29 @@
(string->color (cadr cl))) (string->color (cadr cl)))
(text (car cl) (current-code-font) (current-font-size))))) (text (car cl) (current-code-font) (current-font-size)))))
(define (langs-pict color? #:picts [p (if (pict? color?) (list color?) (list))]) (define (langs-pict color?
#:fit? [fit? #f]
#:picts [p (if (pict? color?) (list color?) (list))])
(define colors (langs-with-colors)) (define colors (langs-with-colors))
(define len (length colors)) (define len (length colors))
(define start (ceiling (/ len 2))) (define start (ceiling (/ len 2)))
(define-values (one two) (split-at colors start)) (define-values (one two) (split-at colors start))
(ht-append (define all
0 (ht-append
(langs-in-tree color?) 0
(apply vc-append 40 (langs-in-tree color?)
(ht-append 20 (apply vc-append 40
((if color? values ghost) (ht-append 20
(apply vl-append 2 one)) ((if color? values ghost)
((if color? values ghost) (apply vl-append 2 one))
(apply vl-append 2 two))) ((if color? values ghost)
p))) (apply vl-append 2 two)))
p)))
(if fit?
(scale all (min 1
(/ client-w (pict-width all))
(/ client-h (pict-height all))))
all))
(define (langs-with-colors) (define (langs-with-colors)
(map line->color (map line->color
@ -99,6 +107,5 @@
(inset (lang-pict 550 color?) 14 10 -10 10)) (inset (lang-pict 550 color?) 14 10 -10 10))
(module+ main (module+ main
(require slideshow)
(slide (langs-pict #f)) (slide (langs-pict #f))
(slide (langs-pict #t))) (slide (langs-pict #t)))