Coverage report: /home/ellis/comp/core/lib/obj/color/color.lisp

Kind	Covered	All	%
expression	271	484	56.0
branch	16	38	42.1

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;; lib/obj/color/colors.lisp --- Color Types

2

3

;; from https://github.com/tpapp/cl-colors/blob/master/colors.lisp

4

5

;; this file includes RGB, HSV, and HEX color definitions.

6

7

;;; Code:

8

(in-package :obj/color)

9

10

(deftype unit-real ()

11

"Real number in [0,1]."

12

'(real 0 1))

13

14

(eval-always

15

(defstruct (color (:constructor color (alpha))

16

(:conc-name nil))

17

(alpha 1.0f0 :type unit-real :read-only t)))

18

19

(defmacro define-color-type (name fields &optional (include 'color))

20

(flet ((unit (x) (if (atom x) x (car x)))

21

(slots (x) (mapcar 'slot-definition-name (list-class-slots (find-class x) t))))

22

(let ((%fields (concatenate 'list

23

(slots include)

24

(loop for f in fields collect (unit f)))))

25

`(eval-always

26

(declaim (inline ,name))

27

(defstruct (,name (:constructor ,name (,@(remove 'alpha %fields) &optional alpha))

28

(:include ,include)

29

(:conc-name nil)

30

(:predicate nil)

31

(:copier nil))

32

,@fields)

33

(defmethod make-load-form ((self ,name) &optional env)

34

(declare (ignore env))

35

(,name ,@(loop for f in %fields collect `(,(unit f) self))))))))

36

37

(define-color-type rgb

38

((red 0 :type unit-real :read-only t)

39

(green 0 :type unit-real :read-only t)

40

(blue 0 :type unit-real :read-only t)))

41

42

(define-color-type %hue

43

((hue 0 :type (real 0 360))

44

(saturation 0 :type unit-real :read-only t)))

45

46

(define-color-type hsv

47

((.value nil :type unit-real :read-only t))

48

%hue)

49

50

(define-color-type hsl

51

((lightness nil :type unit-real :read-only t)))

52

53

(define-color-type hsi

54

((intensity nil :type unit-real :read-only t)))

55

56

(define-color-type cmyk (cyan magenta yellow .key))

57

;; CEIXYZ

58

(define-color-type xyz (.x .y .z))

59

;; L*A*B

60

(define-color-type lab (.l .a .b))

61

62

(defun gray (value)

63

"Create an RGB representation of a gray color (value in [0,1)."

64

(rgb value value value))

65

66

(defun normalize-hue (hue)

67

"Normalize hue to the interval [0,360)."

68

(mod hue 360))

69

70

;;; conversions

71

(defun rgb-to-hsv (rgb &optional (undefined-hue 0))

72

"Convert RGB to HSV representation. When hue is undefined (saturation is

73

zero), UNDEFINED-HUE will be assigned."

74

(with-slots (red green blue) rgb

75

(let* ((value (max red green blue))

76

(delta (- value (min red green blue)))

77

(saturation (if (plusp value)

78

(/ delta value)

79

0)))

80

(flet ((normalize (constant right left)

81

(let ((hue (+ constant (/ (* 60 (- right left)) delta))))

82

(if (minusp hue)

83

(+ hue 360)

84

hue))))

85

(hsv (cond

86

((zerop saturation) undefined-hue) ; undefined

87

((= red value) (normalize 0 green blue)) ; dominant red

88

((= green value) (normalize 120 blue red)) ; dominant green

89

(t (normalize 240 red green)))

90

saturation

91

value)))))

92

93

(defun hsv-to-rgb (hsv)

94

"Convert HSV to RGB representation. When SATURATION is zero, HUE is

95

ignored."

96

(with-slots (hue saturation .value) hsv

97

;; if saturation=0, color is on the gray line

98

(when (zerop saturation)

99

(return-from hsv-to-rgb (gray .value)))

100

;; nonzero saturation: normalize hue to [0,6)

101

(let ((h (/ (normalize-hue hue) 60)))

102

(multiple-value-bind (quotient remainder) (floor h)

103

(let ((p (* .value (- 1 saturation)))

104

(q (* .value (- 1 (* saturation remainder))))

105

(r (* .value (- 1 (* saturation (- 1 remainder))))))

106

(case quotient

107

(0 (rgb .value r p))

108

(1 (rgb q .value p))

109

(2 (rgb p .value r))

110

(3 (rgb p q .value))

111

(4 (rgb r p .value))

112

(t (rgb .value p q))))))))

113

114

(defun hex-to-rgb (string)

115

"Parse hexadecimal notation (eg ff0000 or f00 for red) into an RGB color."

116

(destructuring-bind (width max)

117

(case (length string)

118

(3 (list 1 15))

119

(6 (list 2 255))

120

(t (error "string ~A doesn't have length 3 or 6, can't parse as ~

121

RGB specification" string)))

122

(flet ((parse (index)

123

(/ (parse-integer string :start (* index width)

124

:end (* (1+ index) width)

125

:radix 16)

126

max)))

127

(rgb (parse 0) (parse 1) (parse 2)))))

128

129

;;; conversion with generic functions

130

(defgeneric as-hsv (color &optional undefined-hue)

131

(:method ((color rgb) &optional (undefined-hue 0))

132

(rgb-to-hsv color undefined-hue))

133

(:method ((color hsv) &optional undefined-hue)

134

(declare (ignore undefined-hue))

135

color))

136

137

(defgeneric as-rgb (color)

138

(:method ((rgb rgb))

139

rgb)

140

(:method ((hsv hsv))

141

(hsv-to-rgb hsv))

142

(:method ((string string))

143

     ;; TODO in the long run this should recognize color names too (which are keywords in our case)

144

(hex-to-rgb string)))

145

146

;;; internal functions

147

;; (definline convex-combo (a b alpha)

148

;; "Convex combination (1-ALPHA)*A+ALPHA*B, ie ALPHA is the weight of A."

149

;; (declare (type (real 0 1) alpha))

150

;; (+ (* (- 1 alpha) a) (* alpha b)))

151

152

;;; parsing and printing of CSS-like colors

153

(defun print-hex-rgb (color &key short (hash T) alpha destination)

154

"Converts a COLOR to its hexadecimal RGB string representation. If

155

SHORT is specified each component gets just one character.

156

157

A hash character (#) is prepended if HASH is true (default).

158

159

If ALPHA is set it is included as an ALPHA component.

160

161

DESTINATION is the first argument to FORMAT, by default NIL."

162

(let ((rgb (as-rgb color))

163

(factor (if short 15 255)))

164

(flet ((c (x) (round (* x factor))))

165

(format destination (if short

166

"~@[~C~]~X~X~X~@[~X~]"

167

"~@[~C~]~2,'0X~2,'0X~2,'0X~@[~X~]")

168

(and hash #\#)

169

(c (red rgb)) (c (green rgb)) (c (blue rgb))

170

(and alpha (c alpha))))))

171

172

;; TODO: a JUNK-ALLOWED parameter, like for PARSE-INTEGER, would be nice

173

(defun parse-hex-rgb (string &key (start 0) end)

174

"Parses a hexadecimal RGB(A) color string. Returns a new RGB color value

175

and an alpha component if present."

176

(let* ((length (length string))

177

(end (or end length))

178

(sub-length (- end start)))

179

(cond

180

;; check for valid range, we need at least three and accept at most

181

;; nine characters

182

((and (<= #.(length "fff") sub-length)

183

(<= sub-length #.(length "#ffffff00")))

184

(when (char= (char string start) #\#)

185

(incf start)

186

(decf sub-length))

187

(labels ((parse (string index offset)

188

(parse-integer string :start index :end (+ offset index)

189

:radix 16))

190

(short (string index)

191

(/ (parse string index 1) 15))

192

(long (string index)

193

(/ (parse string index 2) 255)))

194

;; recognize possible combinations of alpha component and length

195

;; of the rest of the encoded color

196

(multiple-value-bind (shortp alphap)

197

(case sub-length

198

(#.(length "fff") (values T NIL))

199

(#.(length "fff0") (values T T))

200

(#.(length "ffffff") (values NIL NIL))

201

(#.(length "ffffff00") (values NIL T)))

202

(if shortp

203

(values

204

(rgb

205

(short string start)

206

(short string (+ 1 start))

207

(short string (+ 2 start)))

208

(and alphap (short string (+ 3 start))))

209

(values

210

(rgb

211

(long string start)

212

(long string (+ 2 start))

213

(long string (+ 4 start)))

214

(and alphap (long string (+ 6 start))))))))

215

(t

216

(error "not enough or too many characters in indicated sequence: ~A"

217

(subseq string start end))))))

218

219

(defvar *color-conversions* ())

220

221

(defun conversion-matrix (from to)

222

(loop for (ff tt m) in *color-conversions*

223

do (when (and (eq ff from) (eq tt to))

224

(return m))

225

finally (error "No conversion matrix from ~s to ~s." from to)))

226

227

(defun (setf conversion-matrix) (matrix from to)

228

(loop for entry in *color-conversions*

229

for (ff tt m) = entry

230

do (when (and (eq ff from) (eq tt to))

231

(return (setf (caddr entry) matrix)))

232

finally (push (list from to matrix) *color-conversions*))

233

matrix)

234

235

(defmacro define-conversion ((from to) &body matrix)

236

`(setf (conversion-matrix ',from ',to)

237

(make-array 9 :element-type 'single-float

238

:initial-contents ',matrix)))

239

240

(defun reduce-row (matrix row a b c)

241

(let ((row (* row 3)))

242

(+ (* a (aref matrix (+ row 0)))

243

(* b (aref matrix (+ row 1)))

244

(* c (aref matrix (+ row 2))))))

245

246

(define-conversion (:adobe-rgb xyz)

247

0.5767309 0.1855540 0.1881852

248

0.2973769 0.6273491 0.0752741

249

0.0270343 0.0706872 0.9911085)

250

251

(define-conversion (xyz :adobe-rgb)

252

2.0413690 -0.5649464 -0.3446944

253

-0.9692660 1.8760108 0.0415560

254

0.0134474 -0.1183897 1.0154096)

255

256

(define-conversion (:apple-rgb xyz)

257

0.4497288 0.3162486 0.1844926

258

0.2446525 0.6720283 0.0833192

259

0.0251848 0.1411824 0.9224628)

260

261

(define-conversion (xyz :apple-rgb)

262

2.9515373 -1.2894116 -0.4738445

263

-1.0851093 1.9908566 0.0372026

264

0.0854934 -0.2694964 1.0912975)

265

266

(define-conversion (:best-rgb xyz)

267

0.6326696 0.2045558 0.1269946

268

0.2284569 0.7373523 0.0341908

269

0.0000000 0.0095142 0.8156958)

270

271

(define-conversion (xyz :best-rgb)

272

1.7552599 -0.4836786 -0.2530000

273

-0.5441336 1.5068789 0.0215528

274

0.0063467 -0.0175761 1.2256959)

275

276

(define-conversion (:beta-rgb xyz)

277

0.6712537 0.1745834 0.1183829

278

0.3032726 0.6637861 0.0329413

279

0.0000000 0.0407010 0.7845090)

280

281

(define-conversion (xyz :beta-rgb)

282

1.6832270 -0.4282363 -0.2360185

283

-0.7710229 1.7065571 0.0446900

284

0.0400013 -0.0885376 1.2723640)

285

286

(define-conversion (:bruce-rgb xyz)

287

0.4674162 0.2944512 0.1886026

288

0.2410115 0.6835475 0.0754410

289

0.0219101 0.0736128 0.9933071)

290

291

(define-conversion (xyz :bruce-rgb)

292

2.7454669 -1.1358136 -0.4350269

293

-0.9692660 1.8760108 0.0415560

294

0.0112723 -0.1139754 1.0132541)

295

296

(define-conversion (:cie-rgb xyz)

297

0.4887180 0.3106803 0.2006017

298

0.1762044 0.8129847 0.0108109

299

0.0000000 0.0102048 0.9897952)

300

301

(define-conversion (xyz :cie-rgb)

302

2.3706743 -0.9000405 -0.4706338

303

-0.5138850 1.4253036 0.0885814

304

0.0052982 -0.0146949 1.0093968)

305

306

(define-conversion (:colormatch-rgb xyz)

307

0.5093439 0.3209071 0.1339691

308

0.2748840 0.6581315 0.0669845

309

0.0242545 0.1087821 0.6921735)

310

311

(define-conversion (xyz :colormatch-rgb)

312

2.6422874 -1.2234270 -0.3930143

313

-1.1119763 2.0590183 0.0159614

314

0.0821699 -0.2807254 1.4559877)

315

316

(define-conversion (:don-rgb-4 xyz)

317

0.6457711 0.1933511 0.1250978

318

0.2783496 0.6879702 0.0336802

319

0.0037113 0.0179861 0.8035125)

320

321

(define-conversion (xyz :don-rgb-4)

322

1.7603902 -0.4881198 -0.2536126

323

-0.7126288 1.6527432 0.0416715

324

0.0078207 -0.0347411 1.2447743)

325

326

(define-conversion (:eci-rgb xyz)

327

0.6502043 0.1780774 0.1359384

328

0.3202499 0.6020711 0.0776791

329

0.0000000 0.0678390 0.7573710)

330

331

(define-conversion (xyz :eci-rgb)

332

1.7827618 -0.4969847 -0.2690101

333

-0.9593623 1.9477962 -0.0275807

334

0.0859317 -0.1744674 1.3228273)

335

336

(define-conversion (:ekta-space-ps5 xyz)

337

0.5938914 0.2729801 0.0973485

338

0.2606286 0.7349465 0.0044249

339

0.0000000 0.0419969 0.7832131)

340

341

(define-conversion (xyz :ekta-space-ps5)

342

2.0043819 -0.7304844 -0.2450052

343

-0.7110285 1.6202126 0.0792227

344

0.0381263 -0.0868780 1.2725438)

345

346

(define-conversion (:ntsc-rgb xyz)

347

0.6068909 0.1735011 0.2003480

348

0.2989164 0.5865990 0.1144845

349

0.0000000 0.0660957 1.1162243)

350

351

(define-conversion (xyz :ntsc-rgb)

352

1.9099961 -0.5324542 -0.2882091

353

-0.9846663 1.9991710 -0.0283082

354

0.0583056 -0.1183781 0.8975535)

355

356

(define-conversion (:pal-rgb xyz)

357

0.4306190 0.3415419 0.1783091

358

0.2220379 0.7066384 0.0713236

359

0.0201853 0.1295504 0.9390944)

360

361

(define-conversion (xyz :pal-rgb)

362

3.0628971 -1.3931791 -0.4757517

363

-0.9692660 1.8760108 0.0415560

364

0.0678775 -0.2288548 1.0693490)

365

366

(define-conversion (:prophoto-rgb xyz)

367

0.7976749 0.1351917 0.0313534

368

0.2880402 0.7118741 0.0000857

369

0.0000000 0.0000000 0.8252100)

370

371

(define-conversion (xyz :prophoto-rgb)

372

1.3459433 -0.2556075 -0.0511118

373

-0.5445989 1.5081673 0.0205351

374

0.0000000 0.0000000 1.2118128)

375

376

(define-conversion (:smpte-c-rgb xyz)

377

0.3935891 0.3652497 0.1916313

378

0.2124132 0.7010437 0.0865432

379

0.0187423 0.1119313 0.9581563)

380

381

(define-conversion (xyz :smpte-c-rgb)

382

3.5053960 -1.7394894 -0.5439640

383

-1.0690722 1.9778245 0.0351722

384

0.0563200 -0.1970226 1.0502026)

385

386

(define-conversion (:srgb xyz)

387

0.4124564 0.3575761 0.1804375

388

0.2126729 0.7151522 0.0721750

389

0.0193339 0.1191920 0.9503041)

390

391

(define-conversion (xyz :srgb)

392

3.2404542 -1.5371385 -0.4985314

393

-0.9692660 1.8760108 0.0415560

394

0.0556434 -0.2040259 1.0572252)

395

396

(define-conversion (:wide-gamut-rgb xyz)

397

0.7161046 0.1009296 0.1471858

398

0.2581874 0.7249378 0.0168748

399

0.0000000 0.0517813 0.7734287)

400

401

(define-conversion (xyz :wide-gamut-rgb)

402

1.4628067 -0.1840623 -0.2743606

403

-0.5217933 1.4472381 0.0677227

404

0.0349342 -0.0968930 1.2884099)

405

406

407

(defun rgb= (a b)

408

(and

409

(typep a 'rgb) (typep b 'rgb)

410

(= (red a) (red b))

411

(= (blue a) (blue b))

412

(= (green a) (green b))

413

(= (alpha a) (alpha b))))

414

415

(define-constant +black+ (rgb 1 1 1) :test 'rgb=)

416

(define-constant +white+ (rgb 0 0 0) :test 'rgb=)