78 lines
2.2 KiB
Scheme
78 lines
2.2 KiB
Scheme
#lang scheme
|
|
(provide langs-pict)
|
|
(require "draw-plain.ss"
|
|
slideshow slideshow/code
|
|
scheme/runtime-path)
|
|
(define-runtime-path lang-colors.ss "lang-colors.ss")
|
|
|
|
(define (color->name c)
|
|
(let-values ([(r g b) (split-out-color c)])
|
|
(cond
|
|
[(and (= r 0) (= g 0) (= b 0)) 'black]
|
|
[(and (= r g) (= r b)) 'gray]
|
|
[(and (= 255 b) (= r g)) 'blue]
|
|
[(and (= r 0) (= g 0)) 'blue]
|
|
[(and (= r 0) (= b 0)) 'green]
|
|
[(and (= g 0) (= b 0)) 'red]
|
|
[else 'other])))
|
|
|
|
(define (color-name->index c)
|
|
(case c
|
|
[(blue) 0]
|
|
[(red) 1]
|
|
[(green) 2]
|
|
[(gray) 3]
|
|
[(other) 4]
|
|
[(black) 5]
|
|
[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.ss 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 (map line->color
|
|
(append colored-langs (list (list "everything else" "#000000")))))
|
|
(define len (length colors))
|
|
(define start (ceiling (/ len 2)))
|
|
(define-values (one two) (split-at colors start))
|
|
(ht-append
|
|
0
|
|
(inset (lang-pict 550 color?) 20 0 0 0)
|
|
(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)))
|
|
|
|
;(slide (langs-pict #f)) (slide (langs-pict #t))
|