suzanne.soy/lang-slide
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fixed color sorting algorithm

Browse Source
This commit is contained in:
Robby Findler 2012-09-04 20:56:16 +02:00
parent a5653bf9bb
commit 2a09449884
3 changed files with 46 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
find.rkt
View File

@ -1,7 +1,8 @@
#lang racket
(require racket/system
racket/draw
racket/runtime-path)
racket/runtime-path
"orig-colors.rkt")
(define (get-language i)
(and (or (regexp-match #rx"scrbl$" (path->string i))
@ -218,20 +219,6 @@
(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" "gold"))
(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"))
(cyan . ((0 255 255) (150 255 255)))
(brown . ("brown"))))
(define colors-table (hash-copy orig-colors))
(define (next-color lang key)

42
lang-slide.ss
View File

@ -3,29 +3,45 @@
langs-in-tree
langs-with-colors)
(require "draw-plain.ss"
"orig-colors.rkt"
slideshow slideshow/code
scheme/runtime-path)
scheme/runtime-path
racket/gui/base)
(define-runtime-path lang-colors.rkt "lang-colors.rkt")
(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-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]
[(other) 4]
[(black) 5]
[(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)
@ -33,7 +49,7 @@
(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)])

15
orig-colors.rkt Normal file
View File

@ -0,0 +1,15 @@
#lang racket/base
(provide orig-colors)
(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" "gold"))
(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"))
(cyan . ((0 255 255) (150 255 255)))
(brown . ("brown"))))