;;
;; chicken-web-colors:
;; Parse and write HTML/CSS color strings in CHICKEN Scheme.
;;
;; Copyright © 2019  John Croisant.
;; All rights reserved.
;;
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions
;; are met:
;;
;; - Redistributions of source code must retain the above copyright
;;   notice, this list of conditions and the following disclaimer.
;;
;; - Redistributions in binary form must reproduce the above copyright
;;   notice, this list of conditions and the following disclaimer in
;;   the documentation and/or other materials provided with the
;;   distribution.
;;
;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
;; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
;; COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
;; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
;; OF THE POSSIBILITY OF SUCH DAMAGE.


(export parse-web-color
        parse-hex-color
        parse-named-color
        parse-rgb-color
        parse-hsl-color)


(define-type regexp-match (struct regexp-match))


(: parse-web-color (string --> color-list))
(define (parse-web-color str)
  (cond
   ((irregex-match +hex-color-regex+ str)
    (%parse-hex-color str))
   ((irregex-match +named-color-regex+ str)
    (parse-named-color str))
   ((or (irregex-match +rgb-color-regex+ str)
        (irregex-match +rgb-slash-color-regex+ str))
    => %handle-rgb-match)
   ((or (irregex-match +hsl-color-regex+ str)
        (irregex-match +hsl-slash-color-regex+ str))
    => %handle-hsl-match)
   (else
    (error "Invalid web color" str))))


(: parse-hex-color (string --> color-list))
(define (parse-hex-color str)
  (assert (irregex-match +hex-color-regex+ str)
          "Invalid hex color" str)
  (%parse-hex-color str))

(: %parse-hex-color (string --> color-list))
(define (%parse-hex-color str)
  (case (string-length str)
    ;; #RGB or #RGBA
    ((4 5)
     (list
      'rgb
      (string->number (make-string 2 (string-ref str 1)) 16)
      (string->number (make-string 2 (string-ref str 2)) 16)
      (string->number (make-string 2 (string-ref str 3)) 16)
      (if (= 5 (string-length str))
          (/ (string->number (make-string 2 (string-ref str 4)) 16)
             255)
          1)))
    ;; #RRGGBB or #RRGGBBAA
    ((7 9)
     (list
      'rgb
      (string->number (substring str 1 3) 16)
      (string->number (substring str 3 5) 16)
      (string->number (substring str 5 7) 16)
      (if (= 9 (string-length str))
          (/ (string->number (substring str 7 9) 16)
             255)
          1)))
    (else
     (error "Invalid hex color" str))))

(define +hex-color-regex+
  (sre->irregex
   `(: bos
       "#"
       (or (= 3 hex-digit) (= 4 hex-digit)
           (= 6 hex-digit) (= 8 hex-digit))
       eos)))


(: parse-named-color (string --> color-list))
(define (parse-named-color str)
  (cdr (or (assq (string->symbol (string-downcase str))
                 (*web-color-names*))
           (error "Unknown named color" str))))

(define +named-color-regex+
  (sre->irregex
   `(: bos (+ (or alphanumeric "-")) eos)
   'i))


(: parse-rgb-color (string --> color-list))
(define (parse-rgb-color str)
  (cond ((or (irregex-match +rgb-color-regex+ str)
             (irregex-match +rgb-slash-color-regex+ str))
         => %handle-rgb-match)
        (else (error "Invalid rgb color" str))))

(define +separator-pattern+
  '(or (: (* whitespace) "," (* whitespace))
       (+ whitespace)))

(define +number-pattern+
  '(or real
       (: "." (+ digit) (? (or "e" "E") integer))))

