You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
304 lines
8.5 KiB
Racket
304 lines
8.5 KiB
Racket
#lang racket/base
|
|
(require racket/contract racket/match racket/string)
|
|
|
|
(require "named-colors.rkt")
|
|
|
|
(module+ test (require rackunit))
|
|
|
|
|
|
;; Conversion functions between RGB and other color systems.
|
|
;; Adaptation of colorsys module in the Python library
|
|
;; Original source:
|
|
;; http://hg.python.org/cpython/file/2.7/Lib/colorsys.py
|
|
|
|
;; References:
|
|
;; http://en.wikipedia.org/wiki/HLS_color_space
|
|
|
|
|
|
(provide rgb->hsl hsl->rgb
|
|
rgb->hex hex->rgb
|
|
hsl->hex hex->hsl)
|
|
|
|
|
|
;; this makes things work on exact numbers by default
|
|
(read-decimal-as-inexact #f)
|
|
|
|
|
|
(define unitval? (real-in 0 1))
|
|
|
|
(define/contract (real->unitval x)
|
|
(real? . -> . unitval?)
|
|
(min (max 0 x) 1))
|
|
|
|
(module+ test
|
|
(check-equal? (real->unitval -10) 0)
|
|
(check-equal? (real->unitval 10) 1)
|
|
(check-equal? (real->unitval 0.5) 0.5))
|
|
|
|
|
|
(define DEGREE_MAX 360)
|
|
(define degree? (real-in 0 DEGREE_MAX))
|
|
|
|
(module+ test
|
|
(check-false (degree? -1))
|
|
(check-true (degree? 0))
|
|
(check-true (degree? 149.23))
|
|
(check-true (degree? 255))
|
|
(check-false (degree? 361)))
|
|
|
|
|
|
;; like (modulo x 1) but works with floating-point numbers
|
|
(define (modulo1 x)
|
|
(- x (floor x)))
|
|
|
|
|
|
(define/contract (unitval->byte u)
|
|
(unitval? . -> . byte?)
|
|
(inexact->exact (floor (* u 255))))
|
|
|
|
(module+ test
|
|
(check-equal? (unitval->byte 0) 0)
|
|
(check-equal? (unitval->byte 1) 255))
|
|
|
|
|
|
(define/contract (byte->unitval b)
|
|
(byte? . -> . unitval?)
|
|
(/ b 255))
|
|
|
|
(module+ test
|
|
(check-equal? (byte->unitval 0) 0)
|
|
(check-equal? (byte->unitval 255) 1))
|
|
|
|
|
|
(define (degree-string? x)
|
|
(and (string? x) (degree? (string->number x))))
|
|
|
|
(define/contract (unitval->degree u)
|
|
(unitval? . -> . degree-string?)
|
|
(format "~a" (exact->inexact (/ (floor (* u DEGREE_MAX 100)) 100))))
|
|
|
|
(module+ test
|
|
(check-equal? (unitval->degree 0) "0.0")
|
|
(check-equal? (unitval->degree 0.5) "180.0")
|
|
(check-equal? (unitval->degree 1) "360.0"))
|
|
|
|
(define (unitval->percentage u)
|
|
(format "~a%" (exact->inexact (/ (floor (* u 100 100)) 100))))
|
|
|
|
|
|
(module+ test
|
|
(check-true (degree-string? "0"))
|
|
(check-true (degree-string? "180"))
|
|
(check-true (degree-string? "360"))
|
|
(check-false (degree-string? "450"))
|
|
(check-false (degree-string? 450))
|
|
(check-false (degree-string? "foo")))
|
|
|
|
|
|
(define/contract (degree-string->unitval d)
|
|
(degree-string? . -> . unitval?)
|
|
(/ (string->number d) DEGREE_MAX))
|
|
|
|
(module+ test
|
|
(check-equal? (degree-string->unitval "0") 0)
|
|
(check-equal? (degree-string->unitval "180") (/ 1 2))
|
|
(check-equal? (degree-string->unitval "360") 1))
|
|
|
|
|
|
(define/contract (trim-unitval-sign x)
|
|
(string? . -> . string?)
|
|
(string-trim x "%" #:left? #f))
|
|
|
|
(module+ test
|
|
(check-equal? (trim-unitval-sign "50") "50")
|
|
(check-equal? (trim-unitval-sign "50%") "50")
|
|
(check-equal? (trim-unitval-sign "%50%") "%50"))
|
|
|
|
(define/contract (unitval-string? x)
|
|
(any/c . -> . boolean?)
|
|
(and (string? x)
|
|
(equal? #\% (car (reverse (string->list x))))
|
|
((real-in 0 100) (string->number (trim-unitval-sign x)))))
|
|
|
|
(module+ test
|
|
(check-true (unitval-string? "56%"))
|
|
(check-true (unitval-string? "0.00001%"))
|
|
(check-false (unitval-string? 50))
|
|
(check-false (unitval-string? "50"))
|
|
(check-false (unitval-string? "-12%"))
|
|
(check-false (unitval-string? "200%")))
|
|
|
|
|
|
(define/contract (unitval-string->unitval x)
|
|
(unitval-string? . -> . unitval?)
|
|
(/ (string->number (trim-unitval-sign x)) 100))
|
|
|
|
(module+ test
|
|
(check-equal? (unitval-string->unitval "50%") (/ 1 2))
|
|
(check-equal? (unitval-string->unitval "100%") 1)
|
|
(check-equal? (unitval-string->unitval "0%") 0))
|
|
|
|
|
|
(define (trim-pound-sign x)
|
|
(string-trim x "#" #:right? #f))
|
|
|
|
(define (make-hex-number x)
|
|
(string->number (string-append "#x" (trim-pound-sign x))))
|
|
|
|
|
|
(define HEX_DIGITS (string->list "0123456789abcdef"))
|
|
(define (hex-digit? x)
|
|
(member x HEX_DIGITS))
|
|
|
|
(define (base-hex? x)
|
|
(and (string? x)
|
|
(equal? (substring x 0 1) "#")
|
|
(andmap hex-digit? (string->list (string-downcase (trim-pound-sign x))))))
|
|
|
|
(define (short-hex? x) ; like #ddd
|
|
(and (= (string-length x) 4) (base-hex? x)))
|
|
|
|
(define (long-hex? x) ; like #e802cf
|
|
(and (= (string-length x) 7) (base-hex? x)))
|
|
|
|
(define (hex? x)
|
|
(or (short-hex? x) (long-hex? x)))
|
|
|
|
(define rgb? (list/c unitval? unitval? unitval?))
|
|
(define hsl? rgb?)
|
|
|
|
(define (rgbish? x)
|
|
(ormap (λ(proc) (proc x))
|
|
(list
|
|
rgb?
|
|
(list/c unitval-string? unitval-string? unitval-string?)
|
|
(list/c byte? byte? byte?)
|
|
hex?
|
|
named-color?)))
|
|
|
|
(define/contract (rgbish->rgb x)
|
|
(rgbish? . -> . rgb?)
|
|
;; must handle all possible branches of rgbish
|
|
(cond
|
|
[(rgb? x) x]
|
|
[((list/c unitval-string? unitval-string? unitval-string?) x)
|
|
(map unitval-string->unitval x)]
|
|
[((list/c byte? byte? byte?) x) (map byte->unitval x)]
|
|
[(hex? x) (hex->rgb x)]
|
|
[(named-color? x) (rgbish->rgb (named-color->hex x))]
|
|
[else #f]))
|
|
|
|
|
|
(define (hslish? x)
|
|
(ormap (λ(proc) (proc x))
|
|
(list
|
|
hsl?
|
|
(list/c degree-string? unitval-string? unitval-string?) ; aka css-hsl
|
|
(list/c byte? byte? byte?))))
|
|
|
|
(define (hslish->hsl x)
|
|
(hslish? . -> . hsl?)
|
|
(cond
|
|
[(hsl? x) x]
|
|
[((list/c degree-string? unitval-string? unitval-string?) x) (cons (degree-string->unitval (car x)) (map unitval-string->unitval (cdr x)))]
|
|
[((list/c byte? byte? byte?) x) (map byte->unitval x)]
|
|
[else #f]))
|
|
|
|
(define (hsl->css hsl)
|
|
(hslish? . -> . hsl?)
|
|
(match-define (list h s lum) (hslish->hsl hsl))
|
|
(list (unitval->degree h) (unitval->percentage s) (unitval->percentage lum)))
|
|
|
|
;; convert rgb values into hue value
|
|
(define/contract (rgb->h r g b)
|
|
(unitval? unitval? unitval? . -> . unitval?)
|
|
(define maxc (max r g b))
|
|
(define minc (min r g b))
|
|
(if (minc . = . maxc)
|
|
0 ; color is gray. Return now & avoid division by zero below
|
|
(let ()
|
|
(define-values (rc gc bc)
|
|
(apply values (map (λ(x) (/ (- maxc x) (- maxc minc))) (list r g b))))
|
|
(modulo1 (/ (cond
|
|
[(r . = . maxc) (- bc gc)]
|
|
[(g . = . maxc) (+ 2.0 (- rc bc))]
|
|
[else (+ 4.0 (- gc rc))])
|
|
6.0)))))
|
|
|
|
|
|
(define/contract (rgb->hsl rgb)
|
|
(rgbish? . -> . hsl?)
|
|
(match-define (list r g b) (rgbish->rgb rgb))
|
|
(define maxc (max r g b))
|
|
(define minc (min r g b))
|
|
(define h (rgb->h r g b))
|
|
(define lum (/ (+ maxc minc) 2))
|
|
(define s (/ (- maxc minc) (if (lum . <= . 0.5)
|
|
(+ maxc minc)
|
|
(- 2.0 maxc minc))))
|
|
(map real->unitval (list h s lum)))
|
|
|
|
(define/contract (hsl->rgb hsl)
|
|
(hslish? . -> . rgb?)
|
|
(define ONE_THIRD (/ 1 3))
|
|
(define ONE_SIXTH (/ 1 6))
|
|
(define TWO_THIRDS (/ 2 3))
|
|
(match-define (list h s lum) (hslish->hsl hsl))
|
|
|
|
(define (_v m1 m2 hue)
|
|
(let ([hue (modulo1 hue)])
|
|
(cond
|
|
[(hue . < . ONE_SIXTH) (+ m1 (* (- m2 m1) hue 6.0))]
|
|
[(hue . < . 0.5) m2]
|
|
[(hue . < . TWO_THIRDS) (+ m1 (* (- m2 m1) (- TWO_THIRDS hue) 6.0))]
|
|
[else m1])))
|
|
|
|
(define m2 (if (lum . <= . 0.5)
|
|
(* lum (+ 1.0 s))
|
|
(- (+ lum s) (* lum s))))
|
|
|
|
(define m1 (- (* 2.0 lum) m2))
|
|
|
|
(map real->unitval (map (λ(x) (_v m1 m2 x))
|
|
(list (+ h ONE_THIRD) h (- h ONE_THIRD)))))
|
|
|
|
|
|
|
|
(define/contract (rgb->hex rgb)
|
|
(rgbish? . -> . hex?)
|
|
;; make a 2-digit hex string from a number
|
|
(define (hex-format num)
|
|
(define hex (format "~x" num))
|
|
(if (= (string-length hex) 1)
|
|
(string-append "0" hex)
|
|
hex))
|
|
|
|
(define raw-hex (apply string-append (map hex-format (map unitval->byte (rgbish->rgb rgb)))))
|
|
(define triple-double-pattern #px"^(\\w)\\1(\\w)\\2(\\w)\\3$")
|
|
(define result (regexp-match triple-double-pattern raw-hex))
|
|
(string-append "#" (if result
|
|
; cdr result holds the three submatches
|
|
(apply string-append (cdr result))
|
|
raw-hex)))
|
|
|
|
(module+ test
|
|
(check-equal? (rgb->hex '(1 1 1)) "#fff")
|
|
(check-equal? (rgb->hex '(0.8 0.8 0.8)) "#ccc")
|
|
(check-equal? (rgb->hex '(0.01 0.01 0.01)) "#020202"))
|
|
|
|
(define/contract (hex->long-hex hex)
|
|
(hex? . -> . long-hex?)
|
|
(if (short-hex? hex)
|
|
(let ()
|
|
(match-define (list d1 d2 d3) (cdr (regexp-match #px"^#(\\w)(\\w)(\\w)$" hex)))
|
|
(string-append "#" d1 d1 d2 d2 d3 d3))
|
|
hex))
|
|
|
|
(define/contract (hex->rgb hex)
|
|
(hex? . -> . rgb?)
|
|
(let ([hex (hex->long-hex hex)])
|
|
(define result (regexp-match #px"^#(\\w\\w)(\\w\\w)(\\w\\w)$" hex))
|
|
(map (compose1 byte->unitval make-hex-number) (cdr result))))
|
|
|
|
(define hsl->hex (compose1 rgb->hex hsl->rgb))
|
|
(define hex->hsl (compose1 rgb->hsl hex->rgb)) |