pictures.rkt (2960B)
1 #lang racket 2 3 (require "draw-plain.ss" 4 "orig-colors.rkt" 5 racket/draw 6 slideshow/code-pict 7 racket/runtime-path 8 slideshow/pict) 9 10 (provide langs-pict 11 langs-in-tree 12 langs-with-colors) 13 14 (define-runtime-path lang-colors.rktd "lang-colors.rktd") 15 16 (define (color->name c) 17 (define-values (r g b) (split-out-color c)) 18 (cond 19 [(and (equal? r 0) (equal? g 0) (equal? b 0)) 20 'black] 21 [else 22 (define res 23 (for/or ([(k v) (in-hash orig-colors)]) 24 (for/or ([c (in-list v)]) 25 (define rgb (cond 26 [(string? c) 27 (define clr (send the-color-database find-color c)) 28 (list (send clr red) (send clr green) (send clr blue))] 29 [else 30 c])) 31 (and (equal? rgb (list r g b)) 32 k)))) 33 (unless res (error 'color->name "unable to find color name for ~s" c)) 34 res])) 35 36 (define (color-name->index c) 37 (case c 38 [(blue) 0] 39 [(red) 1] 40 [(orange) 1.5] 41 [(green) 2] 42 [(gray) 3] 43 [(pink) 4] 44 [(cyan) 5] 45 [(purple) 5.5] 46 [(yellow) 7] 47 [(brown) 8] 48 [(black) 100] 49 [else (error 'color-name->index "unk ~s" c)])) 50 51 (define (split-out-color c) 52 (values 53 (string->number (substring c 1 3) 16) 54 (string->number (substring c 3 5) 16) 55 (string->number (substring c 5 7) 16))) 56 57 (define (color<=? c1 c2) 58 (let ([n1 (color->name c1)] 59 [n2 (color->name c2)]) 60 (cond 61 [(equal? n1 n2) 62 (string<=? c1 c2)] 63 [else 64 (<= (color-name->index n1) 65 (color-name->index n2))]))) 66 67 (define lang-colors 68 (sort (call-with-input-file lang-colors.rktd read) 69 color<=? 70 #:key cadr)) 71 72 (define-values (black-langs colored-langs) 73 (partition (λ (x) (equal? (cadr x) "#000000")) lang-colors)) 74 75 (define (line->color cl) 76 (let ([font-size 14]) 77 (hc-append 6 78 (colorize (filled-ellipse 14 14) 79 (string->color (cadr cl))) 80 (text (car cl) (current-code-font) font-size)))) 81 82 (define (langs-pict color? 83 #:fit [fit (λ (x) x)] 84 #:picts [p (if (pict? color?) (list color?) (list))]) 85 (define colors (langs-with-colors)) 86 (define len (length colors)) 87 (define start (ceiling (/ len 2))) 88 (define-values (one two) (split-at colors start)) 89 (define all 90 (ht-append 91 0 92 (langs-in-tree color?) 93 (apply vc-append 40 94 (ht-append 20 95 ((if color? values ghost) 96 (apply vl-append 2 one)) 97 ((if color? values ghost) 98 (apply vl-append 2 two))) 99 p))) 100 (fit all)) 101 102 (define (langs-with-colors) 103 (map line->color 104 (append colored-langs (list (list "everything else" "#000000"))))) 105 106 (define (langs-in-tree color?) 107 (inset (lang-pict 550 color?) 14 10 -10 10))