diff options
Diffstat (limited to 'chickadee/graphics/color.scm')
-rw-r--r-- | chickadee/graphics/color.scm | 220 |
1 files changed, 220 insertions, 0 deletions
diff --git a/chickadee/graphics/color.scm b/chickadee/graphics/color.scm new file mode 100644 index 0000000..1a0be6d --- /dev/null +++ b/chickadee/graphics/color.scm @@ -0,0 +1,220 @@ +;;; Chickadee Game Toolkit +;;; Copyright © 2016, 2018 David Thompson <davet@gnu.org> +;;; +;;; Chickadee is free software: you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published +;;; by the Free Software Foundation, either version 3 of the License, +;;; or (at your option) any later version. +;;; +;;; Chickadee is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program. If not, see +;;; <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Colors! +;; +;;; Code: + +(define-module (chickadee graphics color) + #:use-module (ice-9 match) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-1) + #:use-module (chickadee math) + #:export (color make-color + color? + color-r color-g color-b color-a + rgba rgb transparency string->color + color* color+ color- color-inverse color-lerp + + white black red green blue yellow magenta cyan transparent + 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)) + +(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-inlinable (make-color r g b a) + (wrap-color + (f32vector + (clamp 0.0 1.0 r) + (clamp 0.0 1.0 g) + (clamp 0.0 1.0 b) + (clamp 0.0 1.0 a)))) + +(define-inlinable (color r g b a) + (make-color r g b a)) + +(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-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-lerp start end alpha) + (color+ (color* start (- 1.0 alpha)) + (color* end alpha))) + +;;; +;;; Pre-defined Colors +;;; + +;; Basic +(define white (rgb #xffffff)) +(define black (rgb #x000000)) +(define red (rgb #xff0000)) +(define green (rgb #x00ff00)) +(define blue (rgb #x0000ff)) +(define yellow (rgb #xffff00)) +(define magenta (rgb #xff00ff)) +(define cyan (rgb #x00ffff)) +(define transparent (make-color 0 0 0 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)) |