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

name files more sensibly, improve readme

Browse Source
This commit is contained in:
Sam Tobin-Hochstadt 2012-11-12 18:21:32 -05:00
parent dba4283aa8
commit 40f30a8ce1
5 changed files with 147 additions and 138 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
README.md
View File

@ -1,13 +1,20 @@
## Finding files
`find.rkt` generates `lang.plain` (I don't remember how)
## Pictures
`main.rkt` draws the picture, with some options.
`main.rkt` provides several picts, with some options. When run on the
command line, it shows a slide that demos the pict.
## Slides
`lang-slide.rkt` has a slideshow slide that uses the picture.
`hudak-quote.rkt` has a slideshow slide that uses the picture along
with a quote from Paul Hudak.
## PNG
`mk-img.rkt` generates a PNG of the image.
## Regenerating the data
`find.rkt` regenerates `lang.plain` and `lang-colors.rktd`
automatically when run.
##### Originally by Robby Findler.

37
lang-slide/hudak-quote.rkt Normal file
View File

@ -0,0 +1,37 @@
#lang racket/base
(require "main.rkt"
slideshow
slideshow/code
unstable/gui/slideshow)
(provide langs hudak-quote perlis-quote)
(define hudak-quote
(vr-append 10 (vl-append (t "“A domain specific language is the ultimate abstraction.” "))
(t " — Paul Hudak")))
(define perlis-quote (vr-append 10 (vr-append (t "“There will always be things we wish to say in our programs")
(t "that in all known languages can only be said poorly.”"))
(t " — Alan Perlis")))
(define p2 (vl-append (t "Racket ships more than") (t "40 documented languages")))
(define p1 (lt-superimpose (ghost p2) (vl-append (t "In 6000+ files of") (t "Racket source code ..."))))
(define (langs)
(define p1+p2 (vl-append 10 p1 p2))
(parameterize ([current-code-font 'default])
(slide/staged [#;hudak one two]
;#:title "Files in Racket"
;#:layout 'tall
(cond
[(eq? stage-name 'hudak)
(mini-slide (vr-append 60 hudak-quote perlis-quote))]
[(eq? stage-name 'one)
(frame (langs-pict #f #:picts (list (lt-superimpose p1 (ghost p1+p2)))))]
[else
(langs-pict p1+p2)]))))
(module+ main
(langs))

103
lang-slide/lang-slide.rkt
View File

@ -1,103 +0,0 @@
#lang scheme
(provide langs-pict
langs-in-tree
langs-with-colors)
(require "draw-plain.ss"
"orig-colors.rkt"
slideshow slideshow/code
scheme/runtime-path
racket/gui/base)
(define-runtime-path lang-colors.rktd "lang-colors.rktd")
(define (color->name c)
(define-values (r g b) (split-out-color c))
(cond
[(and (equal? r 0) (equal? g 0) (equal? b 0))
'black]
[else
(define res
(for/or ([(k v) (in-hash orig-colors)])
(for/or ([c (in-list v)])
(define rgb (cond
[(string? c)
(define clr (send the-color-database find-color c))
(list (send clr red) (send clr green) (send clr blue))]
[else
c]))
(and (equal? rgb (list r g b))
k))))
(unless res (error 'color->name "unable to find color name for ~s" c))
res]))
(define (color-name->index c)
(case c
[(blue) 0]
[(red) 1]
[(orange) 1.5]
[(green) 2]
[(gray) 3]
[(pink) 4]
[(cyan) 5]
[(purple) 5.5]
[(yellow) 7]
[(brown) 8]
[(black) 100]
[else (error 'color-name->index "unk ~s" c)]))
(define (split-out-color c)
(values
(string->number (substring c 1 3) 16)
(string->number (substring c 3 5) 16)
(string->number (substring c 5 7) 16)))
(define (color<=? c1 c2)
(let ([n1 (color->name c1)]
[n2 (color->name c2)])
(cond
[(equal? n1 n2)
(string<=? c1 c2)]
[else
(<= (color-name->index n1)
(color-name->index n2))])))
(define lang-colors
(sort (call-with-input-file lang-colors.rktd read)
color<=?
#:key cadr))
(define-values (black-langs colored-langs)
(partition (λ (x) (equal? (cadr x) "#000000")) lang-colors))
(define (line->color cl)
(parameterize ([current-font-size 16])
(hc-append 6
(colorize (filled-ellipse 14 14)
(string->color (cadr cl)))
(text (car cl) (current-code-font) (current-font-size)))))
(define (langs-pict color? #:picts [p (if (pict? color?) (list color?) (list))])
(define colors (langs-with-colors))
(define len (length colors))
(define start (ceiling (/ len 2)))
(define-values (one two) (split-at colors start))
(ht-append
0
(langs-in-tree color?)
(apply vc-append 40
(ht-append 20
((if color? values ghost)
(apply vl-append 2 one))
((if color? values ghost)
(apply vl-append 2 two)))
p)))
(define (langs-with-colors)
(map line->color
(append colored-langs (list (list "everything else" "#000000")))))
(define (langs-in-tree color?)
(inset (lang-pict 550 color?) 14 10 10 10))
(module+ main
(slide (langs-pict #f))
(slide (langs-pict #t)))

130
lang-slide/main.rkt
View File

@ -1,35 +1,103 @@
#lang racket/base
(require "lang-slide.rkt"
slideshow
slideshow/code
unstable/gui/slideshow)
#lang scheme
(provide langs-pict
langs-in-tree
langs-with-colors)
(require "draw-plain.ss"
"orig-colors.rkt"
slideshow slideshow/code
scheme/runtime-path
racket/gui/base)
(define-runtime-path lang-colors.rktd "lang-colors.rktd")
(provide langs hudak-quote perlis-quote)
(define hudak-quote
(vr-append 10 (vl-append (t "“A domain specific language is the ultimate abstraction.” "))
(t " — Paul Hudak")))
(define perlis-quote (vr-append 10 (vr-append (t "“There will always be things we wish to say in our programs")
(t "that in all known languages can only be said poorly.”"))
(t " — Alan Perlis")))
(define p2 (vl-append (t "Racket ships more than") (t "40 documented languages")))
(define p1 (lt-superimpose (ghost p2) (vl-append (t "In 6000+ files of") (t "Racket source code ..."))))
(define (langs)
(define p1+p2 (vl-append 10 p1 p2))
(parameterize ([current-code-font 'default])
(slide/staged [#;hudak one two]
;#:title "Files in Racket"
;#:layout 'tall
(define (color->name c)
(define-values (r g b) (split-out-color c))
(cond
[(eq? stage-name 'hudak)
(mini-slide (vr-append 60 hudak-quote perlis-quote))]
[(eq? stage-name 'one)
(frame (langs-pict #f #:picts (list (lt-superimpose p1 (ghost p1+p2)))))]
[(and (equal? r 0) (equal? g 0) (equal? b 0))
'black]
[else
(langs-pict p1+p2)]))))
(define res
(for/or ([(k v) (in-hash orig-colors)])
(for/or ([c (in-list v)])
(define rgb (cond
[(string? c)
(define clr (send the-color-database find-color c))
(list (send clr red) (send clr green) (send clr blue))]
[else
c]))
(and (equal? rgb (list r g b))
k))))
(unless res (error 'color->name "unable to find color name for ~s" c))
res]))
(langs)
(define (color-name->index c)
(case c
[(blue) 0]
[(red) 1]
[(orange) 1.5]
[(green) 2]
[(gray) 3]
[(pink) 4]
[(cyan) 5]
[(purple) 5.5]
[(yellow) 7]
[(brown) 8]
[(black) 100]
[else (error 'color-name->index "unk ~s" c)]))
(define (split-out-color c)
(values
(string->number (substring c 1 3) 16)
(string->number (substring c 3 5) 16)
(string->number (substring c 5 7) 16)))
(define (color<=? c1 c2)
(let ([n1 (color->name c1)]
[n2 (color->name c2)])
(cond
[(equal? n1 n2)
(string<=? c1 c2)]
[else
(<= (color-name->index n1)
(color-name->index n2))])))
(define lang-colors
(sort (call-with-input-file lang-colors.rktd read)
color<=?
#:key cadr))
(define-values (black-langs colored-langs)
(partition (λ (x) (equal? (cadr x) "#000000")) lang-colors))
(define (line->color cl)
(parameterize ([current-font-size 16])
(hc-append 6
(colorize (filled-ellipse 14 14)
(string->color (cadr cl)))
(text (car cl) (current-code-font) (current-font-size)))))
(define (langs-pict color? #:picts [p (if (pict? color?) (list color?) (list))])
(define colors (langs-with-colors))
(define len (length colors))
(define start (ceiling (/ len 2)))
(define-values (one two) (split-at colors start))
(ht-append
0
(langs-in-tree color?)
(apply vc-append 40
(ht-append 20
((if color? values ghost)
(apply vl-append 2 one))
((if color? values ghost)
(apply vl-append 2 two)))
p)))
(define (langs-with-colors)
(map line->color
(append colored-langs (list (list "everything else" "#000000")))))
(define (langs-in-tree color?)
(inset (lang-pict 550 color?) 14 10 10 10))
(module+ main
(slide (langs-pict #f))
(slide (langs-pict #t)))

2
lang-slide/mk-img.rkt
View File

@ -1,5 +1,5 @@
#lang scheme/gui
(require "lang-slide.ss" slideshow)
(require "main.rkt" slideshow)
(define the-margin 32)