129 lines
3.4 KiB
Racket
129 lines
3.4 KiB
Racket
#lang racket/base
|
|
|
|
(require racket/contract
|
|
racket-sprintf
|
|
)
|
|
|
|
(provide rgba
|
|
hex->rgba
|
|
rgba->hex
|
|
rgba?
|
|
rgba-blue
|
|
rgba-red
|
|
rgba-green
|
|
rgba-alpha
|
|
rgba-blue!
|
|
rgba-red!
|
|
rgba-green!
|
|
rgba-alpha!
|
|
)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Data structures
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define-struct rgba*
|
|
([red #:mutable] [green #:mutable] [blue #:mutable] [alpha #:mutable])
|
|
#:transparent
|
|
)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Support functions
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (between-0-255? x)
|
|
(and (integer? x)
|
|
(>= x 0)
|
|
(<= x 255)))
|
|
|
|
|
|
(define (optional-between-0-255? x)
|
|
(write x)
|
|
(newline)
|
|
(or (null? x)
|
|
(and (= (length x) 1)
|
|
(between-0-255? (car x)))))
|
|
|
|
(define (hex2->int str)
|
|
(let ((s (string-downcase str))
|
|
(sub (- (char->integer #\a) 10))
|
|
(subnum (char->integer #\0)))
|
|
(let ((ac (string-ref s 0))
|
|
(bc (string-ref s 1)))
|
|
(let ((a (- (char->integer ac) (if (char>=? ac #\a) sub subnum)))
|
|
(b (- (char->integer bc) (if (char>=? bc #\a) sub subnum))))
|
|
(+ (* a 16) b)))))
|
|
|
|
(define (hex-color? c)
|
|
(let ((re #px"[#]?([0-9a-fA-F]{2})([0-9a-fA-F]{2})([0-9a-fA-F]{2})([0-9a-fA-F]{2})?"))
|
|
(let ((m (regexp-match re c)))
|
|
(not (eq? m #f)))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; API
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (rgba? c)
|
|
(rgba*? c))
|
|
|
|
(define/contract (rgba r g b . a)
|
|
(->* (between-0-255? between-0-255? between-0-255?) (between-0-255?) rgba?)
|
|
(make-rgba* r g b (if (null? a) 255 (car a)))
|
|
)
|
|
|
|
(define/contract (hex->rgba h)
|
|
(-> hex-color? rgba?)
|
|
(let ((re #px"[#]?([0-9a-fA-F]{2})([0-9a-fA-F]{2})([0-9a-fA-F]{2})([0-9a-fA-F]{2})?"))
|
|
(let ((m (regexp-match re h)))
|
|
(if (eq? m #f)
|
|
(error "Not a CSS hex color string")
|
|
(rgba (hex2->int (list-ref m 1))
|
|
(hex2->int (list-ref m 2))
|
|
(hex2->int (list-ref m 3))
|
|
(if (eq? (list-ref m 4) #f)
|
|
255
|
|
(hex2->int (list-ref m 4))))))))
|
|
|
|
(define/contract (rgba->hex c)
|
|
(-> rgba? string?)
|
|
(string-append
|
|
(sprintf "#%02x%02x%02x" (rgba-red c) (rgba-green c) (rgba-blue c))
|
|
(if (= (rgba-alpha c) 255)
|
|
""
|
|
(sprintf "%02x" (rgba-alpha c)))))
|
|
|
|
|
|
(define/contract (rgba-red! c r)
|
|
(-> rgba? between-0-255? rgba?)
|
|
(set-rgba*-red! c r))
|
|
|
|
(define/contract (rgba-green! c g)
|
|
(-> rgba? between-0-255? rgba?)
|
|
(set-rgba*-green! c g))
|
|
|
|
(define/contract (rgba-blue! c b)
|
|
(-> rgba? between-0-255? rgba?)
|
|
(set-rgba*-blue! c b))
|
|
|
|
(define/contract (rgba-alpha! c a)
|
|
(-> rgba? between-0-255? rgba?)
|
|
(set-rgba*-alpha! c a))
|
|
|
|
(define/contract (rgba-red c)
|
|
(-> rgba? between-0-255?)
|
|
(rgba*-red c))
|
|
|
|
(define/contract (rgba-green c)
|
|
(-> rgba? between-0-255?)
|
|
(rgba*-green c))
|
|
|
|
(define/contract (rgba-blue c)
|
|
(-> rgba? between-0-255?)
|
|
(rgba*-blue c))
|
|
|
|
(define/contract (rgba-alpha c)
|
|
(-> rgba? between-0-255?)
|
|
(rgba*-alpha c))
|
|
|
|
|