(define +rgb-color-regex+
  (sre->irregex
   `(: bos
       "rgb" (? "a") "("
       (* whitespace)
       (=> r ,+number-pattern+)
       (=> rgb% (? "%"))
       ,+separator-pattern+
       (=> g ,+number-pattern+)
       (backref rgb%)
       ,+separator-pattern+
       (=> b ,+number-pattern+)
       (backref rgb%)
       (? ,+separator-pattern+
          (=> a ,+number-pattern+)
          (=> a% (? "%")))
       (* whitespace)
       ")"
       eos)
   'i))

;; Special case for "rgb[a](R G B / A)" syntax. The slash is only
;; allowed if the RGB are separated by spaces (not commas).
(define +rgb-slash-color-regex+
  (sre->irregex
   `(: bos
       "rgb" (? "a") "("
       (* whitespace)
       (=> r ,+number-pattern+)
       (=> rgb% (? "%"))
       (+ whitespace)
       (=> g ,+number-pattern+)
       (backref rgb%)
       (+ whitespace)
       (=> b ,+number-pattern+)
       (backref rgb%)
       (? (: (* whitespace) "/" (* whitespace))
          (=> a ,+number-pattern+)
          (=> a% (? "%")))
       (* whitespace)
       ")"
       eos)
   'i))

(: %handle-rgb-match (regexp-match --> color-list))
(define (%handle-rgb-match match)
  (let ((r (irregex-match-substring match 'r))
        (rgb% (irregex-match-substring match 'rgb%))
        (g (irregex-match-substring match 'g))
        (b (irregex-match-substring match 'b))
        (a (irregex-match-substring match 'a))
        (a% (irregex-match-substring match 'a%)))
    (list (if (string= rgb% "%") 'rgb% 'rgb)
          (%percent r rgb%)
          (%percent g rgb%)
          (%percent b rgb%)
          (if a (%percent a a%) 1))))

(: %percent (string string --> number))
(define (%percent n %)
  (if (string= % "%")
      (/ (string->number n 10) 100)
      (string->number n 10)))


(: parse-hsl-color (string --> color-list))
(define (parse-hsl-color str)
  (cond ((or (irregex-match +hsl-color-regex+ str)
             (irregex-match +hsl-slash-color-regex+ str))
         => %handle-hsl-match)
        (else (error "Invalid hsl color" str))))

(define +hsl-color-regex+
  (sre->irregex
   `(: bos
       "hsl" (? "a") "("
       (* whitespace)
       (=> h ,+number-pattern+)
       (=> hunit (? (or "deg" "rad" "grad" "turn")))
       ,+separator-pattern+
       (=> s ,+number-pattern+)
       "%"
       ,+separator-pattern+
       (=> l ,+number-pattern+)
       "%"
       (? ,+separator-pattern+
          (=> a ,+number-pattern+)
          (=> a% (? "%")))
       (* whitespace)
       ")"
       eos)
   'i))

;; Special case for "hsl[a](H S L / A)" syntax. The slash is only
;; allowed if the HSL are separated by spaces (not commas).
(define +hsl-slash-color-regex+
  (sre->irregex
   `(: bos
       "hsl" (? "a") "("
       (* whitespace)
       (=> h ,+number-pattern+)
       (=> hunit (? (or "deg" "rad" "grad" "turn")))
       (+ whitespace)
       (=> s ,+number-pattern+)
       "%"
       (+ whitespace)
       (=> l ,+number-pattern+)
       "%"
       (? (: (* whitespace) "/" (* whitespace))
          (=> a ,+number-pattern+)
          (=> a% (? "%")))
       (* whitespace)
       ")"
       eos)
   'i))

(: %handle-hsl-match (regexp-match --> color-list))
(define (%handle-hsl-match match)
  (let ((h (irregex-match-substring match 'h))
        (hunit (irregex-match-substring match 'hunit))
        (s (irregex-match-substring match 's))
        (l (irregex-match-substring match 'l))
        (a (irregex-match-substring match 'a))
        (a% (irregex-match-substring match 'a%)))
    (list 'hsl
          (%hue h hunit)
          (%percent s "%")
          (%percent l "%")
          (if a (%percent a a%) 1))))

(: hue (string string --> number))
(define (%hue n unit)
  (let ((n (string->number n 10)))
    (case (string->symbol unit)
      ((deg ||) n)
      ((rad) (* n 57.29577951308232))
      ((turn) (* n 360))
      ((grad) (cond-expand
               (chicken-4
                (let ((h (* n 360/400)))
                  (if (and (exact? n) (integer? h))
                      (inexact->exact h)
                      h)))
               (else
                (* n 360/400)))))))