/pliant/graphic/color/color.pli
1	abstract
2	[Tri values colors conversions] ; eol
3	link "extra details" "http://www.cs.rit.edu/~ncs/color/t_convert.html"
4	[ and ]
5	link "sRGB spec" "http://www.w3.org/Graphics/Color/sRGB.html"
6
7	module "/pliant/language/unsafe.pli"
8	module "spectrum.pli"
9	module "gradation.pli"
10	module "/pliant/math/functions.pli"
11	module "/pliant/math/matrix.pli"
12	module "/pliant/graphic/misc/float.pli"
13	submodule "rgb888.pli"
14
15	function angle xx yy -> a
16	arg Float xx yy a
17	var Float x y z
18	x := xx ; y := yy
19	if x>=0.0
20	if y>=0.0
21	z := 0
22	else
23	z := x ; x := -y ; y := z ; z := 1.5*pi
24	else
25	if y>=0
26	z := x ; x := y ; y := -z ; z := 0.5*pi
27	else
28	x := -x; y := -y ; z := pi
29	if y<=x
30	if x=0
31	a := 0
32	a := z+(atan y/x)
33	else
34	a := z+0.5*pi-(atan x/y)
35
36
37	public
38	type ColorXYZ
39	field Float32 X Y Z
40
41	type ColorXYZn
42	field Float32 X Y Z
43
44	type ColorYxy
45	field Float32 Y x y
46
47	type ColorRGB
48	field Float32 r g b
49
50	type ColorHSV
51	field Float32 h s v
52
53	type ColorLab
54	field Float32 L a b
55
56	type ColorLCh
57	field Float32 L C h
58
59
60	function filter_XYZ s -> xyz
61	arg ColorSpectrum32 s ; arg ColorXYZ xyz
62	var ColorSpectrum32 final := illuminant_spectrum*s
63	xyz X := final X
64	xyz Y := final Y
65	xyz Z := final Z
66
67	constant ill_X illuminant_spectrum:X
68	constant ill_Y illuminant_spectrum:Y
69	constant ill_Z illuminant_spectrum:Z
70
71	function filter_XYZn s -> xyz
72	arg ColorSpectrum32 s ; arg ColorXYZn xyz
73	var ColorSpectrum32 final := illuminant_spectrum*s
74	xyz X := final:X/ill_X
75	xyz Y := final:Y/ill_Y
76	xyz Z := final:Z/ill_Z
77
78	function 'cast ColorYxy' xyz -> yxy
79	arg ColorXYZ xyz ; arg ColorYxy yxy
80	yxy Y := xyz Y
81	var Float f := xyz:X+xyz:Y+xyz:Z
82	if f<=0
83	f := 1
84	yxy x := xyz:X/f
85	yxy y := xyz:Y/f
86
87	function 'cast ColorXYZn' xyz -> xyzn
88	arg ColorXYZ xyz ; arg ColorXYZn xyzn
89	xyzn X := xyz:X/ill_X
90	xyzn Y := xyz:Y/ill_Y
91	xyzn Z := xyz:Z/ill_Z
92
93	function 'cast ColorXYZ' xyzn -> xyz
94	arg ColorXYZn xyzn ; arg ColorXYZ xyz
95	xyz X := xyzn:X*ill_X
96	xyz Y := xyzn:Y*ill_Y
97	xyz Z := xyzn:Z*ill_Z
98
99	function 'cast ColorXYZ' yxy -> xyz
100	arg ColorYxy yxy ; arg ColorXYZ xyz
101	xyz Y := yxy Y
102	var Float f := yxy:Y/yxy:y
103	xyz X := yxy:x*f
104	xyz Z := (1-yxy:x-yxy:y)*f
105
106	function rgb_matrix -> final
107	arg Matrix final
108	(var Matrix rgb_spec) resize 3 3
109	# red
110	rgb_spec 0 0 := 0.64 ; rgb_spec 1 0 := 0.33 ; rgb_spec 2 0 := 1-(rgb_spec 0 0)-(rgb_spec 1 0)
111	# green
112	rgb_spec 0 1 := 0.30 ; rgb_spec 1 1 := 0.60 ; rgb_spec 2 1 := 1-(rgb_spec 0 1)-(rgb_spec 1 1)
113	# blue
114	rgb_spec 0 2 := 0.15 ; rgb_spec 1 2 := 0.06 ; rgb_spec 2 2 := 1-(rgb_spec 0 2)-(rgb_spec 1 2)
115	var ColorXYZ white := filter_XYZ (cast 1 ColorSpectrum32)
116	(var Matrix ill) resize 3 1
117	ill 0 0 := white:X
118	ill 1 0 := white:Y
119	ill 2 0 := white:Z
120	var Matrix coeff := rgb_spec^(-1)*ill
121	final resize 3 3
122	for (var Int l) 0 2
123	for (var Int c) 0 2
124	final l c := (coeff c 0)*(rgb_spec l c)
125
126	function display
127	constant m rgb_matrix
128	for (var Int l) 0 2
129	for (var Int c) 0 2
130	console (m l c) " "
131	console eol
132	# display
133
134	function 'cast ColorRGB' xyz -> rgb
135	arg ColorXYZ xyz ; arg ColorRGB rgb
136	constant m rgb_matrix^(-1)
137	rgb r := (m 0 0)*xyz:X+(m 0 1)*xyz:Y+(m 0 2)*xyz:Z
138	rgb g := (m 1 0)*xyz:X+(m 1 1)*xyz:Y+(m 1 2)*xyz:Z
139	rgb b := (m 2 0)*xyz:X+(m 2 1)*xyz:Y+(m 2 2)*xyz:Z
140
141	function 'cast ColorXYZ' rgb -> xyz
142	arg ColorRGB rgb ; arg ColorXYZ xyz
143	constant m rgb_matrix
144	xyz X := (m 0 0)*rgb:r+(m 0 1)*rgb:g+(m 0 2)*rgb:b
145	xyz Y := (m 1 0)*rgb:r+(m 1 1)*rgb:g+(m 1 2)*rgb:b
146	xyz Z := (m 2 0)*rgb:r+(m 2 1)*rgb:g+(m 2 2)*rgb:b
147
148	function test
149	var ColorXYZ xyz := filter_XYZ (cast 1 ColorSpectrum32)
150	var ColorRGB rgb := cast xyz ColorRGB
151	console "r = " rgb:r "  g = " rgb:g "  b = " rgb:b eol
152	# test
153
154	gvar ColorGradation rgb_gradation := color_gamma 2.4 0.03928 0.055
155
156	function 'cast ColorRGB888' rgb -> rgb888
157	arg ColorRGB rgb ; arg ColorRGB888 rgb888
158	reduction
159	rgb888 r := rgb_gradation encode rgb:r
160	rgb888 g := rgb_gradation encode rgb:g
161	rgb888 b := rgb_gradation encode rgb:b
162
163	function 'cast ColorRGB' rgb888 -> rgb
164	arg ColorRGB888 rgb888 ; arg ColorRGB rgb
165	extension
166	rgb r := rgb_gradation decode rgb888:r
167	rgb g := rgb_gradation decode rgb888:g
168	rgb b := rgb_gradation decode rgb888:b
169
170	function 'cast ColorRGB' hsv -> rgb
171	arg ColorHSV hsv ; arg ColorRGB rgb
172	check hsv:h>=0 and hsv:h<360
173	check hsv:s>=0 and hsv:s<=1
174	check hsv:v>=0 and hsv:v<=1
175	var Float s := hsv s
176	var Float v := hsv v
177	if hsv:s=0
178	rgb r := v
179	rgb g := v
180	rgb b := v
181	return
182	var Float h := hsv:h/60
183	var Int i := cast h-0.5 Int
184	check i>=0 and i<=5
185	var Float f := h-i
186	var Float p := v*(1-s)
187	var Float q := v*(1-s*f)
188	var Float t := v*(1-s*(1-f))
189	if i=0
190	rgb r := v
191	rgb g := t
192	rgb b := p
193	eif i=1
194	rgb r := q
195	rgb g := v
196	rgb b := p
197	eif i=2
198	rgb r := p
199	rgb g := v
200	rgb b := t
201	eif i=3
202	rgb r := p
203	rgb g := q
204	rgb b := v
205	eif i=4
206	rgb r := t
207	rgb g := p
208	rgb b := v
209	else # i=5
210	rgb r := v
211	rgb g := p
212	rgb b := q
213
214	function 'cast ColorHSV' rgb -> hsv
215	arg ColorRGB rgb ; arg ColorHSV hsv
216	# check rgb:r>=0 and rgb:r<=1
217	# check rgb:g>=0 and rgb:g<=1
218	# check rgb:b>=0 and rgb:b<=1
219	var Float min := min (min rgb:r rgb:g) rgb:b
220	var Float max := max (max rgb:r rgb:g) rgb:b
221	hsv v := max
222	var Float delta := max-min
223	if max>0
224	hsv s := delta/max
225	else # r=g=b=0 -> s=0, v=undefined
226	hsv s := 0
227	hsv h := undefined
228	return
229	var Float h
230	if rgb:r=max
231	h := (rgb:g-rgb:b)/delta
232	eif rgb:g=max
233	h := 2+(rgb:b-rgb:r)/delta
234	else
235	h := 4+(rgb:r-rgb:g)/delta
236	h *= 60
237	if h<0
238	h += 360
239	hsv h := h
240
241	export filter_XYZ filter_XYZn
242	export 'cast ColorXYZ' 'cast ColorXYZn' 'cast ColorYxy' 'cast ColorRGB' 'cast ColorRGB888' 'cast ColorHSV'
243
244
245	gvar Matrix r
246
247	function r_setup
248	var Matrix m
249	m resize 3 3
250	m 0 0 := 0.49    ; m 0 1 := 0.31    ; m 0 2 := 0.20
251	m 1 0 := 0.17697 ; m 1 1 := 0.81240 ; m 1 2 := 0.01063
252	m 2 0 := 0       ; m 2 1 := 0.01    ; m 2 2 := 0.99
253	r := m^(-1)
254	if false
255	for (var Int l) 0 2
256	for (var Int c) 0 2
257	console (r l c) " "
258	console eol
259	r_setup
260
261	function cie_rgb xyz -> rgb
262	arg ColorXYZ xyz ; arg ColorRGB rgb
263	rgb r := (r 0 0)*xyz:X + (r 0 1)*xyz:Y + (r 0 2)*xyz:Z
264	rgb g := (r 1 0)*xyz:X + (r 1 1)*xyz:Y + (r 1 2)*xyz:Z
265	rgb b := (r 2 0)*xyz:X + (r 2 1)*xyz:Y + (r 2 2)*xyz:Z
266
267	function uniform v w -> u
268	arg Float v w u
269	if v/w>0.008856
270	u := (v/w)^(1/3)
271	else
272	u := 7.787*v/w+16/116
273
274	function 'cast ColorLab' xyz -> lab
275	arg ColorXYZ xyz ; arg ColorLab lab
276	lab L := 116*(uniform xyz:Y ill_Y)-16
277	lab a := 500*((uniform xyz:X ill_X)-(uniform xyz:Y ill_Y))
278	lab b := 200*((uniform xyz:Y ill_Y)-(uniform xyz:Z ill_Z))
279
280
281	function linear1 u -> l
282	arg Float u l
283	if u>9.03296295513076*0.008856
284	l := ((u+0.16)/1.16) ^ 3
285	else
286	l := u/9.03296295513076
287
288	function 'cast ColorXYZ' lab -> xyz
289	arg ColorLab lab ; arg ColorXYZ xyz
290	xyz X := (linear1 lab:a*1.16/500.0 + lab:L/100.0) * ill_X
291	xyz Y := (linear1 lab:L/100) * ill_Y
292	xyz Z := (linear1 lab:L/100 - lab:b*1.16/200) * ill_Z
293
294
295	function linear2 v w -> u
296	arg Float v w u
297	u := v/w
298
299	function lab_linear xyz -> lab
300	arg ColorXYZ xyz ; arg ColorLab lab
301	lab L := 100*(linear2 xyz:Y ill_Y)
302	lab a := 500*((linear2 xyz:X ill_X)-(linear2 xyz:Y ill_Y))
303	lab b := 200*((linear2 xyz:Y ill_Y)-(linear2 xyz:Z ill_Z))
304
305
306	function 'cast ColorLab' lch -> lab
307	arg ColorLCh lch ; arg ColorLab lab
308	lab L := lch L
309	lab a := lch:C*(cos lch:h*pi/180)
310	if lab:a=undefined
311	lab a := 0
312	lab b := lch:C*(sin lch:h*pi/180)
313	if lab:b=undefined
314	lab b := 0
315
316	function 'cast ColorLCh' lab -> lch
317	arg ColorLab lab ; arg ColorLCh lch
318	lch L := lab L
319	lch C := (lab:a*lab:a+lab:b*lab:b)^0.5
320	if lch:C=undefined
321	lch C := 0
322	lch h := (angle lab:a lab:b)*180/pi
323
324
325	export cie_rgb 'cast ColorXYZ' 'cast ColorLab' 'cast ColorLCh' 'cast ColorLab' lab_linear
326
327
328	function lab_distance ref test -> d
329	arg ColorLab ref test ; arg Float d
330	var Float dL := abs ref:L-test:L
331	var Float da := abs ref:a-test:a
332	var Float db := abs ref:b-test:b
333	d := ( pow2:dL + pow2:da + pow2:db )^0.5
334	if d=undefined
335	d := 0
336
337	function lab_distance ref test -> d
338	arg ColorXYZ ref test ; arg Float d
339	d := lab_distance (cast ref ColorLab) (cast test ColorLab)
340
341	export lab_distance
342
343
344	function cmc_distance ref test l c -> d
345	arg ColorLab ref test ; arg Float l c d
346	var Float e := lab_distance ref test
347	if l=undefined or c=undefined
348	return e
349	var ColorLCh ref_lch := cast ref ColorLCh
350	var ColorLCh test_lch := cast test ColorLCh
351	var Float dL := abs ref:L-test:L
352	var Float dC := abs ref_lch:C-test_lch:C
353	var Float dH := ( pow2:e - pow2:dL - pow2:dC )^0.5
354	if dH=undefined
355	dH := 0
356	var Float L := min ref_lch:L test_lch:L
357	var Float C := max ref_lch:C test_lch:C
358	var Float h := ref_lch h
359	if h=undefined
360	h := 0
361	var Float Sl
362	if L>=16
363	Sl := 0.040975*L/(1+0.01765*L)
364	else
365	Sl := 0.511
366	var Float Sc := 0.0638*C/(1+0.0131*C)+0.638
367	var Float f := (C^4/(C^4+1900))^0.5
368	if f=undefined
369	f := 0
370	var Float T
371	if h<164 or h>345
372	T := 0.36+(abs 0.4*(cos (h+35)*pi/180))
373	else
374	T := 0.56+(abs 0.2*(cos (h+168)*pi/180))
375	var Float Sh := (f*T+1-f)*Sc
376	d := ( (pow2 dL/(l*Sl)) + (pow2 dC/(c*Sc)) + (pow2 dH/Sh) )^0.5
377	if d=undefined
378	d := 0
379
380	gvar Float cmc_distance_l_parameter := 1
381	gvar Float cmc_distance_c_parameter := 1
382
383	function cmc_distance ref test -> d
384	arg ColorLab ref test ; arg Float d
385	d := cmc_distance ref test cmc_distance_l_parameter cmc_distance_c_parameter
386
387	function cmc_distance ref test l c -> d
388	arg ColorXYZ ref test ; arg Float l c ; arg Float d
389	d := cmc_distance (cast ref ColorLab) (cast test ColorLab) l c
390
391	function cmc_distance ref test -> d
392	arg ColorXYZ ref test ; arg Float d
393	d := cmc_distance (cast ref ColorLab) (cast test ColorLab)
394
395	export cmc_distance cmc_distance_l_parameter cmc_distance_c_parameter