47ad769b47f0fa78eedb1e6041177e9b545c1679
[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 (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 (%make-color r g b a)
48 color?
49 (r color-r)
50 (g color-g)
51 (b color-b)
52 (a color-a))
53
54 (define (make-color r g b a)
55 "Return a newly allocated color with the given RGBA channel values.
56 Each channel is clamped to the range [0, 1]."
57 (%make-color (clamp 0 1 r)
58 (clamp 0 1 g)
59 (clamp 0 1 b)
60 (clamp 0 1 a)))
61
62 (define (color-component color-code offset)
63 "Return the value of an 8-bit color channel in the range [0,1] for
64 the integer COLOR-CODE, given an OFFSET in bits."
65 (let ((mask (ash #xff offset)))
66 (/ (ash (logand mask color-code)
67 (- offset))
68 255.0)))
69
70 (define (rgba color-code)
71 "Translate an RGBA format string COLOR-CODE into a color object.
72 For example: #xffffffff will return a color with RGBA values 1, 1, 1,
73 1."
74 (%make-color (color-component color-code 24)
75 (color-component color-code 16)
76 (color-component color-code 8)
77 (color-component color-code 0)))
78
79 (define (rgb color-code)
80 "Translate an RGB format string COLOR-CODE into a color object.
81 For example: #xffffff will return a color with RGBA values 1, 1, 1,
82 1."
83 (%make-color (color-component color-code 16)
84 (color-component color-code 8)
85 (color-component color-code 0)
86 1.0))
87
88 (define (transparency alpha)
89 "Create a new color that is white with a transparency value of
90 ALPHA. ALPHA is clamped to the range [0, 1]."
91 (make-color 1 1 1 alpha))
92
93 ;; (define-method (* (a <<color>>) (b <<color>>))
94 ;; (make-color (* (color-r a) (color-r b))
95 ;; (* (color-g a) (color-g b))
96 ;; (* (color-b a) (color-b b))
97 ;; (* (color-a a) (color-a b))))
98
99 ;; TODO: Optimize and inline
100 (define color*
101 (match-lambda*
102 ((($ <color> r1 g1 b1 a1) ($ <color> r2 g2 b2 a2))
103 (make-color (* r1 r2)
104 (* g1 g2)
105 (* b1 b2)
106 (* a1 a2)))
107 ((($ <color> r g b a) (? number? k))
108 (make-color (* r k)
109 (* g k)
110 (* b k)
111 (* a k)))))
112
113 (define color+
114 (match-lambda*
115 ((($ <color> r1 g1 b1 a1) ($ <color> r2 g2 b2 a2))
116 (make-color (+ r1 r2)
117 (+ g1 g2)
118 (+ b1 b2)
119 (+ a1 a2)))))
120
121 (define color-
122 (match-lambda*
123 ((($ <color> r1 g1 b1 a1) ($ <color> r2 g2 b2 a2))
124 (make-color (- r1 r2)
125 (- g1 g2)
126 (- b1 b2)
127 (- a1 a2)))))
128
129 (define color-inverse
130 (match-lambda
131 (($ <color> r g b a)
132 (make-color (- 1 r)
133 (- 1 g)
134 (- 1 b)
135 a)))) ; Do not alter alpha channel.
136
137 (define-inlinable (color-lerp start end alpha)
138 (color+ (color* start (- 1.0 alpha))
139 (color* end alpha)))
140
141 ;;;
142 ;;; Pre-defined Colors
143 ;;;
144
145 ;; Basic
146 (define white (rgb #xffffff))
147 (define black (rgb #x000000))
148 (define red (rgb #xff0000))
149 (define green (rgb #x00ff00))
150 (define blue (rgb #x0000ff))
151 (define yellow (rgb #xffff00))
152 (define magenta (rgb #xff00ff))
153 (define cyan (rgb #x00ffff))
154 (define transparent (make-color 0 0 0 0))
155
156 ;; Tango color pallete
157 ;; http://tango.freedesktop.org
158 (define tango-light-butter (rgb #xfce94f))
159 (define tango-butter (rgb #xedd400))
160 (define tango-dark-butter (rgb #xc4a000))
161 (define tango-light-orange (rgb #xfcaf3e))
162 (define tango-orange (rgb #xf57900))
163 (define tango-dark-orange (rgb #xce5c00))
164 (define tango-light-chocolate (rgb #xe9b96e))
165 (define tango-chocolate (rgb #xc17d11))
166 (define tango-dark-chocolate (rgb #x8f5902))
167 (define tango-light-chameleon (rgb #x8ae234))
168 (define tango-chameleon (rgb #x73d216))
169 (define tango-dark-chameleon (rgb #x4e9a06))
170 (define tango-light-sky-blue (rgb #x729fcf))
171 (define tango-sky-blue (rgb #x3465a4))
172 (define tango-dark-sky-blue (rgb #x204a87))
173 (define tango-light-plum (rgb #xad7fa8))
174 (define tango-plum (rgb #x75507b))
175 (define tango-dark-plum (rgb #x5c3566))
176 (define tango-light-scarlet-red (rgb #xef2929))
177 (define tango-scarlet-red (rgb #xcc0000))
178 (define tango-dark-scarlet-red (rgb #xa40000))
179 (define tango-aluminium-1 (rgb #xeeeeec))
180 (define tango-aluminium-2 (rgb #xd3d7cf))
181 (define tango-aluminium-3 (rgb #xbabdb6))
182 (define tango-aluminium-4 (rgb #x888a85))
183 (define tango-aluminium-5 (rgb #x555753))
184 (define tango-aluminium-6 (rgb #x2e3436))