Initial commit, as given at DARPA PI meeting
This commit is contained in:
Sam Tobin-Hochstadt
commit
8d6398cda6
157
draw-plain.ss
Normal file
157
draw-plain.ss
Normal file
|
|
@ -0,0 +1,157 @@
|
|||
#lang scheme/gui
|
||||
(provide lang-pict string->color)
|
||||
|
||||
(require scheme/runtime-path
|
||||
slideshow)
|
||||
|
||||
(define-runtime-path lang.plain "lang.plain")
|
||||
|
||||
(define (parse-file)
|
||||
(call-with-input-file lang.plain
|
||||
(λ (port)
|
||||
(for ([l (in-lines port)])
|
||||
(parse-line l)))))
|
||||
|
||||
;; nodes : hash[string -o> node]
|
||||
(define nodes (make-hash))
|
||||
(define-struct node (x y w h type color) #:transparent)
|
||||
|
||||
;; parents : hash[string -o> string]
|
||||
(define parents (make-hash))
|
||||
|
||||
(define graph-width 0)
|
||||
(define graph-height 0)
|
||||
|
||||
(define (parse-line line)
|
||||
(cond
|
||||
[(regexp-match #rx"^node \"([^\"]*)\" +([0-9.]*) +([0-9.]*) +([0-9.]*) +([0-9.]*) +\"([^\"]*)\" +([^ ]*) +([^ ]*) +([^ ]*) +([^ ]*)"
|
||||
line)
|
||||
=>
|
||||
(λ (m)
|
||||
(let-values ([(id x y w h label type1 type2 color1 color2)
|
||||
(apply values (cdr m))])
|
||||
(hash-set! nodes id (make-node (string->number y)
|
||||
(string->number x)
|
||||
(string->number w)
|
||||
(string->number h)
|
||||
(string->symbol type2)
|
||||
(string->color color1)))))]
|
||||
[(regexp-match #rx"^edge \"([^\"]*)\" +\"([^\"]*)\""
|
||||
line)
|
||||
=>
|
||||
(λ (m)
|
||||
(let-values ([(src dest) (apply values (cdr m))])
|
||||
(hash-set! parents dest src)))]
|
||||
[(regexp-match #rx"^graph ([0-9.]*) ([0-9.]*) ([0-9.]*)" line)
|
||||
=>
|
||||
(λ (m)
|
||||
(let-values ([(scale w h) (apply values (cdr m))])
|
||||
(set! graph-width (string->number w))
|
||||
(set! graph-height (string->number h))))]
|
||||
[(regexp-match #rx"^stop" line) (void)]
|
||||
[else
|
||||
(error 'parse-line "unknown line ~s\n" line)]))
|
||||
|
||||
(define (string->color str)
|
||||
(cond
|
||||
[(regexp-match
|
||||
#rx"#([0-9a-f][0-9a-f])([0-9a-f][0-9a-f])([0-9a-f][0-9a-f])"
|
||||
str)
|
||||
=>
|
||||
(λ (m)
|
||||
(let-values ([(r g b) (apply values (cdr m))])
|
||||
(make-object color%
|
||||
(string->number r 16)
|
||||
(string->number g 16)
|
||||
(string->number b 16))))]
|
||||
[else
|
||||
(let ([c (send the-color-database find-color str)])
|
||||
(unless c
|
||||
(error 'string->color "unknown color ~s" str))
|
||||
c)]))
|
||||
|
||||
(define (draw-graph dc dx dy w h color?)
|
||||
(let ([scale (min (/ w graph-width)
|
||||
(/ h graph-height))])
|
||||
(define (draw-node name node)
|
||||
(case (node-type node)
|
||||
[(circle)
|
||||
(let-values ([(nx ny) (node->xy node)]
|
||||
[(px py) (node->xy (hash-ref nodes (hash-ref parents name)))])
|
||||
(let ([nw (* 1.8 (node-w node))]
|
||||
[nh (* 1.8 (node-h node))])
|
||||
(cond
|
||||
[color?
|
||||
(send dc set-pen "black" 1 'transparent)
|
||||
(send dc set-brush (node-color node) 'solid)]
|
||||
[else
|
||||
(send dc set-pen "SlateGray" 1 'solid)
|
||||
(send dc set-brush "LightSlateGray" 'solid)])
|
||||
(send dc draw-ellipse
|
||||
(+ dx (- nx (* scale (/ nw 2))))
|
||||
(+ dy (- ny (* scale (/ nh 2))))
|
||||
(* scale nw)
|
||||
(* scale nh))))]
|
||||
[else (void)]))
|
||||
(define (draw-edge src dest)
|
||||
(send dc set-pen "gray" 1 'solid)
|
||||
(send dc set-brush "black" 'transparent)
|
||||
(let-values ([(sx sy) (node->xy (hash-ref nodes src))]
|
||||
[(tx ty) (node->xy (hash-ref nodes dest))])
|
||||
(send dc draw-line
|
||||
(+ dx sx)
|
||||
(+ dy sy)
|
||||
(+ dx tx)
|
||||
(+ dy ty))))
|
||||
|
||||
(define (node->xy node)
|
||||
(values (* scale (node-x node))
|
||||
(- h (* scale (node-y node)))))
|
||||
(let ([smoothing (send dc get-smoothing)]
|
||||
[pen (send dc get-pen)]
|
||||
[brush (send dc get-brush)])
|
||||
(send dc set-smoothing 'aligned)
|
||||
(hash-for-each
|
||||
parents
|
||||
(λ (dest src)
|
||||
(draw-edge src dest)))
|
||||
(for-each
|
||||
(λ (name-node)
|
||||
(draw-node (car name-node)
|
||||
(cadr name-node)))
|
||||
(sort (hash-map nodes list)
|
||||
(compare-name-node-list w h)))
|
||||
(send dc set-smoothing smoothing)
|
||||
(send dc set-pen pen)
|
||||
(send dc set-brush brush))))
|
||||
|
||||
(define ((compare-name-node-list w h) name-node1 name-node2)
|
||||
(let* ([c (make-rectangular (/ w 2) (/ h 2))]
|
||||
[x (make-rectangular (node-x (cadr name-node1))
|
||||
(node-x (cadr name-node2)))]
|
||||
[y (make-rectangular (node-y (cadr name-node1))
|
||||
(node-y (cadr name-node2)))]
|
||||
[ax (angle (- x c))]
|
||||
[ay (angle (- y c))])
|
||||
(cond
|
||||
[(= ax ay)
|
||||
(< (magnitude x) (magnitude y))]
|
||||
[else
|
||||
(< ax ay)])))
|
||||
|
||||
(parse-file)
|
||||
|
||||
#;
|
||||
(begin
|
||||
(define f (new frame% [label ""]))
|
||||
(define c (new canvas%
|
||||
[parent f]
|
||||
[paint-callback
|
||||
(λ (c dc)
|
||||
(let-values ([(w h) (send c get-client-size)])
|
||||
(draw-graph dc 0 0 w h)))]))
|
||||
(send f show #t))
|
||||
|
||||
(define (lang-pict size color?)
|
||||
(dc (λ (dc dx dy) (draw-graph dc dx dy size size color?))
|
||||
size size))
|
||||
298
find.ss
Normal file
298
find.ss
Normal file
|
|
@ -0,0 +1,298 @@
|
|||
#lang scheme
|
||||
(require scheme/generator
|
||||
scheme/system
|
||||
racket/draw)
|
||||
|
||||
(define (in-files base [reg #f])
|
||||
(in-generator
|
||||
(let loop ([dir/file base])
|
||||
(cond
|
||||
[(directory-exists? dir/file)
|
||||
(for-each (λ (x) (loop (build-path dir/file x)))
|
||||
(directory-list dir/file))]
|
||||
[(file-exists? dir/file)
|
||||
(when (or (not reg)
|
||||
(regexp-match reg (path->string dir/file)))
|
||||
(yield dir/file))]))))
|
||||
|
||||
|
||||
(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-files (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))
|
||||
(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)]
|
||||
[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)
|
||||
(let ([new-color (string-append
|
||||
"#"
|
||||
(to-hex r)
|
||||
(to-hex g)
|
||||
(to-hex b))])
|
||||
(hash-set! colors lang new-color)
|
||||
new-color))
|
||||
|
||||
(define orig-colors
|
||||
#hash((blue . ((0 0 255) (0 0 240) (0 0 220) (0 0 205) (0 0 190) (0 0 160)
|
||||
(50 50 255) (80 80 255) (100 100 255) (0 0 130) (0 0 100) (0 0 70)
|
||||
"slateblue"))
|
||||
(green . ((0 255 0) (0 230 0) (0 200 0) (0 175 0) (0 150 0) (0 125 0) (0 100 0)))
|
||||
(red . ((255 0 0) (230 0 0) (200 0 0) (175 0 0) (150 0 0) (125 0 0) (100 0 0)))
|
||||
(yellow . ((255 255 0)))
|
||||
(orange . ("orange" "darkorange"))
|
||||
(gray . ((240 240 240) (220 220 220) (200 200 200) (180 180 180) (160 160 160) (130 130 130) (100 100 100) (70 70 70) (50 50 50) (30 30 30)))
|
||||
(pink . ("pink" "lightpink" "fuchsia"))
|
||||
(purple . ("orchid" "purple" "darkviolet"))
|
||||
(brown . ("brown"))))
|
||||
|
||||
(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)
|
||||
|
||||
(call-with-output-file "lang-colors.ss"
|
||||
(λ (port)
|
||||
(pretty-print
|
||||
(sort (hash-map colors list)
|
||||
string<=?
|
||||
#:key car)
|
||||
port))
|
||||
#:exists 'truncate)
|
||||
|
||||
(printf "calling twopi\n")
|
||||
(void
|
||||
(parameterize ([current-input-port (open-input-string "")])
|
||||
(system "/usr/bin/twopi -Tplain lang.dot > lang.plain")))
|
||||
43
lang-colors.ss
Normal file
43
lang-colors.ss
Normal file
|
|
@ -0,0 +1,43 @@
|
|||
(("#%kernel" "#0000cd")
|
||||
("at-exp racket/base" "#960000")
|
||||
("at-exp scheme/base" "#7d0000")
|
||||
("deinprogramm/DMdA" "#00af00")
|
||||
("env-lang.rkt" "#000000")
|
||||
("framework/private/decode" "#000000")
|
||||
("frtime" "#f0f0f0")
|
||||
("frtime/frtime-lang-only" "#dcdcdc")
|
||||
("frtime/lang-utils" "#c8c8c8")
|
||||
("htdp/asl" "#00c800")
|
||||
("htdp/bsl" "#00ff00")
|
||||
("htdp/isl+" "#00e600")
|
||||
("lang-utils.ss" "#000000")
|
||||
("meta/web" "#a020f0")
|
||||
("mzscheme" "#000046")
|
||||
("one off language" "#000000")
|
||||
("pre-base.rkt" "#000000")
|
||||
("r5rs" "#ffc0cb")
|
||||
("r6rs" "#ffb6c1")
|
||||
("racket" "#000064")
|
||||
("racket/base" "#0000f0")
|
||||
("racket/gui" "#6464ff")
|
||||
("racket/load" "#0000dc")
|
||||
("racket/private" "#000082")
|
||||
("racket/private/base" "#0000be")
|
||||
("racket/private/provider" "#0000ff")
|
||||
("racket/signature" "#3232ff")
|
||||
("racket/unit" "#0000a0")
|
||||
("scribble/base/reader" "#e60000")
|
||||
("scribble/doc" "#af0000")
|
||||
("scribble/lp" "#ff0000")
|
||||
("scribble/manual" "#c80000")
|
||||
("setup/infotab" "#ffff00")
|
||||
("slideshow" "#5050ff")
|
||||
("srfi/provider" "#ff00ff")
|
||||
("string-constant-lang.ss" "#000000")
|
||||
("swindle/base" "#000000")
|
||||
("swindle/turbo" "#000000")
|
||||
("syntax/module-reader" "#843c24")
|
||||
("typed-scheme/minimal" "#ffa500")
|
||||
("typed/racket" "#ff8c00")
|
||||
("web-server" "#da70d6")
|
||||
("web-server/insta" "#9400d3"))
|
||||
77
lang-slide.ss
Normal file
77
lang-slide.ss
Normal file
|
|
@ -0,0 +1,77 @@
|
|||
#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))
|
||||
3419
lang.plain
Normal file
3419
lang.plain
Normal file
File diff suppressed because it is too large
Load Diff
30
main.rkt
Normal file
30
main.rkt
Normal file
|
|
@ -0,0 +1,30 @@
|
|||
#lang racket/base
|
||||
(require "lang-slide.rkt" ;"../config.rkt"
|
||||
slideshow 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)
|
||||
(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)
|
||||
(langs-pict #f #:picts (list p1))]
|
||||
[else
|
||||
(langs-pict (vl-append 10 p1 p2))])))
|
||||
|
||||
17
mk-img.ss
Normal file
17
mk-img.ss
Normal file
|
|
@ -0,0 +1,17 @@
|
|||
#lang scheme/gui
|
||||
(require "lang-slide.ss" slideshow)
|
||||
|
||||
(define the-margin 32)
|
||||
|
||||
(define the-pict (let ([p (langs-pict #t)])
|
||||
(scale p (/ (- 1024 the-margin) (pict-width p)))))
|
||||
(pict-width the-pict)
|
||||
(define bm (make-object bitmap%
|
||||
(+ the-margin (ceiling (inexact->exact (pict-width the-pict))))
|
||||
(+ the-margin (ceiling (inexact->exact (pict-height the-pict))))))
|
||||
(define bdc (make-object bitmap-dc% bm))
|
||||
(send bdc set-smoothing 'aligned)
|
||||
(send bdc clear)
|
||||
(draw-pict the-pict bdc (/ the-margin 2) (/ the-margin 2))
|
||||
(send bdc set-bitmap #f)
|
||||
(send bm save-file "langs.png" 'png)
|
||||
Loading…
Reference in New Issue
Block a user