path: root/chickadee/graphics/color.scm

;;; Chickadee Game Toolkit
;;; Copyright © 2016, 2018, 2021 David Thompson <dthompson2@worcester.edu>
;;;
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;;    http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.

;;; Commentary:
;;
;; Colors!
;;
;;; Code:

(define-module (chickadee graphics color)
  #:use-module (chickadee graphics engine)
  #:use-module (chickadee graphics gl)
  #:use-module (chickadee math)
  #:use-module (ice-9 format)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-9 gnu)
  #:use-module (srfi srfi-1)
  #:export (make-color
            make-color8
            color?
            color-r
            color-g
            color-b
            color-a
            rgba
            rgb
            transparency
            string->color
            color->string
            color*
            color+
            color-
            color/
            color-inverse
            color-tone-map
            color-lerp

            white
            black
            red
            green
            blue
            yellow
            magenta
            cyan

            tango-light-butter
            tango-butter
            tango-dark-butter
            tango-light-orange
            tango-orange
            tango-dark-orange
            tango-light-chocolate
            tango-chocolate
            tango-dark-chocolate
            tango-light-chameleon
            tango-chameleon
            tango-dark-chameleon
            tango-light-sky-blue
            tango-sky-blue
            tango-dark-sky-blue
            tango-light-plum
            tango-plum
            tango-dark-plum
            tango-light-scarlet-red
            tango-scarlet-red
            tango-dark-scarlet-red
            tango-aluminium-1
            tango-aluminium-2
            tango-aluminium-3
            tango-aluminium-4
            tango-aluminium-5
            tango-aluminium-6

            db32-black
            db32-valhalla
            db32-loulou
            db32-oiled-cedar
            db32-rope
            db32-tahiti-gold
            db32-twine
            db32-pancho
            db32-golden-fizz
            db32-atlantis
            db32-christi
            db32-elf-green
            db32-dell
            db32-verdigris
            db32-opal
            db32-deep-koamaru
            db32-venice-blue
            db32-royal-blue
            db32-cornflower
            db32-viking
            db32-light-steel-blue
            db32-white
            db32-heather
            db32-topaz
            db32-dim-gray
            db32-smokey-ash
            db32-clairvoyant
            db32-brown
            db32-mandy
            db32-plum
            db32-rain-forest
            db32-stinger

            default-color-mask
            null-color-mask
            g:color-mask
            current-color-mask
            color-mask?
            color-mask-red?
            color-mask-green?
            color-mask-blue?
            color-mask-alpha?))

(define-record-type <color>
  (wrap-color bv)
  color?
  (bv unwrap-color))

(define-inlinable (color-r color)
  (f32vector-ref (unwrap-color color) 0))

(define-inlinable (color-g color)
  (f32vector-ref (unwrap-color color) 1))

(define-inlinable (color-b color)
  (f32vector-ref (unwrap-color color) 2))

(define-inlinable (color-a color)
  (f32vector-ref (unwrap-color color) 3))

(define (display-color c port)
  (format port "#<color r: ~1,3f, g: ~1,3f, b: ~1,3f, a: ~1,3f>"
          (color-r c) (color-g c) (color-b c) (color-a c)))

(set-record-type-printer! <color> display-color)

