;;
;; 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 web-color->string      write-web-color
        rgb-color->hex-string  write-hex-color
        rgb-color->string      write-rgb-color
        hsl-color->string      write-hsl-color)


(: web-color->string (color-list --> string))
(define (web-color->string color)
  (call-with-output-string
   (lambda (port)
     (write-web-color color port))))

(: write-web-color (color-list #!optional port -> undefined))
(define (write-web-color color #!optional (port (current-output-port)))
  (assert (color-list? color)
          "Invalid color list" color)
  (case (car color)
    ((rgb)
     (if (= 1 (list-ref color 4))
         (write-hex-color color port)
         (write-rgb-color color port)))
    ((rgb%)
     (write-rgb-color color port))
    ((hsl)
     (write-hsl-color color port))))


(: rgb-color->hex-string (color-list --> string))
(define (rgb-color->hex-string color)
  (call-with-output-string
   (lambda (port)
     (write-hex-color color port))))

(: write-hex-color (color-list #!optional port -> undefined))
(define (write-hex-color color #!optional (port (current-output-port)))
  (let ((bytes (rgb-color->bytes color)))
    (display "#" port)
    (%write-hex-byte port (list-ref bytes 0))
    (%write-hex-byte port (list-ref bytes 1))
    (%write-hex-byte port (list-ref bytes 2))
    (if (not (= 255 (list-ref bytes 3)))
        (%write-hex-byte port (list-ref bytes 3)))))

(: %write-hex-byte (output-port fixnum -> undefined))
(define (%write-hex-byte port n)
  (if (< n 16)
      (display "0" port))
  (display (number->string n 16) port))


(: rgb-color->string (color-list --> string))
(define (rgb-color->string color)
  (call-with-output-string
   (lambda (port)
     (write-rgb-color color port))))

(: write-rgb-color (color-list #!optional port -> undefined))
(define (write-rgb-color color #!optional (port (current-output-port)))
  (assert (color-list? color '(rgb rgb%))
          "Invalid rgb color list" color)
  (let ((% (if (eq? 'rgb% (car color)) "%" ""))
        (scale (if (eq? 'rgb% (car color)) 100 1)))
    (let ((r (%pretty-number (* scale (list-ref color 1))))
          (g (%pretty-number (* scale (list-ref color 2))))
          (b (%pretty-number (* scale (list-ref color 3))))
          (a (list-ref color 4)))
      (if (= 1 a)
          (fprintf port "rgb(~A~A, ~A~A, ~A~A)"
                   r % g % b %)
          (fprintf port "rgba(~A~A, ~A~A, ~A~A, ~A)"
                   r % g % b % (%pretty-number a))))))

(: %pretty-number (number --> number))
(define (%pretty-number n)
  (if (integer? n)
      (inexact->exact n)
      (exact->inexact n)))


(: hsl-color->string (color-list --> string))
(define (hsl-color->string color)
  (call-with-output-string
   (lambda (port)
     (write-hsl-color color port))))

(: write-hsl-color (color-list #!optional port -> undefined))
(define (write-hsl-color color #!optional (port (current-output-port)))
  (assert (and (color-list? color '(hsl)))
          "Invalid hsl color list" color)
  (let ((h (%pretty-number (list-ref color 1)))
        (s (%pretty-number (* 100 (list-ref color 2))))
        (l (%pretty-number (* 100 (list-ref color 3))))
        (a (list-ref color 4)))
    (if (= 1 a)
        (fprintf port "hsl(~A, ~A%, ~A%)"
                 h s l)
        (fprintf port "hsla(~A, ~A%, ~A%, ~A)"
                 h s l (%pretty-number a)))))