commit fd0f9e836ba7a1af619e09df430690c38a7f2b0a parent 2a0944988498c940340728add9f71601ea3e5343 Author: Sam Tobin-Hochstadt <samth@racket-lang.org> Date: Mon, 12 Nov 2012 18:12:25 -0500 Move to subdir for Planet2. Extension fixes. Diffstat:
| D | find.rkt | | | 280 | ------------------------------------------------------------------------------- |
| D | lang-slide.ss | | | 103 | ------------------------------------------------------------------------------- |
| R | draw-plain.ss -> lang-slide/draw-plain.rkt | | | 0 | |
| A | lang-slide/find.rkt | | | 280 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| R | lang-colors.rkt -> lang-slide/lang-colors.rktd | | | 0 | |
| A | lang-slide/lang-slide.rkt | | | 103 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| R | lang.plain -> lang-slide/lang.plain | | | 0 | |
| R | main.rkt -> lang-slide/main.rkt | | | 0 | |
| R | mk-img.ss -> lang-slide/mk-img.rkt | | | 0 | |
| R | orig-colors.rkt -> lang-slide/orig-colors.rkt | | | 0 |
10 files changed, 383 insertions(+), 383 deletions(-)
diff --git a/find.rkt b/find.rkt @@ -1,280 +0,0 @@ -#lang racket -(require racket/system - racket/draw - racket/runtime-path - "orig-colors.rkt") - -(define (get-language i) - (and (or (regexp-match #rx"scrbl$" (path->string i)) - (regexp-match #rx"[.]rkt$" (path->string i)) - (regexp-match #rx"[.]ss$" (path->string i)) - (regexp-match #rx"[.]scm$" (path->string i))) - (call-with-input-file i - (λ (port) - (simplify-language - (and (not (skip-file? i)) - (parameterize ([read-accept-reader #t]) - (with-handlers ((exn:fail? (λ (x) (printf "exn when reading ~s\n" i) (raise x)))) - (let loop () - (let ([line (read-line (peeking-input-port port))]) - (cond - [(eof-object? line) - (error 'get-language "got to eof without finding a language")] - [(regexp-match #rx"[(]" line) - (cond - [(regexp-match #rx"module [^ ]* +(.*)$" line) - => - (λ (m) - (let ([obj (read (open-input-string (list-ref m 1)))]) - (if (string? obj) - (format "s-exp ~a" obj) - (format "~a" obj))))] - [else - (match (read port) - [`(module ,modname ,lang ,stuff ...) - (if (string? lang) - (format "s-exp ~a" lang) - (format "~a" lang))] - [else - - #f ;; here we just assume there is no language specified - #;(error 'get-language "found a paren, but not a module expression in ~s" i)])])] - [(regexp-match #rx"#reader ?scribble/reader" line) - (read-line port) - (loop)] - [(regexp-match #rx"#reader" line) - (parse-reader-line port)] - [(regexp-match #rx"#lang (.*)$" line) - => - (λ (m) (list-ref m 1))] - [(regexp-match #rx"#!r6rs$" line) "r6rs"] - [else - (read-line port) - (loop)]))))))))))) - -(define (simplify-language lang) - (and lang - (let ([lang - (regexp-replace - #rx" +$" - (regexp-replace* #rx"\"" - (regexp-replace* #rx"s-exp " lang "") - "") - "")]) - (cond - [(regexp-match #rx"^scheme" lang) - (simplify-language (string-append "racket" (substring lang 6)))] - [(regexp-match #rx"#%kernel" lang) - "#%kernel"] - [(regexp-match #rx"lib infotab.ss setup" lang) - "setup/infotab"] - [(regexp-match #rx"slideshow" lang) - "slideshow"] - [(regexp-match #rx"typed/scheme$" lang) - "typed/racket"] - [(regexp-match #rx"typed-scheme$" lang) - "typed/racket"] - [(regexp-match #rx"racket/unit/lang" lang) - "racket/unit"] - [(regexp-match #rx"srfi/provider" lang) - "srfi/provider"] - [(regexp-match #rx"htdp/bsl/reader" lang) - "htdp/bsl"] - [(regexp-match #rx"htdp-beginner.ss" lang) - "htdp/bsl"] - [(regexp-match #rx"htdp-intermediate.ss" lang) - "htdp/isl"] - [(regexp-match #rx"htdp-intermediate-lambda.ss" lang) - "htdp/isl+"] - [(regexp-match #rx"htdp-advanced.ss" lang) - "htdp/asl"] - [else lang])))) - - -(define (skip-file? path) - (let ([str (path->string path)]) - (or (regexp-match #rx"collects/games/loa/main.ss" str) - (regexp-match #rx"collects/tests" str) - (regexp-match #rx"collects/scribblings/guide/contracts-examples" str) - (regexp-match #rx"collects/htdp/tests/matrix-" str) - (regexp-match #rx"collects/scribblings/guide/read.scrbl" str)))) - -(define (parse-reader-line port) - (let ([line (read-line port)]) - (cond - [(regexp-match #rx"htdp-beginner-reader.ss" line) - "htdp/bsl"] - [else - (error 'parse-reader-line "unknown line ~s" line)]))) - - -(define ht (make-hash)) -(for ((i (in-directory (simplify-path (build-path (collection-path "racket") 'up))))) - (let ([lang (get-language i)]) - (when lang - (hash-set! ht lang (cons i (hash-ref ht lang '())))))) -(let ([one-offs '()]) - (hash-for-each - ht - (λ (k v) (when (= 1 (length v)) - (hash-remove! ht k) - (set! one-offs (cons (car v) one-offs))))) - (hash-set! ht "one off language" one-offs)) - -(sort (hash-map ht (λ (x y) (list x (length y)))) string<=? #:key car) - -(define existing-edges (make-hash)) -(define existing-interior-nodes (make-hash)) -(define directory->languages (make-hash)) - -(define depth-table (make-hash)) - -(define path->rank - (let ([rank-table (make-hash)]) - (λ (path) - (hash-ref rank-table path - (λ () - (let ([next (hash-count rank-table)]) - (hash-set! rank-table path (format "rank~a" next)) - (format "rank~a" next))))))) - -(define (file-to-dot filename language) - (let ([path (find-relative-path (simplify-path (build-path (collection-path "drscheme") 'up 'up)) - filename)]) - (let loop ([eles (explode-path path)] - [parent (build-path 'same)] - [depth 0]) - (let* ([child (build-path parent (car eles))] - [key (cons parent child)]) - - (cond - [(null? (cdr eles)) - (unless (member language (hash-ref directory->languages parent '())) - (hash-set! directory->languages parent (cons language (hash-ref directory->languages parent '()))) - (unless (hash-ref existing-edges key #f) - (hash-set! existing-edges key #t) - (printf " \"~a\" -> \"~a\" [color=gray,arrowhead=none,arrowtail=none];\n" parent child)) - (hash-set! depth-table depth (+ 1 (hash-ref depth-table depth 0))) - (let ([rank (path->rank parent)]) - (printf " \"~a\" [label=\"\",shape=circle,fillcolor=\"~a\",color=\"~a\",style=filled] ;\n" - (path->string child) - (language->color filename language) - (language->color filename language))))] - [else - (unless (hash-ref existing-edges key #f) - (hash-set! existing-edges key #t) - (printf " \"~a\" -> \"~a\" [color=gray,arrowhead=none,arrowtail=none];\n" parent child)) - (unless (hash-ref existing-interior-nodes parent #f) - (hash-set! existing-interior-nodes parent #t) - (printf " \"~a\" [shape=point,color=gray];\n" parent)) - (unless (hash-ref existing-interior-nodes child #f) - (hash-set! existing-interior-nodes child #t) - (printf " \"~a\" [shape=point,color=gray];\n" child)) - (loop (cdr eles) child (+ depth 1))]))))) - -(define colors (make-hash)) - -(define (language->color file lang) - (hash-ref colors lang - (λ () - (cond - [(regexp-match #rx"web" lang) - (next-color lang 'purple)] - [(or (regexp-match #rx"frtime" lang)) - (next-color lang 'gray)] - [(regexp-match #rx"typed" lang) - (next-color lang 'orange)] - [(or (regexp-match #rx"at-exp" lang) - (regexp-match #rx"scribble" lang)) - (next-color lang 'red)] - [(or (regexp-match #rx"scheme" lang) - (regexp-match #rx"racket" lang) - (regexp-match #rx"slideshow" lang) - (regexp-match #rx"#%kernel" lang) - (regexp-match #rx"pre-base.rkt" lang)) - (next-color lang 'blue)] - [(or (regexp-match #rx"srfi" lang) - (regexp-match #rx"r6rs" lang) - (regexp-match #rx"r5rs" lang)) - (next-color lang 'pink)] - [(regexp-match #rx"module-reader" lang) - (next-color lang 'brown)] - [(regexp-match #rx"setup" lang) - (next-color lang 'yellow)] - [(or (regexp-match #rx"htdp" lang) - (regexp-match #rx"DMdA" lang)) - (next-color lang 'green)] - [(regexp-match #rx"swindle" lang) - (next-color lang 'cyan)] - [else - (fprintf (current-error-port) "unknown language ~s ~s\n" lang (length (hash-ref ht lang))) - (new-color lang 0 0 0)])))) - -(define (new-color lang r g b) - (define new-color (string-append - "#" - (to-hex r) - (to-hex g) - (to-hex b))) - (hash-set! colors lang new-color) - new-color) - -(define colors-table (hash-copy orig-colors)) - -(define (next-color lang key) - (let ([lst (hash-ref colors-table key)]) - (cond - [(null? lst) - (eprintf "ran out of ~a for ~a\n" key lang) - (hash-set! colors-table key (hash-ref orig-colors key)) - (next-color lang key)] - [else - (hash-set! colors-table key (cdr lst)) - (cond - [(list? (car lst)) - (apply new-color lang (car lst))] - [else - (let ([color (send the-color-database find-color (car lst))]) - (new-color lang - (send color red) - (send color green) - (send color blue)))])]))) - -(define (to-hex n) - (cond - [(<= n 15) (format "0~a" (number->string n 16))] - [else (number->string n 16)])) - -(define (to-dot) - (printf "digraph {\n") - (hash-for-each - ht - (λ (lang files) - (for-each - (λ (file) (file-to-dot file lang)) - files))) - (printf "}\n")) - -(call-with-output-file "lang.dot" - (λ (port) - (parameterize ([current-output-port port]) - (to-dot))) - #:exists 'truncate) - -(define-runtime-path lang-colors.rkt "lang-colors.rkt") -(call-with-output-file lang-colors.rkt - (λ (port) - (pretty-write - (sort (hash-map colors list) - string<=? - #:key car) - port)) - #:exists 'truncate) - -(printf "calling twopi\n") -(void - (parameterize ([current-input-port (open-input-string "")]) - (system (format "~a -Tplain lang.dot > lang.plain" - (if (file-exists? "/usr/local/bin/twopi") - "/usr/local/bin/twopi" - "/usr/bin/twopi"))))) diff --git a/lang-slide.ss b/lang-slide.ss @@ -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.rkt "lang-colors.rkt") - -(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.rkt 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))) diff --git a/draw-plain.ss b/lang-slide/draw-plain.rkt diff --git a/lang-slide/find.rkt b/lang-slide/find.rkt @@ -0,0 +1,280 @@ +#lang racket +(require racket/system + racket/draw + racket/runtime-path + "orig-colors.rkt") + +(define (get-language i) + (and (or (regexp-match #rx"scrbl$" (path->string i)) + (regexp-match #rx"[.]rkt$" (path->string i)) + (regexp-match #rx"[.]ss$" (path->string i)) + (regexp-match #rx"[.]scm$" (path->string i))) + (call-with-input-file i + (λ (port) + (simplify-language + (and (not (skip-file? i)) + (parameterize ([read-accept-reader #t]) + (with-handlers ((exn:fail? (λ (x) (printf "exn when reading ~s\n" i) (raise x)))) + (let loop () + (let ([line (read-line (peeking-input-port port))]) + (cond + [(eof-object? line) + (error 'get-language "got to eof without finding a language")] + [(regexp-match #rx"[(]" line) + (cond + [(regexp-match #rx"module [^ ]* +(.*)$" line) + => + (λ (m) + (let ([obj (read (open-input-string (list-ref m 1)))]) + (if (string? obj) + (format "s-exp ~a" obj) + (format "~a" obj))))] + [else + (match (read port) + [`(module ,modname ,lang ,stuff ...) + (if (string? lang) + (format "s-exp ~a" lang) + (format "~a" lang))] + [else + + #f ;; here we just assume there is no language specified + #;(error 'get-language "found a paren, but not a module expression in ~s" i)])])] + [(regexp-match #rx"#reader ?scribble/reader" line) + (read-line port) + (loop)] + [(regexp-match #rx"#reader" line) + (parse-reader-line port)] + [(regexp-match #rx"#lang (.*)$" line) + => + (λ (m) (list-ref m 1))] + [(regexp-match #rx"#!r6rs$" line) "r6rs"] + [else + (read-line port) + (loop)]))))))))))) + +(define (simplify-language lang) + (and lang + (let ([lang + (regexp-replace + #rx" +$" + (regexp-replace* #rx"\"" + (regexp-replace* #rx"s-exp " lang "") + "") + "")]) + (cond + [(regexp-match #rx"^scheme" lang) + (simplify-language (string-append "racket" (substring lang 6)))] + [(regexp-match #rx"#%kernel" lang) + "#%kernel"] + [(regexp-match #rx"lib infotab.ss setup" lang) + "setup/infotab"] + [(regexp-match #rx"slideshow" lang) + "slideshow"] + [(regexp-match #rx"typed/scheme$" lang) + "typed/racket"] + [(regexp-match #rx"typed-scheme$" lang) + "typed/racket"] + [(regexp-match #rx"racket/unit/lang" lang) + "racket/unit"] + [(regexp-match #rx"srfi/provider" lang) + "srfi/provider"] + [(regexp-match #rx"htdp/bsl/reader" lang) + "htdp/bsl"] + [(regexp-match #rx"htdp-beginner.ss" lang) + "htdp/bsl"] + [(regexp-match #rx"htdp-intermediate.ss" lang) + "htdp/isl"] + [(regexp-match #rx"htdp-intermediate-lambda.ss" lang) + "htdp/isl+"] + [(regexp-match #rx"htdp-advanced.ss" lang) + "htdp/asl"] + [else lang])))) + + +(define (skip-file? path) + (let ([str (path->string path)]) + (or (regexp-match #rx"collects/games/loa/main.ss" str) + (regexp-match #rx"collects/tests" str) + (regexp-match #rx"collects/scribblings/guide/contracts-examples" str) + (regexp-match #rx"collects/htdp/tests/matrix-" str) + (regexp-match #rx"collects/scribblings/guide/read.scrbl" str)))) + +(define (parse-reader-line port) + (let ([line (read-line port)]) + (cond + [(regexp-match #rx"htdp-beginner-reader.ss" line) + "htdp/bsl"] + [else + (error 'parse-reader-line "unknown line ~s" line)]))) + + +(define ht (make-hash)) +(for ((i (in-directory (simplify-path (build-path (collection-path "racket") 'up))))) + (let ([lang (get-language i)]) + (when lang + (hash-set! ht lang (cons i (hash-ref ht lang '())))))) +(let ([one-offs '()]) + (hash-for-each + ht + (λ (k v) (when (= 1 (length v)) + (hash-remove! ht k) + (set! one-offs (cons (car v) one-offs))))) + (hash-set! ht "one off language" one-offs)) + +(sort (hash-map ht (λ (x y) (list x (length y)))) string<=? #:key car) + +(define existing-edges (make-hash)) +(define existing-interior-nodes (make-hash)) +(define directory->languages (make-hash)) + +(define depth-table (make-hash)) + +(define path->rank + (let ([rank-table (make-hash)]) + (λ (path) + (hash-ref rank-table path + (λ () + (let ([next (hash-count rank-table)]) + (hash-set! rank-table path (format "rank~a" next)) + (format "rank~a" next))))))) + +(define (file-to-dot filename language) + (let ([path (find-relative-path (simplify-path (build-path (collection-path "drscheme") 'up 'up)) + filename)]) + (let loop ([eles (explode-path path)] + [parent (build-path 'same)] + [depth 0]) + (let* ([child (build-path parent (car eles))] + [key (cons parent child)]) + + (cond + [(null? (cdr eles)) + (unless (member language (hash-ref directory->languages parent '())) + (hash-set! directory->languages parent (cons language (hash-ref directory->languages parent '()))) + (unless (hash-ref existing-edges key #f) + (hash-set! existing-edges key #t) + (printf " \"~a\" -> \"~a\" [color=gray,arrowhead=none,arrowtail=none];\n" parent child)) + (hash-set! depth-table depth (+ 1 (hash-ref depth-table depth 0))) + (let ([rank (path->rank parent)]) + (printf " \"~a\" [label=\"\",shape=circle,fillcolor=\"~a\",color=\"~a\",style=filled] ;\n" + (path->string child) + (language->color filename language) + (language->color filename language))))] + [else + (unless (hash-ref existing-edges key #f) + (hash-set! existing-edges key #t) + (printf " \"~a\" -> \"~a\" [color=gray,arrowhead=none,arrowtail=none];\n" parent child)) + (unless (hash-ref existing-interior-nodes parent #f) + (hash-set! existing-interior-nodes parent #t) + (printf " \"~a\" [shape=point,color=gray];\n" parent)) + (unless (hash-ref existing-interior-nodes child #f) + (hash-set! existing-interior-nodes child #t) + (printf " \"~a\" [shape=point,color=gray];\n" child)) + (loop (cdr eles) child (+ depth 1))]))))) + +(define colors (make-hash)) + +(define (language->color file lang) + (hash-ref colors lang + (λ () + (cond + [(regexp-match #rx"web" lang) + (next-color lang 'purple)] + [(or (regexp-match #rx"frtime" lang)) + (next-color lang 'gray)] + [(regexp-match #rx"typed" lang) + (next-color lang 'orange)] + [(or (regexp-match #rx"at-exp" lang) + (regexp-match #rx"scribble" lang)) + (next-color lang 'red)] + [(or (regexp-match #rx"scheme" lang) + (regexp-match #rx"racket" lang) + (regexp-match #rx"slideshow" lang) + (regexp-match #rx"#%kernel" lang) + (regexp-match #rx"pre-base.rkt" lang)) + (next-color lang 'blue)] + [(or (regexp-match #rx"srfi" lang) + (regexp-match #rx"r6rs" lang) + (regexp-match #rx"r5rs" lang)) + (next-color lang 'pink)] + [(regexp-match #rx"module-reader" lang) + (next-color lang 'brown)] + [(regexp-match #rx"setup" lang) + (next-color lang 'yellow)] + [(or (regexp-match #rx"htdp" lang) + (regexp-match #rx"DMdA" lang)) + (next-color lang 'green)] + [(regexp-match #rx"swindle" lang) + (next-color lang 'cyan)] + [else + (fprintf (current-error-port) "unknown language ~s ~s\n" lang (length (hash-ref ht lang))) + (new-color lang 0 0 0)])))) + +(define (new-color lang r g b) + (define new-color (string-append + "#" + (to-hex r) + (to-hex g) + (to-hex b))) + (hash-set! colors lang new-color) + new-color) + +(define colors-table (hash-copy orig-colors)) + +(define (next-color lang key) + (let ([lst (hash-ref colors-table key)]) + (cond + [(null? lst) + (eprintf "ran out of ~a for ~a\n" key lang) + (hash-set! colors-table key (hash-ref orig-colors key)) + (next-color lang key)] + [else + (hash-set! colors-table key (cdr lst)) + (cond + [(list? (car lst)) + (apply new-color lang (car lst))] + [else + (let ([color (send the-color-database find-color (car lst))]) + (new-color lang + (send color red) + (send color green) + (send color blue)))])]))) + +(define (to-hex n) + (cond + [(<= n 15) (format "0~a" (number->string n 16))] + [else (number->string n 16)])) + +(define (to-dot) + (printf "digraph {\n") + (hash-for-each + ht + (λ (lang files) + (for-each + (λ (file) (file-to-dot file lang)) + files))) + (printf "}\n")) + +(call-with-output-file "lang.dot" + (λ (port) + (parameterize ([current-output-port port]) + (to-dot))) + #:exists 'truncate) + +(define-runtime-path lang-colors.rktd "lang-colors.rktd") +(call-with-output-file lang-colors.rktd + (λ (port) + (pretty-write + (sort (hash-map colors list) + string<=? + #:key car) + port)) + #:exists 'truncate) + +(printf "calling twopi\n") +(void + (parameterize ([current-input-port (open-input-string "")]) + (system (format "~a -Tplain lang.dot > lang.plain" + (if (file-exists? "/usr/local/bin/twopi") + "/usr/local/bin/twopi" + "/usr/bin/twopi"))))) diff --git a/lang-colors.rkt b/lang-slide/lang-colors.rktd diff --git a/lang-slide/lang-slide.rkt b/lang-slide/lang-slide.rkt @@ -0,0 +1,103 @@ +#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))) diff --git a/lang.plain b/lang-slide/lang.plain diff --git a/main.rkt b/lang-slide/main.rkt diff --git a/mk-img.ss b/lang-slide/mk-img.rkt diff --git a/orig-colors.rkt b/lang-slide/orig-colors.rkt