-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathold.lisp
173 lines (156 loc) · 6.19 KB
/
old.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
;;; Implements colour conversions between sRGB, CIE XYZ / xyY and CIE
;;; L*a*b* (1976) colour spaces. A complete implementation would
;;; handle details such as white point (illuminant) and viewing angle,
;;; and would cover all the conversions, possibly seamlessly and
;;; sanely. This is not (yet) that complete implementation. (It has
;;; grown when needed to set or verify undergraduate assignments...)
(defun sRGB->XYZ (r g b)
(flet ((linearize (c)
(if (< c 0.04045)
(/ c 12.92)
(expt (/ (+ c 0.055) 1.055) 2.4))))
(let ((rl (linearize r))
(gl (linearize g))
(bl (linearize b)))
(values
(+ (* 0.4124 rl) (* 0.3576 gl) (* 0.1805 bl))
(+ (* 0.2126 rl) (* 0.7152 gl) (* 0.0722 bl))
(+ (* 0.0193 rl) (* 0.1192 gl) (* 0.9505 bl))))))
(defun XYZ->sRGB (x y z)
(declare (type single-float x y z)
(optimize speed))
(flet ((gammaize (c)
(if (< c 0.00304)
(* 12.92 c)
(- (* 1.055 (expt c (/ 2.4))) 0.055))))
(let ((rl (+ (* 3.240625 x) (* -1.537208 y) (* -0.498629 z)))
(gl (+ (* -0.968931 x) (* 1.875756 y) (* 0.041518 z)))
(bl (+ (* 0.055710 x) (* -0.204021 y) (* 1.056996 z))))
(values (gammaize rl) (gammaize gl) (gammaize bl)))))
(defun XYZ->xyY (x y z)
(let ((sum (+ x y z)))
(values (/ x sum) (/ y sum) y)))
(defun sRGB->xyY (r g b)
(multiple-value-call #'XYZ->xyY (sRGB->XYZ r g b)))
(declaim (inline xyY->xyz))
(defun xyY->xyz (x y yy)
(values (* (/ x y) yy) yy (* (/ (- 1 x y) y) yy)))
(defun xyY->sRGB (x y yy)
(declare (optimize speed)
(single-float x y yy))
(multiple-value-bind (x y z)
(xyY->xyz x y yy)
(XYZ->sRGB x y z)))
(defun XYZ->LAB (x y z)
(flet ((f (c)
(if (> c (expt (/ 6 29) 3))
(expt c 1/3)
(+ (* 1/3 (expt 29/6 2) c) 4/29))))
;; E or #+nil D50 illuminant
(let ((x0 100.00 #+nil 96.42)
(y0 100.00)
(z0 100.00 #+nil 82.52))
(values
(- (* 116 (f (/ y y0))) 16)
(* 500 (- (f (/ x x0)) (f (/ y y0))))
(* 200 (- (f (/ y y0)) (f (/ z z0))))))))
(defun sRGB->LAB (r g b)
(apply #'XYZ->LAB (mapcar (lambda (x) (* x 100))
(multiple-value-call #'list (sRGB->XYZ r g b)))))
(defun deltaC/sRGB (c1 c2)
(multiple-value-bind (l1 a1 b1) (apply #'sRGB->LAB c1)
(multiple-value-bind (l2 a2 b2) (apply #'sRGB->LAB c2)
(sqrt (+ (expt (- l2 l1) 2) (expt (- a2 a1) 2) (expt (- b2 b1) 2))))))
(defun grayscalize/sRGB (r g b)
(multiple-value-bind (x y yy) (sRGB->xyY r g b)
(declare (ignore x y))
(multiple-value-bind (r g b)
(xyY->sRGB 0.3127 0.3290 yy)
(/ (+ r g b) 3))))
(defstruct (colour (:constructor %make-colour))
(rep (error "missing rep") :type (unsigned-byte 63)))
(defmethod print-object ((c colour) s)
(let ((x (colour-x c))
(y (colour-y c))
(z (colour-z c)))
(pprint-logical-block (s nil :prefix "#<COLOUR " :suffix ">")
(format s "X: ~,2F Y: ~,2F Z: ~,2F (x: ~,2F y: ~,2F) ~@:_" x y z (/ x (+ x y z)) (/ y (+ x y z)))
(apply #'format s "R: ~,2F G: ~,2F B: ~,2F" (multiple-value-list (xyz->srgb x y z)))
(apply #'format s " (#~2,'0X~2,'0X~2,'0X, ~3:*rgb(~D,~D,~D))" (mapcar (lambda (x) (round (* (min 1 (max 0 x)) 255))) (multiple-value-list (xyz->srgb x y z)))))))
(defun colour-x (colour)
(let* ((bits (ldb (byte 21 42) (colour-rep colour))))
(short-to-float bits)))
(defun colour-y (colour)
(let* ((bits (ldb (byte 21 21) (colour-rep colour))))
(short-to-float bits)))
(defun colour-z (colour)
(let* ((bits (ldb (byte 21 0) (colour-rep colour))))
(short-to-float bits)))
(defun short-floatify (float)
(multiple-value-bind (mantissa exponent sign) (decode-float float)
(unless (<= -32 exponent 31)
(error "exponent"))
(unless (> sign -1)
(error "sign"))
(let* ((m (* mantissa 2))
(m-1 (- m 1))
(im (round (* m-1 (expt 2 15))))
(ie (+ exponent 32)))
(dpb ie (byte 6 15) im))))
(defun short-to-float (short)
(let ((mantissa (ldb (byte 15 0) short))
(exponent (- (ldb (byte 6 15) short) 32)))
(float (* (1+ (/ mantissa (expt 2 15))) (expt 2 (1- exponent))))))
(defun %make-xyz-colour (x y z)
(let ((sx (short-floatify (float x)))
(sy (short-floatify (float y)))
(sz (short-floatify (float z))))
(%make-colour :rep (logior (ash sx 42) (ash sy 21) sz))))
(defun %make-rgb-colour (r g b)
(multiple-value-bind (x y z) (srgb->xyz r g b)
(%make-xyz-colour x y z)))
(defun colour (x)
(cond
((colour-p x) x)
((and (stringp x) (eql 4 (mismatch x "rgb(")))
(let ((end (position #\) x))
(spos 4)
epos rgbs)
(tagbody
valid-spos
(setf epos (position #\, x :start spos :end end))
(when (null epos) (go last-one))
(push (parse-integer x :start spos :end epos) rgbs)
(setf spos (1+ epos))
(go valid-spos)
last-one
(push (parse-integer x :start spos :end end) rgbs)
(return-from colour (apply #'%make-rgb-colour (nreverse (mapcar (lambda (x) (/ x 255)) rgbs)))))))
((and (stringp x) (= (length x) 7)
(char= (char x 0) #\#))
(%make-rgb-colour (/ (parse-integer x :start 1 :end 3 :radix 16) 255)
(/ (parse-integer x :start 3 :end 5 :radix 16) 255)
(/ (parse-integer x :start 5 :end 7 :radix 16) 255)))))
(defmacro with-xyz ((&rest names) c &body body)
(let ((col (gensym "COL")))
`(let ((,col ,c))
(multiple-value-bind (,@names)
(values (colour-x ,col) (colour-y ,col) (colour-z ,col))
,@body))))
(defun colour+ (&rest cs)
(let ((rx 0) (ry 0) (rz 0))
(dolist (c cs (%make-xyz-colour rx ry rz))
(with-xyz (x y z) (colour c)
(incf rx x)
(incf ry y)
(incf rz z)))))
(defun colour+/2 (a b)
(with-xyz (ax ay az) (colour a)
(with-xyz (bx by bz) (colour b)
(%make-xyz-colour (+ ax bx) (+ ay by) (+ az bz)))))
(defun colour* (c n)
(with-xyz (x y z) (colour c)
(%make-xyz-colour (* x n) (* y n) (* z n))))
(defun colour/ (c n)
(with-xyz (x y z) (colour c)
(%make-xyz-colour (/ x n) (/ y n) (/ z n))))