(define* (make-color r g b #:optional (a 1.0))
  (wrap-color (f32vector r g b a)))

(define* (make-color8 r g b #:optional (a 255))
  (make-color (/ r 255.0) (/ g 255.0) (/ b 255.0) (/ a 255.0)))

(define (color-component color-code offset)
  "Return the value of an 8-bit color channel in the range [0,1] for
the integer COLOR-CODE, given an OFFSET in bits."
  (let ((mask (ash #xff offset)))
    (/ (ash (logand mask color-code)
            (- offset))
       255.0)))

(define (rgba color-code)
  "Translate an RGBA format string COLOR-CODE into a color object.
For example: #xffffffff will return a color with RGBA values 1, 1, 1,
1."
  (make-color (color-component color-code 24)
              (color-component color-code 16)
              (color-component color-code 8)
              (color-component color-code 0)))

(define (rgb color-code)
  "Translate an RGB format string COLOR-CODE into a color object.
For example: #xffffff will return a color with RGBA values 1, 1, 1,
1."
  (make-color (color-component color-code 16)
              (color-component color-code 8)
              (color-component color-code 0)
              1.0))

(define (transparency alpha)
  "Create a new color that is white with a transparency value of
ALPHA.  ALPHA is clamped to the range [0, 1]."
  (make-color 1 1 1 alpha))

(define (string->color s)
  "Convert the color code string S, in a format like \"#RRGGBBAA\", to
a color object."
  (define (parse-digit i)
    (match (string-ref s i)
      (#\0 0)
      (#\1 1)
      (#\2 2)
      (#\3 3)
      (#\4 4)
      (#\5 5)
      (#\6 6)
      (#\7 7)
      (#\8 8)
      (#\9 9)
      ((or #\a #\A) 10)
      ((or #\b #\B) 11)
      ((or #\c #\C) 12)
      ((or #\d #\D) 13)
      ((or #\e #\E) 14)
      ((or #\f #\F) 15)))
  (define (parse-channel i)
    (/ (+ (* (parse-digit i) 16)
          (parse-digit (+ i 1)))
       255.0))
  ;; Support color codes with or without a "#" prefix and with or
  ;; without an alpha channel.
  (let* ((start (if (string-prefix? "#" s) 1 0))
         (alpha? (> (string-length s) (+ start 6)))
         (red (parse-channel start))
         (green (parse-channel (+ start 2)))
         (blue (parse-channel (+ start 4)))
         (alpha (if alpha?
                    (parse-channel (+ start 6))
                    1.0)))
    (make-color red green blue alpha)))

(define (color->string color)
  (define (8bit-channel channel)
    (inexact->exact (round (* (clamp 0.0 1.0 channel) 255.0))))
  (let ((r (8bit-channel (color-r color)))
        (g (8bit-channel (color-g color)))
        (b (8bit-channel (color-b color)))
        (a (8bit-channel (color-a color))))
    (with-output-to-string
      (lambda ()
        (display "#")
        (display (number->string r 16))
        (display (number->string g 16))
        (display (number->string b 16))
        (display (number->string a 16))))))

(define-inlinable (color* a b)
  (if (color? b)
      (make-color (* (color-r a) (color-r b))
                  (* (color-g a) (color-g b))
                  (* (color-b a) (color-b b))
                  (* (color-a a) (color-a b)))
      ;; Scalar multiplication.
      (make-color (* (color-r a) b)
                  (* (color-g a) b)
                  (* (color-b a) b)
                  (* (color-a a) b))))

(define-inlinable (color/ a b)
  (if (color? b)
      (make-color (/ (color-r a) (color-r b))
                  (/ (color-g a) (color-g b))
                  (/ (color-b a) (color-b b))
                  (/ (color-a a) (color-a b)))
      ;; Scalar multiplication.
      (make-color (/ (color-r a) b)
                  (/ (color-g a) b)
                  (/ (color-b a) b)
                  (/ (color-a a) b))))

(define-inlinable (color+ a b)
  (make-color (+ (color-r a) (color-r b))
              (+ (color-g a) (color-g b))
              (+ (color-b a) (color-b b))
              (+ (color-a a) (color-a b))))

(define-inlinable (color- a b)
  (make-color (- (color-r a) (color-r b))
              (- (color-g a) (color-g b))
              (- (color-b a) (color-b b))
              (- (color-a a) (color-a b))))

(define-inlinable (color-inverse color)
  (make-color (- 1.0 (color-r color))
              (- 1.0 (color-g color))
              (- 1.0 (color-b color))
              ;; Do not alter alpha channel.
              (color-a color)))

(define-inlinable (color-tone-map color)
  (color/ color (color+ color (make-color 1.0 1.0 1.0 0.0))))

(define-inlinable (color-lerp start end alpha)
  (color+ (color* start (- 1.0 alpha))
          (color* end alpha)))


;;;
;;; Pre-defined Colors
;;;

;; Basic
(define white (make-color 1.0 1.0 1.0))
(define black (make-color 0.0 0.0 0.0))
(define red (make-color 1.0 0.0 0.0))
(define green (make-color 0.0 1.0 0.0))
(define blue (make-color 0.0 0.0 1.0))
(define yellow (make-color 1.0 1.0 0.0))
(define magenta (make-color 1.0 0.0 1.0))
(define cyan (make-color 0.0 1.0 1.0))

;; Tango color pallete
;; http://tango.freedesktop.org
(define tango-light-butter (rgb #xfce94f))
(define tango-butter (rgb #xedd400))
(define tango-dark-butter (rgb #xc4a000))
(define tango-light-orange (rgb #xfcaf3e))
(define tango-orange (rgb #xf57900))
(define tango-dark-orange (rgb #xce5c00))
(define tango-light-chocolate (rgb #xe9b96e))
(define tango-chocolate (rgb #xc17d11))
(define tango-dark-chocolate (rgb #x8f5902))
(define tango-light-chameleon (rgb #x8ae234))
(define tango-chameleon (rgb #x73d216))
(define tango-dark-chameleon (rgb #x4e9a06))
(define tango-light-sky-blue (rgb #x729fcf))
(define tango-sky-blue (rgb #x3465a4))
(define tango-dark-sky-blue (rgb #x204a87))
(define tango-light-plum (rgb #xad7fa8))
(define tango-plum (rgb #x75507b))
(define tango-dark-plum (rgb #x5c3566))
(define tango-light-scarlet-red (rgb #xef2929))
(define tango-scarlet-red (rgb #xcc0000))
(define tango-dark-scarlet-red (rgb #xa40000))
(define tango-aluminium-1 (rgb #xeeeeec))
(define tango-aluminium-2 (rgb #xd3d7cf))
(define tango-aluminium-3 (rgb #xbabdb6))
(define tango-aluminium-4 (rgb #x888a85))
(define tango-aluminium-5 (rgb #x555753))
(define tango-aluminium-6 (rgb #x2e3436))

;; DawnBringer 32 color palette
;; http://pixeljoint.com/forum/forum_posts.asp?TID=16247
;; Color names taken from: http://privat.bahnhof.se/wb364826/pic/db32.gpl
(define db32-black (make-color8 0 0 0))
(define db32-valhalla (make-color8 34 32 52))
(define db32-loulou (make-color8 69 40 60))
(define db32-oiled-cedar (make-color8 102 57 49))
(define db32-rope (make-color8 143 86 59))
(define db32-tahiti-gold (make-color8 223 113 38))
(define db32-twine (make-color8 217 160 102))
(define db32-pancho (make-color8 238 195 154))
(define db32-golden-fizz (make-color8 251 242 54))
(define db32-atlantis (make-color8 153 229 80))
(define db32-christi (make-color8 106 190 48))
(define db32-elf-green (make-color8 55 148 110))
(define db32-dell (make-color8 75 105 47))
(define db32-verdigris (make-color8 82 75 36))
(define db32-opal (make-color8 50 60 57))
(define db32-deep-koamaru (make-color8 63 63 116))
(define db32-venice-blue (make-color8 48 96 130))
(define db32-royal-blue (make-color8 91 110 225))
(define db32-cornflower (make-color8 99 155 255))
(define db32-viking (make-color8 95 205 228))
(define db32-light-steel-blue (make-color8 203 219 252))
(define db32-white (make-color8 255 255 255))
(define db32-heather (make-color8 155 173 183))
(define db32-topaz (make-color8 132 126 135))
(define db32-dim-gray (make-color8 105 106 106))
(define db32-smokey-ash (make-color8 89 86 82))
(define db32-clairvoyant (make-color8 118 66 138))
(define db32-brown (make-color8 172 50 50))
(define db32-mandy (make-color8 217 87 99))
(define db32-plum (make-color8 215 123 186))
(define db32-rain-forest (make-color8 143 151 74))
(define db32-stinger (make-color8 138 111 48))


;;;
;;; Color Masks
;;;

(define-record-type <color-mask>
  (make-color-mask red? green? blue? alpha?)
  color-mask?
  (red? color-mask-red?)
  (green? color-mask-green?)
  (blue? color-mask-blue?)
  (alpha? color-mask-alpha?))

(define default-color-mask (make-color-mask #t #t #t #t))
(define null-color-mask (make-color-mask #f #f #f #f))

(define (bind-color-mask mask)
  (gl-color-mask (color-mask-red? mask)
                 (color-mask-green? mask)
                 (color-mask-blue? mask)
                 (color-mask-alpha? mask)))

(define-graphics-state g:color-mask
  current-color-mask
  #:default default-color-mask
  #:bind bind-color-mask)