render: color: Use f32vector under the hood.
[chickadee.git] / chickadee / render / color.scm
1 ;;; Chickadee Game Toolkit
2 ;;; Copyright © 2016, 2018 David Thompson <davet@gnu.org>
3 ;;;
4 ;;; Chickadee is free software: you can redistribute it and/or modify
5 ;;; it under the terms of the GNU General Public License as published
6 ;;; by the Free Software Foundation, either version 3 of the License,
7 ;;; or (at your option) any later version.
8 ;;;
9 ;;; Chickadee is distributed in the hope that it will be useful, but
10 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
11 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 ;;; General Public License for more details.
13 ;;;
14 ;;; You should have received a copy of the GNU General Public License
15 ;;; along with this program. If not, see
16 ;;; <http://www.gnu.org/licenses/>.
17
18 ;;; Commentary:
19 ;;
20 ;; Colors!
21 ;;
22 ;;; Code:
23
24 (define-module (chickadee render color)
25 #:use-module (ice-9 match)
26 #:use-module (srfi srfi-9)
27 #:use-module (srfi srfi-1)
28 #:use-module (chickadee math)
29 #:export (color make-color
30 color?
31 color-r color-g color-b color-a
32 rgba rgb transparency
33 color* color+ color- color-inverse color-lerp
34
35 white black red green blue yellow magenta cyan transparent
36 tango-light-butter tango-butter tango-dark-butter
37 tango-light-orange tango-orange tango-dark-orange
38 tango-light-chocolate tango-chocolate tango-dark-chocolate
39 tango-light-chameleon tango-chameleon tango-dark-chameleon
40 tango-light-sky-blue tango-sky-blue tango-dark-sky-blue
41 tango-light-plum tango-plum tango-dark-plum
42 tango-light-scarlet-red tango-scarlet-red tango-dark-scarlet-red
43 tango-aluminium-1 tango-aluminium-2 tango-aluminium-3
44 tango-aluminium-4 tango-aluminium-5 tango-aluminium-6))
45
46 (define-record-type <color>
47 (wrap-color bv)
48 color?
49 (bv unwrap-color))
50
51 (define-inlinable (color-r color)
52 (f32vector-ref (unwrap-color color) 0))
53
54 (define-inlinable (color-g color)
55 (f32vector-ref (unwrap-color color) 1))
56
57 (define-inlinable (color-b color)
58 (f32vector-ref (unwrap-color color) 2))
59
60 (define-inlinable (color-a color)
61 (f32vector-ref (unwrap-color color) 3))
62
63 (define-inlinable (make-color r g b a)
64 (wrap-color
65 (f32vector
66 (clamp 0.0 1.0 r)
67 (clamp 0.0 1.0 g)
68 (clamp 0.0 1.0 b)
69 (clamp 0.0 1.0 a))))
70
71 (define-inlinable (color r g b a)
72 (make-color r g b a))
73
74 (define (color-component color-code offset)
75 "Return the value of an 8-bit color channel in the range [0,1] for
76 the integer COLOR-CODE, given an OFFSET in bits."
77 (let ((mask (ash #xff offset)))
78 (/ (ash (logand mask color-code)
79 (- offset))
80 255.0)))
81
82 (define (rgba color-code)
83 "Translate an RGBA format string COLOR-CODE into a color object.
84 For example: #xffffffff will return a color with RGBA values 1, 1, 1,
85 1."
86 (make-color (color-component color-code 24)
87 (color-component color-code 16)
88 (color-component color-code 8)
89 (color-component color-code 0)))
90
91 (define (rgb color-code)
92 "Translate an RGB format string COLOR-CODE into a color object.
93 For example: #xffffff will return a color with RGBA values 1, 1, 1,
94 1."
95 (make-color (color-component color-code 16)
96 (color-component color-code 8)
97 (color-component color-code 0)
98 1.0))
99
100 (define (transparency alpha)
101 "Create a new color that is white with a transparency value of
102 ALPHA. ALPHA is clamped to the range [0, 1]."
103 (make-color 1 1 1 alpha))
104
105 ;; TODO: Optimize and inline
106 (define color*
107 (match-lambda*
108 ((($ <color> r1 g1 b1 a1) ($ <color> r2 g2 b2 a2))
109 (make-color (* r1 r2)
110 (* g1 g2)
111 (* b1 b2)
112 (* a1 a2)))
113 ((($ <color> r g b a) (? number? k))
114 (make-color (* r k)
115 (* g k)
116 (* b k)
117 (* a k)))))
118
119 (define color+
120 (match-lambda*
121 ((($ <color> r1 g1 b1 a1) ($ <color> r2 g2 b2 a2))
122 (make-color (+ r1 r2)
123 (+ g1 g2)
124 (+ b1 b2)
125 (+ a1 a2)))))
126
127 (define color-
128 (match-lambda*
129 ((($ <color> r1 g1 b1 a1) ($ <color> r2 g2 b2 a2))
130 (make-color (- r1 r2)
131 (- g1 g2)
132 (- b1 b2)
133 (- a1 a2)))))
134
135 (define color-inverse
136 (match-lambda
137 (($ <color> r g b a)
138 (make-color (- 1 r)
139 (- 1 g)
140 (- 1 b)
141 a)))) ; Do not alter alpha channel.
142
143 (define-inlinable (color-lerp start end alpha)
144 (color+ (color* start (- 1.0 alpha))
145 (color* end alpha)))
146
147 ;;;
148 ;;; Pre-defined Colors
149 ;;;
150
151 ;; Basic
152 (define white (rgb #xffffff))
153 (define black (rgb #x000000))
154 (define red (rgb #xff0000))
155 (define green (rgb #x00ff00))
156 (define blue (rgb #x0000ff))
157 (define yellow (rgb #xffff00))
158 (define magenta (rgb #xff00ff))
159 (define cyan (rgb #x00ffff))
160 (define transparent (make-color 0 0 0 0))
161
162 ;; Tango color pallete
163 ;; http://tango.freedesktop.org
164 (define tango-light-butter (rgb #xfce94f))
165 (define tango-butter (rgb #xedd400))
166 (define tango-dark-butter (rgb #xc4a000))
167 (define tango-light-orange (rgb #xfcaf3e))
168 (define tango-orange (rgb #xf57900))
169 (define tango-dark-orange (rgb #xce5c00))
170 (define tango-light-chocolate (rgb #xe9b96e))
171 (define tango-chocolate (rgb #xc17d11))
172 (define tango-dark-chocolate (rgb #x8f5902))
173 (define tango-light-chameleon (rgb #x8ae234))
174 (define tango-chameleon (rgb #x73d216))
175 (define tango-dark-chameleon (rgb #x4e9a06))
176 (define tango-light-sky-blue (rgb #x729fcf))
177 (define tango-sky-blue (rgb #x3465a4))
178 (define tango-dark-sky-blue (rgb #x204a87))
179 (define tango-light-plum (rgb #xad7fa8))
180 (define tango-plum (rgb #x75507b))
181 (define tango-dark-plum (rgb #x5c3566))
182 (define tango-light-scarlet-red (rgb #xef2929))
183 (define tango-scarlet-red (rgb #xcc0000))
184 (define tango-dark-scarlet-red (rgb #xa40000))
185 (define tango-aluminium-1 (rgb #xeeeeec))
186 (define tango-aluminium-2 (rgb #xd3d7cf))
187 (define tango-aluminium-3 (rgb #xbabdb6))
188 (define tango-aluminium-4 (rgb #x888a85))
189 (define tango-aluminium-5 (rgb #x555753))
190 (define tango-aluminium-6 (rgb #x2e3436))