commit eff0f6cef383b82a186a9793d9bde048f6a17382
parent 1752047aa791eea175e3eadf5136887504787603
Author: Georges Dupéron <georges.duperon@gmail.com>
Date: Fri, 1 Apr 2016 00:40:30 +0200
Added documentation and integrated the pictures in it.
Diffstat:
6 files changed, 156 insertions(+), 103 deletions(-)
diff --git a/.gitignore b/.gitignore
@@ -1,3 +1,5 @@
*~
lang.dot
compiled/
+/doc/
+/lang-slide/doc/
+\ No newline at end of file
diff --git a/lang-slide/draw-plain.rkt b/lang-slide/draw-plain.rkt
@@ -1,8 +1,9 @@
-#lang scheme/gui
+#lang racket ;scheme/gui
(provide lang-pict string->color)
(require scheme/runtime-path
- slideshow)
+ slideshow/pict
+ racket/draw)
(define-runtime-path lang.plain "lang.plain")
diff --git a/lang-slide/info.rkt b/lang-slide/info.rkt
@@ -0,0 +1,5 @@
+#lang info
+(define build-deps '("scribble-lib" "racket-doc"))
+(define scribblings '(("scribblings/lang-slide.scrbl" ())))
+(define pkg-desc "A picture showing all the languages used to implement Racket.")
+(define version "1.0")
diff --git a/lang-slide/main.rkt b/lang-slide/main.rkt
@@ -1,110 +1,29 @@
#lang scheme
-(provide langs-pict
+
+(provide (rename-out [langs-pict1 langs-pict])
langs-in-tree
langs-with-colors)
+(require "pictures.rkt")
(require "draw-plain.ss"
"orig-colors.rkt"
- racket/draw slideshow/code
+ racket/draw
+ slideshow/code
scheme/runtime-path
- slideshow)
-(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 14])
- (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?
- #:fit? [fit? #f]
- #: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))
- (define all
- (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)))
- (if fit?
- (scale all (min 1
- (/ client-w (pict-width all))
- (/ client-h (pict-height all))))
- all))
-
-(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))
+ slideshow/pict
+ slideshow/base
+ "pictures.rkt")
+
+(define (langs-pict1 color?
+ #:fit? [fit? #f]
+ #:picts [p (if (pict? color?) (list color?) (list))])
+ (langs-pict color?
+ #:fit (λ (all)
+ (if fit?
+ (scale all (min 1
+ (/ client-w (pict-width all))
+ (/ client-h (pict-height all))))
+ all))
+ #:picts p))
(module+ main
(slide (langs-pict #f))
diff --git a/lang-slide/pictures.rkt b/lang-slide/pictures.rkt
@@ -0,0 +1,107 @@
+#lang racket
+
+(require "draw-plain.ss"
+ "orig-colors.rkt"
+ racket/draw
+ slideshow/code-pict
+ racket/runtime-path
+ slideshow/pict)
+
+(provide langs-pict
+ langs-in-tree
+ langs-with-colors)
+
+(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)
+ (let ([font-size 14])
+ (hc-append 6
+ (colorize (filled-ellipse 14 14)
+ (string->color (cadr cl)))
+ (text (car cl) (current-code-font) font-size))))
+
+(define (langs-pict color?
+ #:fit [fit (λ (x) x)]
+ #: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))
+ (define all
+ (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)))
+ (fit all))
+
+(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))
diff --git a/lang-slide/scribblings/lang-slide.scrbl b/lang-slide/scribblings/lang-slide.scrbl
@@ -0,0 +1,18 @@
+#lang scribble/manual
+@require[@for-label[lang-slide
+ racket/base]
+ lang-slide/pictures
+ ;slideshow/pict
+ ]
+
+@title{A picture showing all the languages used to implement Racket.}
+
+Source code: @url{https://github.com/samth/lang-slide}
+
+Here is a bird's eye view of the modules implementing racket:
+
+@(langs-pict #f)
+
+And here is the languages they use:
+
+@(langs-pict #t)
