1
2/* Try to make a Matrix ... works for Vector/Image/Real, plus image/real
3 */
4to_matrix x
5	= to_matrix x.expr, is_Expression x
6	= x, is_Matrix x
7	= oo_unary_function to_matrix_op x, is_class x
8	= tom x, is_real x || is_image x
9	= error (_ "bad arguments to " ++ "to_matrix")
10{
11	to_matrix_op = Operator "to_matrix" tom Operator_type.COMPOUND false;
12
13	tom x
14		= Matrix (itom x), is_image x
15		= Matrix [[x]], is_real x
16		= Matrix [x], is_real_list x
17		= Matrix x, is_matrix x
18		= error (_ "bad arguments to " ++ "to_matrix");
19
20	itom i
21		= (im_vips2mask ((double) i)).value,
22			is_image i && get_bands i == 1
23		= (im_vips2mask ((double) i'')).value,
24			is_image i && get_bands i == 3 && get_width i == 1
25		= error (_ "not 1 band image, or 3 band 1 column image")
26	{
27		split = bandsplit i;
28		i' = im_insert (split?0) (split?1) 1 0;
29		i'' = im_insert i' (split?2) 2 0;
30	}
31}
32
33/* Try to make an Image ... works for Vector/Matrix/Real, plus image/real
34 * Special case for Colour ... pull out the colour_space and set Type in the
35 * image.
36 */
37to_image x
38	= to_image x.expr, is_Expression x
39	= x, is_Image x
40	= Image (image_set_type
41			(Image_type.colour_spaces.lookup 0 1 x.colour_space)
42			(mtoi [x.value])),
43		is_Colour x
44	= oo_unary_function to_image_op x, is_class x
45	= toi x, is_real x || is_image x
46	= error (_ "bad arguments to " ++ "to_image")
47{
48	to_image_op = Operator "to_image" toi Operator_type.COMPOUND false;
49
50	toi x
51		= Image x, is_image x
52		= Image (mtoi [[x]]), is_real x
53		= Image (mtoi [x]), is_real_list x
54		= Image (mtoi x), is_matrix x
55		= error (_ "bad arguments to " ++ "to_image");
56
57	// [[real]] -> image
58	mtoi m
59		= im_mask2vips (Matrix m), width != 3
60		= joinup (im_mask2vips (Matrix m))
61	{
62		width = len m?0;
63		height = len m;
64		joinup i
65			= b1 ++ b2 ++ b3
66		{
67			b1 = extract_area 0 0 1 height i;
68			b2 = extract_area 1 0 1 height i;
69			b3 = extract_area 2 0 1 height i;
70		}
71	}
72}
73
74/* Try to make a Colour.
75 */
76to_colour x
77	= to_colour x.expr, is_Expression x
78	= x, is_Colour x
79	= Colour (colour_space (get_type x)) (map mean (bandsplit (get_image x))),
80		has_image x && has_type x
81	= error (_ "bad arguments to " ++ "to_colour")
82{
83	colour_space type
84		= table.get_name type, table.has_name type
85		= error (_ "unable to make Colour from " ++ table.get_name type ++
86			_ " image")
87	{
88		table = Image_type.colour_spaces;
89	}
90}
91
92/* Try to make a real.
93 */
94to_real x
95	= to_real x.expr, is_Expression x
96	= to_real x.value, is_class x
97	= x, is_real x
98	= abs x, is_complex x
99	= 1, is_bool x && x
100	= 0, is_bool x && !x
101	= error (_ "bad arguments to " ++ "to_real");
102
103/* Try to make a list ... ungroup, basically. Recurse for subgroups.
104 */
105to_list x
106	= map to_list x.value, is_Group x
107	= x;
108
109/* Parse a positive integer.
110 */
111parse_pint l
112	= foldl acc 0 l
113{
114	acc sofar ch = sofar * 10 + parse_c ch;
115
116	/* Turn a char digit to a number.
117	 */
118	parse_c ch
119		= error (_ "not a digit"), !is_digit ch
120		= (int) ch - (int) '0';
121}
122
123/* Parse an integer, with an optional sign character.
124 */
125parse_int l
126	= error (_ "badly formed number"), len parts != 2
127	= sign * n
128{
129	parts = splitpl [member "+-", is_digit] l;
130
131	n = parse_pint parts?1;
132	sign
133		= 1, parts?0 == [] || parts?0 == "+"
134		= -1;
135}
136
137/* Parse a float.
138 *	[+-]?[0-9]*([.][0-9]*)?(e[0-9]+)?
139 */
140parse_float l
141	= err, len parts != 4
142	= (ipart + fpart) * 10 ** exp
143{
144	err = error (_ "badly formed number");
145
146	parts = splitpl [
147		member "+-0123456789", member ".0123456789",
148		member "eE", member "+-0123456789"
149	] l;
150
151	ipart = parse_int parts?0;
152	fpart
153		= 0, parts?1 == [];
154		= err, parts?1?0 != '.'
155		= parse_pint (tl parts?1) / 10 ** (len parts?1 - 1);
156	exp
157		= 0, parts?2 == [] && parts?3 == []
158		= err, parts?2 == []
159		= parse_int parts?3;
160
161}
162
163// matrix to convert D65 XYZ to D50 XYZ ... direct conversion, found by
164// measuring a macbeth chart in D50 and D65 and doing a LMS to get a matrix
165D652D50_direct = Matrix
166	[[ 1.13529, -0.0604663, -0.0606321 ],
167	 [ 0.0975399, 0.935024, -0.0256156 ],
168	 [ -0.0336428, 0.0414702, 0.994135 ]];
169
170D502D65_direct = D652D50_direct ** -1;
171
172/* Convert normalised XYZ to bradford RGB.
173 */
174XYZ2RGBbrad = Matrix
175	[[0.8951,  0.2664, -0.1614],
176	 [-0.7502,  1.7135,  0.0367],
177	 [0.0389, -0.0685,  1.0296]];
178
179/* Convert bradford RGB to normalised XYZ.
180 */
181RGBbrad2XYZ = XYZ2RGBbrad ** -1;
182
183D93_whitepoint = Vector [89.7400, 100, 130.7700];
184D75_whitepoint = Vector [94.9682, 100, 122.5710];
185D65_whitepoint = Vector [95.0470, 100, 108.8827];
186D55_whitepoint = Vector [95.6831, 100, 92.0871];
187D50_whitepoint = Vector [96.4250, 100, 82.4680];
188A_whitepoint = Vector [109.8503, 100, 35.5849]; 	// 2856K
189B_whitepoint = Vector [99.0720, 100, 85.2230];		// 4874K
190C_whitepoint = Vector [98.0700, 100, 118.2300];		// 6774K
191E_whitepoint = Vector [100, 100, 100];			// ill. free
192D3250_whitepoint = Vector [105.6590, 100, 45.8501];
193
194Whitepoints = Enum [
195	["D93", D93_whitepoint],
196	["D75", D75_whitepoint],
197	["D65", D65_whitepoint],
198	["D55", D55_whitepoint],
199	["D50", D50_whitepoint],
200	["A", A_whitepoint],
201	["B", B_whitepoint],
202	["C", C_whitepoint],
203	["E", E_whitepoint],
204	["D3250", D3250_whitepoint]
205];
206
207/* Convert D50 XYZ to D65 using the bradford chromatic adaptation approx.
208 */
209im_D502D65 xyz
210	= xyz'''
211{
212	xyz' = xyz / D50_whitepoint;
213
214	rgb = recomb XYZ2RGBbrad xyz';
215
216	// move white in bradford RGB
217	rgb' = rgb / Vector [0.94, 1.02, 1.33];
218
219	xyz'' = recomb RGBbrad2XYZ rgb';
220
221	// back to D65
222	xyz''' = xyz'' * D65_whitepoint;
223}
224
225/* Convert D65 XYZ to D50 using the bradford approx.
226 */
227im_D652D50 xyz
228	= xyz'''
229{
230	xyz' = xyz / D65_whitepoint;
231
232	rgb = recomb XYZ2RGBbrad xyz';
233
234	// move white in bradford RGB
235	rgb' = rgb * Vector [0.94, 1.02, 1.33];
236
237	xyz'' = recomb RGBbrad2XYZ rgb';
238
239	xyz''' = xyz'' * D50_whitepoint;
240}
241
242/* Convert D50 XYZ to Lab.
243 */
244im_D50XYZ2Lab xyz
245	= im_XYZ2Lab_temp xyz
246		D50_whitepoint.value?0
247		D50_whitepoint.value?1
248		D50_whitepoint.value?2;
249
250/* Convert D50 Lab to XYZ.
251 */
252im_D50Lab2XYZ lab
253	= im_Lab2XYZ_temp lab
254		D50_whitepoint.value?0
255		D50_whitepoint.value?1
256		D50_whitepoint.value?2;
257
258/* ... and mono conversions
259 */
260im_sRGB2mono in
261	= (image_set_type Image_type.B_W @
262		clip2fmt (im_header_int "BandFmt" in) @
263			recomb (Matrix [[.3, .6, .1]])) in;
264im_mono2sRGB in
265	= image_set_type Image_type.sRGB (in ++ in ++ in);
266
267im_sRGB2Lab in = im_XYZ2Lab (im_sRGB2XYZ in);
268
269im_Lab2sRGB in = im_XYZ2sRGB (im_Lab2XYZ in);
270
271/* apply a func to an image ... make it 1 or 3 bands, and reapply other bands
272 * on the way out. Except if it's LABPACK.
273 */
274colour_apply fn x
275	= fn x, b == 1 || b == 3 || c == Image_coding.LABPACK
276	= x''
277{
278	b = get_bands x;
279	c = get_coding x;
280
281	first
282		= extract_bands 0 3 x, b > 3
283		= extract_bands 0 1 x;
284	tail
285		= extract_bands 3 (b - 3) x, b > 3
286		= extract_bands 1 (b - 1) x;
287	x' = fn first;
288	x'' = x' ++ clip2fmt (get_format x') tail;
289}
290
291/* Any 1-ary colour op, applied to Vector/Image/Matrix or image
292 */
293colour_unary fn x
294	= oo_unary_function colour_op x, is_class x
295	= colour_apply fn x, is_image x
296	= colour_apply fn [x], is_real x
297	= error (_ "bad arguments to " ++ "colour_unary")
298{
299	// COMPOUND_REWRAP ... signal to the colour class to go to image and
300	// back
301	colour_op = Operator "colour_unary"
302		colour_object Operator_type.COMPOUND_REWRAP false;
303
304	colour_object x
305		= colour_real_list x, is_real_list x
306		= map colour_real_list x, is_matrix x
307		= colour_apply fn x, is_image x
308		= error (_ "bad arguments to " ++ "colour_unary");
309
310	colour_real_list l
311		= (to_matrix (fn (float) (to_image (Vector l)).value)).value?0;
312}
313
314/* Any symmetric 2-ary colour op, applied to Vector/Image/Matrix or image ...
315 * name is op name for error messages etc.
316 */
317colour_binary name fn x y
318	= oo_binary_function colour_op x y, is_class x
319	= oo_binary'_function colour_op x y, is_class y
320	= fn x y, is_image x && is_image y
321	= error (_ "bad arguments to " ++ name)
322{
323	colour_op = Operator name
324		colour_object Operator_type.COMPOUND_REWRAP true;
325
326	colour_object x y
327		= fn x y, is_image x && is_image y
328		= colour_real_list fn x y, is_real_list x && is_real_list y
329		= map (colour_real_list fn x) y, is_real_list x && is_matrix y
330		= map (colour_real_list (converse fn) y) x,
331			is_matrix x && is_real_list y
332		= map2 (colour_real_list fn) x y, is_matrix x && is_matrix y
333		= error (_ "bad arguments to " ++ name);
334
335	colour_real_list fn l1 l2
336		= (to_matrix (fn i1 i2)).value?0
337	{
338		i1 = (float) (to_image (Vector l1)).value;
339		i2 = (float) (to_image (Vector l2)).value;
340	}
341}
342
343_colour_conversion_table = [
344	/* Lines are [space-from, space-to, conversion function]. Could do
345	 * this as a big array, but table lookup feels safer.
346	 */
347	[B_W, B_W, image_set_type B_W],
348	[B_W, XYZ, im_sRGB2XYZ @ im_mono2sRGB @ im_clip],
349	[B_W, YXY, im_XYZ2Yxy @ im_sRGB2XYZ @ im_mono2sRGB @ im_clip],
350	[B_W, LAB, im_sRGB2Lab @ im_mono2sRGB @ im_clip],
351	[B_W, LCH, im_Lab2LCh @ im_sRGB2Lab @ im_mono2sRGB @ im_clip],
352	[B_W, UCS, im_XYZ2UCS @ im_sRGB2XYZ @ im_mono2sRGB @ im_clip],
353	[B_W, RGB, im_XYZ2disp @ im_sRGB2XYZ @ im_mono2sRGB @ im_clip],
354	[B_W, sRGB, im_mono2sRGB @ im_clip],
355	[B_W, LABQ, im_Lab2LabQ @ im_sRGB2Lab @ im_mono2sRGB @ im_clip],
356	[B_W, LABS, im_LabQ2LabS @ im_Lab2LabQ @ im_sRGB2Lab @
357		im_mono2sRGB @ im_clip],
358
359	[XYZ, B_W, im_sRGB2mono @ im_XYZ2sRGB @ im_clip2f],
360	[XYZ, XYZ, image_set_type XYZ],
361	[XYZ, YXY, im_XYZ2Yxy @ im_clip2f],
362	[XYZ, LAB, im_XYZ2Lab @ im_clip2f],
363	[XYZ, LCH, im_Lab2LCh @ im_XYZ2Lab],
364	[XYZ, UCS, im_XYZ2UCS @ im_clip2f],
365	[XYZ, RGB, im_XYZ2disp @ im_clip2f],
366	[XYZ, sRGB, im_XYZ2sRGB @ im_clip2f],
367	[XYZ, LABQ, im_Lab2LabQ @ im_XYZ2Lab @ im_clip2f],
368	[XYZ, LABS, im_LabQ2LabS @ im_Lab2LabQ @ im_XYZ2Lab @ im_clip2f],
369
370	[YXY, B_W, im_sRGB2mono @ im_XYZ2sRGB @ im_Yxy2XYZ @ im_clip2f],
371	[YXY, XYZ, im_Yxy2XYZ @ im_clip2f],
372	[YXY, YXY, image_set_type YXY],
373	[YXY, LAB, im_XYZ2Lab @ im_Yxy2XYZ @ im_clip2f],
374	[YXY, LCH, im_Lab2LCh @ im_XYZ2Lab @ im_Yxy2XYZ @ im_clip2f],
375	[YXY, UCS, im_XYZ2UCS @ im_Yxy2XYZ @ im_clip2f],
376	[YXY, RGB, im_XYZ2disp @ im_Yxy2XYZ @ im_clip2f],
377	[YXY, sRGB, im_XYZ2sRGB @ im_Yxy2XYZ @ im_clip2f],
378	[YXY, LABQ, im_Lab2LabQ @ im_XYZ2Lab @ im_Yxy2XYZ @ im_clip2f],
379	[YXY, LABS, im_LabQ2LabS @ im_Lab2LabQ @ im_XYZ2Lab @ im_Yxy2XYZ @
380		im_clip2f],
381
382	[LAB, B_W, im_sRGB2mono @ im_Lab2sRGB @ im_Lab2XYZ @ im_clip2f],
383	[LAB, XYZ, im_Lab2XYZ @ im_clip2f],
384	[LAB, YXY, im_XYZ2Yxy @ im_Lab2XYZ @ im_clip2f],
385	[LAB, LAB, image_set_type LAB @ im_clip2f],
386	[LAB, LCH, im_Lab2LCh @ im_clip2f],
387	[LAB, UCS, im_Lab2UCS @ im_clip2f],
388	[LAB, RGB, im_Lab2disp @ im_clip2f],
389	[LAB, sRGB, im_Lab2sRGB @ im_clip2f],
390	[LAB, LABQ, im_Lab2LabQ @ im_clip2f],
391	[LAB, LABS, im_Lab2LabS @ im_clip2f],
392
393	[LCH, B_W, im_sRGB2mono @ im_Lab2sRGB @ im_LCh2Lab @ im_clip2f],
394	[LCH, XYZ, im_Lab2XYZ @ im_LCh2Lab @ im_clip2f],
395	[LCH, YXY, im_XYZ2Yxy @ im_Lab2sRGB @ im_LCh2Lab @ im_clip2f],
396	[LCH, LAB, im_LCh2Lab @ im_clip2f],
397	[LCH, LCH, image_set_type LCH],
398	[LCH, UCS, im_LCh2UCS @ im_clip2f],
399	[LCH, RGB, im_Lab2disp @ im_LCh2Lab @ im_clip2f],
400	[LCH, sRGB, im_Lab2sRGB @ im_LCh2Lab @ im_clip2f],
401	[LCH, LABQ, im_Lab2LabQ @ im_LCh2Lab @ im_clip2f],
402	[LCH, LABS, im_LabQ2LabS @ im_Lab2LabQ @ im_LCh2Lab @ im_clip2f],
403
404	[UCS, B_W, im_sRGB2mono @ im_XYZ2sRGB @ im_UCS2XYZ @ im_clip2f],
405	[UCS, XYZ, im_UCS2XYZ @ im_clip2f],
406	[UCS, YXY, im_XYZ2Yxy @ im_Lab2XYZ @ im_UCS2Lab @ im_clip2f],
407	[UCS, LAB, im_UCS2Lab @ im_clip2f],
408	[UCS, LCH, im_UCS2LCh @ im_clip2f],
409	[UCS, UCS, image_set_type UCS],
410	[UCS, RGB, im_Lab2disp @ im_UCS2Lab @ im_clip2f],
411	[UCS, sRGB, im_Lab2sRGB @ im_UCS2Lab @ im_clip2f],
412	[UCS, LABQ, im_Lab2LabQ @ im_UCS2Lab @ im_clip2f],
413	[UCS, LABS, im_LabQ2LabS @ im_Lab2LabQ @ im_UCS2Lab @ im_clip2f],
414
415	[RGB, B_W, im_sRGB2mono @ im_XYZ2sRGB @ im_disp2XYZ @ im_clip],
416	[RGB, XYZ, im_disp2XYZ @ im_clip],
417	[RGB, YXY, im_XYZ2Yxy @ im_disp2XYZ @ im_clip],
418	[RGB, LAB, im_disp2Lab @ im_clip],
419	[RGB, LCH, im_Lab2LCh @ im_disp2Lab @ im_clip],
420	[RGB, UCS, im_Lab2UCS @ im_disp2Lab @ im_clip],
421	[RGB, RGB, image_set_type RGB],
422	[RGB, sRGB, im_XYZ2sRGB @ im_disp2XYZ @ im_clip],
423	[RGB, LABQ, im_Lab2LabQ @ im_disp2Lab @ im_clip],
424	[RGB, LABS, im_LabQ2LabS @ im_Lab2LabQ @ im_disp2Lab @ im_clip],
425
426	[sRGB, B_W, im_sRGB2mono],
427	[sRGB, XYZ, im_sRGB2XYZ @ im_clip],
428	[sRGB, YXY, im_XYZ2Yxy @ im_sRGB2XYZ @ im_clip],
429	[sRGB, LAB, im_sRGB2Lab @ im_clip],
430	[sRGB, LCH, im_Lab2LCh @ im_sRGB2Lab @ im_clip],
431	[sRGB, UCS, im_XYZ2UCS @ im_sRGB2XYZ @ im_clip],
432	[sRGB, RGB, im_XYZ2disp @ im_sRGB2XYZ @ im_clip],
433	[sRGB, sRGB, image_set_type sRGB],
434	[sRGB, LABQ, im_Lab2LabQ @ im_sRGB2Lab @ im_clip],
435	[sRGB, LABS, im_LabQ2LabS @ im_Lab2LabQ @ im_sRGB2Lab @ im_clip],
436
437	[LABQ, B_W, im_sRGB2mono @ im_Lab2sRGB @ im_LabQ2Lab],
438	[LABQ, XYZ, im_Lab2XYZ @ im_LabQ2Lab],
439	[LABQ, YXY, im_XYZ2Yxy @ im_Lab2XYZ @ im_LabQ2Lab],
440	[LABQ, LAB, im_LabQ2Lab],
441	[LABQ, LCH, im_Lab2LCh @ im_LabQ2Lab],
442	[LABQ, UCS, im_Lab2UCS @ im_LabQ2Lab],
443	[LABQ, RGB, im_LabQ2disp],
444	[LABQ, sRGB, im_Lab2sRGB @ im_LabQ2Lab],
445	[LABQ, LABQ, image_set_type LABQ],
446	[LABQ, LABS, im_LabQ2LabS],
447
448	[LABS, B_W, im_sRGB2mono @ im_Lab2sRGB @ im_LabQ2Lab @
449		im_LabS2LabQ @ im_clip2s],
450	[LABS, XYZ, im_Lab2XYZ @ im_LabQ2Lab @ im_LabS2LabQ @ im_clip2s],
451	[LABS, YXY, im_XYZ2Yxy @
452		im_Lab2XYZ @ im_LabQ2Lab @ im_LabS2LabQ @ im_clip2s],
453	[LABS, LAB, im_LabS2Lab],
454	[LABS, LCH, im_Lab2LCh @ im_LabQ2Lab @ im_LabS2LabQ @ im_clip2s],
455	[LABS, UCS, im_Lab2UCS @ im_LabQ2Lab @ im_LabS2LabQ @ im_clip2s],
456	[LABS, RGB, im_LabQ2disp @ im_LabS2LabQ @ im_clip2s],
457	[LABS, sRGB, im_XYZ2sRGB @
458		im_Lab2XYZ @ im_LabQ2Lab @ im_LabS2LabQ @ im_clip2s],
459	[LABS, LABQ, im_LabS2LabQ @ im_clip2s],
460	[LABS, LABS, image_set_type LABS]
461]
462{
463	/* From Image_type ... repeat here for brevity. Use same ordering as
464	 * in Colour menu for consistency.
465	 */
466	B_W = 1;
467	XYZ = 12;
468	YXY = 23;
469	LAB = 13;
470	LCH = 19;
471	UCS = 18;
472	RGB = 17;
473	sRGB = 22;
474	LABQ = 16;
475	LABS = 21;
476}
477
478/* Transform between two colour spaces.
479 */
480colour_transform from to in
481	= colour_unary _colour_conversion_table?i?2 in, i >= 0
482	= error (_ "unable to convert " ++ Image_type.type_names.get_name from ++
483		_ " to " ++ Image_type.type_names.get_name to)
484{
485	match x = x?0 == from && x?1 == to;
486	i = index match _colour_conversion_table;
487}
488
489/* Transform to a colour space, assuming the type field in the input is
490 * correct
491 */
492colour_transform_to to in = colour_transform (get_type in) to in;
493
494/* Given a list of things, try to make them all the same size. Don't change
495 * the format. Don't touch non-image things.
496 */
497size_alike l
498	= map enlarge l
499{
500	max_width = foldr (test_prop has_width get_width) 0 l;
501	max_height = foldr (test_prop has_height get_height) 0 l;
502
503	test_prop has get x best
504		= best, !has x
505		= max_pair best (get x);
506
507	enlarge x
508		= embed 0 0 0 max_width max_height x, has_width x
509		= x;
510}
511
512/* Given a list of things, look for 1 band objects and bump them to to n -
513 * band objects, where n is the maximum number of bands. Don't change the
514 * format. Don't touch non-image things.
515 */
516bands_alike l
517	= map upband l
518{
519	max_bands = foldr (test_prop has_bands get_bands) 0 l;
520
521	test_prop has get x best
522		= best, !has x
523		= max_pair best (get x);
524
525	upband x
526		= bandjoin (replicate max_bands x),
527			has_bands x && get_bands x == 1
528		= x;
529}
530