136 lines
3.7 KiB
Racket
136 lines
3.7 KiB
Racket
#lang racket
|
|
|
|
(define (hsl2rgb h s l)
|
|
(define (color q p h)
|
|
(let ((tc (cond
|
|
((> h 1) (- h 1))
|
|
((< h 0) (+ h 1))
|
|
(else h))))
|
|
(cond
|
|
((< tc 1/6) (+ p (* (- q p) tc 6)))
|
|
((< tc 1/2) q)
|
|
((< tc 2/3) (+ p (* (- q p) (- 2/3 tc) 6)))
|
|
(else p))))
|
|
(let* ((q (if (< l 0.5)
|
|
(* l (+ 1 s))
|
|
(+ l s (- (* l s)))))
|
|
(p (- (* 2 l) q)))
|
|
(values
|
|
(inexact->exact (round (* 256 (color q p (+ h 1/3)))))
|
|
(inexact->exact (round (* 256 (color q p h))))
|
|
(inexact->exact (round (* 256 (color q p (- h 1/3))))))))
|
|
|
|
(define (hsl2rgb-ref h s l)
|
|
(hsl2rgb (/ h 256) (/ s 256) (/ l 256)))
|
|
|
|
(define (hsv2rgb h s v)
|
|
(let* ((hi (modulo (floor (/ h 256/6)) 6))
|
|
(vmin (/ (* v (- 256 s)) 256))
|
|
(a (* (- v vmin) (/ (modulo h 43) 256/6)))
|
|
(vinc (+ vmin a))
|
|
(vdec (- v a))
|
|
|
|
(vmin (inexact->exact (round vmin)))
|
|
(vinc (inexact->exact (round vinc)))
|
|
(vdec (inexact->exact (round vdec))))
|
|
(cond
|
|
((= hi 0) (values v vinc vmin))
|
|
((= hi 1) (values vdec v vmin))
|
|
((= hi 2) (values vmin v vinc))
|
|
((= hi 3) (values vmin vdec v))
|
|
((= hi 4) (values vinc vmin v))
|
|
((= hi 5) (values v vmin vdec)))))
|
|
|
|
(define (hsv2rgb-int h s v)
|
|
(define (byte-div-43-mod-6 x)
|
|
(cond
|
|
((< x 43) 0)
|
|
((< x 86) 1)
|
|
((< x 128) 2)
|
|
((< x 171) 3)
|
|
((< x 214) 4)
|
|
(else 5)))
|
|
|
|
(define (byte-mod-43 x)
|
|
(cond
|
|
((< x 43) x)
|
|
((< x 86) (- x 43))
|
|
((< x 128) (- x 86))
|
|
((< x 171) (- x 128))
|
|
((< x 214) (- x 171))
|
|
(else (- x 214))))
|
|
|
|
(define (*6 a) (+ (arithmetic-shift a 1)
|
|
(arithmetic-shift a 2)))
|
|
|
|
(let* ((hi (byte-div-43-mod-6 h))
|
|
(vmin (arithmetic-shift
|
|
(* (- 255 s) v) -8))
|
|
(a (arithmetic-shift
|
|
(* (- v vmin)
|
|
(*6 (byte-mod-43 h))) -8))
|
|
(vinc (+ vmin a))
|
|
(vdec (- v a)))
|
|
(printf "hi=~a, vmin=~a, a=~a, vinc=~a, vdec=~a\n" hi vmin a vinc vdec)
|
|
(cond
|
|
((= hi 0) (values v vinc vmin))
|
|
((= hi 1) (values vdec v vmin))
|
|
((= hi 2) (values vmin v vinc))
|
|
((= hi 3) (values vmin vdec v))
|
|
((= hi 4) (values vinc vmin v))
|
|
((= hi 5) (values v vmin vdec)))))
|
|
|
|
(define (hsl2rgb-int h s l)
|
|
(define (*fp8 a b) (arithmetic-shift (* a b) -8))
|
|
(define (*2 a) (arithmetic-shift a 1))
|
|
(define (*6 a) (+ (arithmetic-shift a 1)
|
|
(arithmetic-shift a 2)))
|
|
|
|
(define c1/6 43)
|
|
(define c1/3 85)
|
|
(define c1/2 128)
|
|
(define c2/3 171)
|
|
(define c1 256)
|
|
|
|
(let* ((l*s (*fp8 l s))
|
|
(q (if (< l c1/2)
|
|
(+ l l*s)
|
|
(+ l s (- l*s))))
|
|
(p (- (*2 l) q))
|
|
(q-p ;;(- q p)
|
|
(*2 (- q l)))
|
|
(tr (if (< h c2/3) [+ h c1/3] [- c1/3 (- c1 h)]))
|
|
(tg h)
|
|
(tb (if (>= h c1/3) [- h c1/3] [- c1 h]))
|
|
(q-p*6 (*6 q-p))
|
|
|
|
(r (cond
|
|
((< tr c1/6) [+ p (*fp8 q-p*6 tr)])
|
|
((< tr c1/2) q)
|
|
((< tr c2/3) [+ p (*fp8 q-p*6 (- c2/3 tr))])
|
|
(else p)))
|
|
|
|
(g (cond
|
|
((< tg c1/6) [+ p (*fp8 q-p*6 tg)])
|
|
((< tg c1/2) q)
|
|
((< tg c2/3) [+ p (*fp8 q-p*6 (- c2/3 tg))])
|
|
(else p)))
|
|
|
|
(b (cond
|
|
((< tb c1/6) [+ p (*fp8 q-p*6 tb)])
|
|
((< tb c1/2) q)
|
|
((< tb c2/3) [+ p (*fp8 q-p*6 (- c2/3 tb))])
|
|
(else p))))
|
|
;; (printf "q=~a p=~a q-p=~a tr=~a tg=~a tb=~a\n" q p q-p tr tg tb)
|
|
(values r g b)))
|
|
|
|
(define (p f h s x)
|
|
(let-values (((r g b) (f h s x)))
|
|
(printf "HSX ~a ~a ~a -> " h s x)
|
|
(printf "RGB ~a ~a ~a\n\n" r g b)))
|
|
|
|
;;(p 20 255 100)
|
|
(p hsv2rgb-int 50 100 150)
|
|
(p hsv2rgb-int 111 222 33)
|
|
(p hsv2rgb-int 200 150 50)
|