basket/basket/color.scm

(define-module (basket color)
               #:use-module (basket)
               #:use-module (srfi srfi-1))

(export
  hsl->rgb
  hsv->rgb)

(define (preserve-alpha fn color)
  (if (<= (length color) 3)
      (fn color)
      (append (fn (take color 3)) (drop color 3))))

(define (hsl->rgb' hsl)
  (let* ((h (car hsl))
         (s (cadr hsl))
         (l (caddr hsl))
         (c (* s (- 1 (abs (- (* 2 l) 1)))))
         (hh (* 6 h))
         (x (* c (- 1 (abs (- (floor-remainder hh 2) 1))))))
    (map (curry + (- l (/ c 2)))
         (cond
           ((< hh 1) (list c x 0))
           ((< hh 2) (list x c 0))
           ((< hh 3) (list 0 c x))
           ((< hh 4) (list 0 x c))
           ((< hh 5) (list x 0 c))
           ((<= hh 6) (list c 0 x))
           (else (list 0 0 0))))))

(define (hsl->rgb hsl)
  "Converts a color from HSL(A) to RGB(A)."
  (preserve-alpha hsl->rgb' hsl))

(define (hsv->rgb' hsv)
  (let* ((h (car hsv))
         (s (cadr hsv))
         (v (caddr hsv))
         (c (* v s))
         (hh (* 6 h))
         (x (* c (- 1 (abs (- (floor-remainder hh 2) 1))))))
    (map (curry + (- v c))
         (cond
           ((< hh 1) (list c x 0))
           ((< hh 2) (list x c 0))
           ((< hh 3) (list 0 c x))
           ((< hh 4) (list 0 x c))
           ((< hh 5) (list x 0 c))
           ((<= hh 6) (list c 0 x))
           (else (list 0 0 0))))))

(define (hsv->rgb hsv)
  "Converts a color from HSV(A) to RGB(A)."
  (preserve-alpha hsv->rgb' hsv))