1 #include "snd.h"
2 
3 typedef struct {
4   int size;
5   char *name;
6   rgb_t *r, *g, *b;
7   Xen lambda;
8   int gc_loc;
9   mus_float_t **(*make_rgb)(int size, Xen func);
10   void (*get_rgb)(double x, rgb_t *r, rgb_t *g, rgb_t *b);
11 } cmap;
12 
13 static cmap **cmaps = NULL;
14 static int cmaps_size = 0;
15 
16 #define no_such_colormap Xen_make_error_type("no-such-colormap")
17 
18 
is_colormap(int n)19 bool is_colormap(int n)
20 {
21   return((n >= 0) &&
22 	 (n < cmaps_size) &&
23 	 (cmaps[n]));
24 }
25 
26 
colormap_name(int n)27 char *colormap_name(int n)
28 {
29   if (is_colormap(n))
30     return(cmaps[n]->name);
31   return(NULL);
32 }
33 
34 
num_colormaps(void)35 int num_colormaps(void)
36 {
37   int i;
38   for (i = cmaps_size - 1; i >= 0; i--)
39     if (cmaps[i])
40       return(i + 1);
41   return(0);
42 }
43 
44 
delete_cmap(int index)45 static cmap *delete_cmap(int index)
46 {
47   if (is_colormap(index))
48     {
49       cmap *c;
50       c = cmaps[index];
51       if (c->r) free(c->r);
52       if (c->g) free(c->g);
53       if (c->b) free(c->b);
54       if (c->name) free(c->name);
55       if (Xen_is_procedure(c->lambda))
56 	snd_unprotect_at(c->gc_loc);
57       free(c);
58       cmaps[index] = NULL;
59     }
60   return(NULL);
61 }
62 
63 
mus_float_ts_to_rgb_t(int size,mus_float_t * data)64 static rgb_t *mus_float_ts_to_rgb_t(int size, mus_float_t *data)
65 {
66   int i;
67   rgb_t *new_data;
68   new_data = (rgb_t *)calloc(size, sizeof(rgb_t));
69   for (i = 0; i < size; i++)
70     new_data[i] = float_to_rgb(data[i]);
71   return(new_data);
72 }
73 
74 
rebuild_colormap(cmap * c)75 static void rebuild_colormap(cmap *c)
76 {
77   mus_float_t **rgb;
78   int i;
79   /* release old colormap data */
80   if (c->r) free(c->r);
81   if (c->g) free(c->g);
82   if (c->b) free(c->b);
83   c->size = color_map_size(ss);
84   /* make new data */
85   rgb = (*(c->make_rgb))(c->size, c->lambda);
86   c->r = mus_float_ts_to_rgb_t(c->size, rgb[0]);
87   c->g = mus_float_ts_to_rgb_t(c->size, rgb[1]);
88   c->b = mus_float_ts_to_rgb_t(c->size, rgb[2]);
89   for (i = 0; i < 3; i++) free(rgb[i]);
90   free(rgb);
91 }
92 
93 
get_current_color(int index,int n,rgb_t * r,rgb_t * g,rgb_t * b)94 void get_current_color(int index, int n, rgb_t *r, rgb_t *g, rgb_t *b)
95 {
96   if (is_colormap(index))
97     {
98       cmap *c;
99       c = cmaps[index];
100       if (c->get_rgb)
101 	(c->get_rgb)((double)n / (double)color_map_size(ss), r, g, b);
102       else
103 	{
104 	  if (color_map_size(ss) != c->size)
105 	    rebuild_colormap(c);
106 	  if ((n >= 0) && (n < c->size))
107 	    {
108 	      (*r) = c->r[n];
109 	      (*g) = c->g[n];
110 	      (*b) = c->b[n];
111 	    }
112 	}
113     }
114 }
115 
116 #if HAVE_GL
color_map_reds(int index)117 rgb_t *color_map_reds(int index)
118 {
119   if (is_colormap(index))
120     {
121       cmap *c;
122       c = cmaps[index];
123       if (c->get_rgb) return(NULL);
124       if (color_map_size(ss) != c->size)
125 	rebuild_colormap(c);
126       return(c->r);
127     }
128   return(NULL);
129 }
130 
131 
color_map_greens(int index)132 rgb_t *color_map_greens(int index)
133 {
134   if (is_colormap(index))
135     {
136       cmap *c;
137       c = cmaps[index];
138       if (c->get_rgb) return(NULL);
139       if (color_map_size(ss) != c->size)
140 	rebuild_colormap(c);
141       return(c->g);
142     }
143   return(NULL);
144 }
145 
146 
color_map_blues(int index)147 rgb_t *color_map_blues(int index)
148 {
149   if (is_colormap(index))
150     {
151       cmap *c;
152       c = cmaps[index];
153       if (c->get_rgb) return(NULL);
154       if (color_map_size(ss) != c->size)
155 	rebuild_colormap(c);
156       return(c->b);
157     }
158   return(NULL);
159 }
160 #endif
161 
162 
new_cmap(const char * name,int size,mus_float_t ** rgb)163 static cmap *new_cmap(const char *name, int size, mus_float_t **rgb)
164 {
165   cmap *c;
166   c = (cmap *)calloc(1, sizeof(cmap));
167   c->name = mus_strdup(name);
168   c->size = size;
169   if (rgb)
170     {
171       c->r = mus_float_ts_to_rgb_t(size, rgb[0]);
172       c->g = mus_float_ts_to_rgb_t(size, rgb[1]);
173       c->b = mus_float_ts_to_rgb_t(size, rgb[2]);
174     }
175   c->lambda = Xen_false;
176   c->gc_loc = NOT_A_GC_LOC;
177   return(c);
178 }
179 
180 
make_builtin_cmap(int size,const char * name,mus_float_t ** (* make_rgb)(int size,Xen ignored),void (* get_rgb)(double x,rgb_t * r,rgb_t * g,rgb_t * b))181 static cmap *make_builtin_cmap(int size, const char *name,
182 			       mus_float_t **(*make_rgb)(int size, Xen ignored),
183 			       void (*get_rgb)(double x, rgb_t *r, rgb_t *g, rgb_t *b))
184 {
185   mus_float_t **rgb = NULL;
186   cmap *c = NULL;
187   if ((make_rgb) && (!get_rgb))
188     rgb = make_rgb(size, Xen_false);
189   c = new_cmap(name, size, rgb);
190   c->get_rgb = get_rgb;
191   c->make_rgb = make_rgb;
192   if (rgb)
193     {
194       int i;
195       for (i = 0; i < 3; i++) free(rgb[i]);
196       free(rgb);
197     }
198   return(c);
199 }
200 
201 
make_base_rgb(int size)202 static mus_float_t **make_base_rgb(int size)
203 {
204   mus_float_t **rgb;
205   int i;
206   rgb = (mus_float_t **)calloc(3, sizeof(mus_float_t *));
207   for (i = 0; i < 3; i++) rgb[i] = (mus_float_t *)calloc(size, sizeof(mus_float_t));
208   return(rgb);
209 }
210 
211 
212 static char *add_colormap_func_error_msg = NULL;
213 static bool add_colormap_func_hit_error = false;
214 
add_colormap_func_error(const char * msg,void * data)215 static void add_colormap_func_error(const char *msg, void *data)
216 {
217   add_colormap_func_hit_error = true;
218   add_colormap_func_error_msg = mus_strdup(msg); /* msg itself is freed by the error handler in snd-xen.c */
219 }
220 
221 
make_xen_colormap(int size,Xen lambda)222 static mus_float_t **make_xen_colormap(int size, Xen lambda)
223 {
224   Xen xrgb;
225   mus_float_t **rgb = NULL;
226   add_colormap_func_hit_error = false;
227   redirect_xen_error_to(add_colormap_func_error, NULL);
228   xrgb = Xen_call_with_1_arg(lambda,
229 		    C_int_to_Xen_integer(size),
230 		    S_add_colormap);
231   redirect_xen_error_to(NULL, NULL);
232   if (add_colormap_func_hit_error)
233     {
234       Xen str;
235       if (add_colormap_func_error_msg)
236 	{
237 	  str = C_string_to_Xen_string(add_colormap_func_error_msg);
238 	  free(add_colormap_func_error_msg);
239 	  add_colormap_func_error_msg = NULL;
240 	}
241       else str = Xen_false;
242 
243       Xen_error(Xen_make_error_type("colormap-error"),
244 		Xen_list_2(C_string_to_Xen_string(S_add_colormap ": function error ~A"),
245 			   str));
246     }
247 
248   if (!(Xen_is_list(xrgb)))
249     Xen_error(Xen_make_error_type("colormap-error"),
250 	      Xen_list_3(C_string_to_Xen_string(S_add_colormap ": colormap function, ~A, returned ~A, but should return a list of 3 " S_vct "s"),
251 			 lambda,
252 			 xrgb));
253   else
254     {
255       vct *xr, *xg, *xb;
256       mus_float_t *xrdata, *xgdata, *xbdata;
257       int i, gc_loc;
258 
259       /* user-defined colormap func returns a list of 3 vcts (r g b) */
260       gc_loc = snd_protect(xrgb);
261 
262       if (!(mus_is_vct(Xen_list_ref(xrgb, 0))))
263 	Xen_error(Xen_make_error_type("colormap-error"),
264 		  Xen_list_2(C_string_to_Xen_string(S_add_colormap ": function did not return a list of " S_vct "s! ~A"),
265 			     xrgb));
266 
267       xr = Xen_to_vct(Xen_list_ref(xrgb, 0));
268       xrdata = mus_vct_data(xr);
269       if (mus_vct_length(xr) < size)
270 	Xen_error(Xen_make_error_type("colormap-error"),
271 		  Xen_list_2(C_string_to_Xen_string(S_add_colormap ": function did not return a list of " S_vct "s of the correct size: ~A"),
272 			     xrgb));
273 
274       xg = Xen_to_vct(Xen_list_ref(xrgb, 1));
275       xgdata = mus_vct_data(xg);
276       xb = Xen_to_vct(Xen_list_ref(xrgb, 2));
277       xbdata = mus_vct_data(xb);
278       rgb = make_base_rgb(size);
279       for (i = 0; i < size; i++)
280 	{
281 	  rgb[0][i] = xrdata[i];
282 	  rgb[1][i] = xgdata[i];
283 	  rgb[2][i] = xbdata[i];
284 	}
285 
286       snd_unprotect_at(gc_loc);
287     }
288   return(rgb);
289 }
290 
291 
add_colormap(const char * name,Xen func)292 static int add_colormap(const char *name, Xen func)
293 {
294   cmap *c;
295   mus_float_t **rgb;
296   int index = -1, i, loc;
297   for (i = 0; i < cmaps_size; i++)
298     if (!(cmaps[i]))
299       {
300 	index = i;
301 	break;
302       }
303   if (index == -1) /* no free slot */
304     {
305       index = cmaps_size;
306       cmaps_size += 8;
307       cmaps = (cmap **)realloc(cmaps, cmaps_size * sizeof(cmap *));
308       for (i = index; i < cmaps_size; i++) cmaps[i] = NULL;
309     }
310   loc = snd_protect(func);
311   rgb = make_xen_colormap(color_map_size(ss), func);
312   c = new_cmap(name, color_map_size(ss), rgb);
313   c->make_rgb = make_xen_colormap;
314   c->lambda = func;
315   c->gc_loc = loc;
316   for (i = 0; i < 3; i++) free(rgb[i]);
317   free(rgb);
318   cmaps[index] = c;
319   return(index);
320 }
321 
322 
make_black_and_white_colormap(int size,Xen ignored)323 static mus_float_t **make_black_and_white_colormap(int size, Xen ignored)
324 {
325   /* (r 0) (g 0) (b 0) */
326   return(make_base_rgb(size));
327 }
328 
329 
330 #define black_and_white_rgb NULL
331 
332 /* colormap functions taken mostly from (GPL) octave-forge code written by Kai Habel <kai.habel@gmx.de> */
333 
make_gray_colormap(int size,Xen ignored)334 static mus_float_t **make_gray_colormap(int size, Xen ignored)
335 {
336   /* (r x) (g x) (b x) */
337   mus_float_t **rgb;
338   int i;
339   mus_float_t x, incr;
340   rgb = make_base_rgb(size);
341   incr = 1.0 / (mus_float_t)size;
342   for (i = 0, x = 0.0; i < size; i++, x += incr)
343     {
344       rgb[0][i] = x;
345       rgb[1][i] = x;
346       rgb[2][i] = x;
347     }
348   return(rgb);
349 }
350 
351 
352 #define gray_rgb NULL
353 
make_autumn_colormap(int size,Xen ignored)354 static mus_float_t **make_autumn_colormap(int size, Xen ignored)
355 {
356   /* (r 1.0) (g x) (b 0.0) */
357   mus_float_t **rgb;
358   int i;
359   mus_float_t x, incr;
360   rgb = make_base_rgb(size);
361   incr = 1.0 / (mus_float_t)size;
362   for (i = 0, x = 0.0; i < size; i++, x += incr)
363     {
364       rgb[0][i] = 1.0;
365       rgb[1][i] = x;
366       rgb[2][i] = 0.0;
367     }
368   return(rgb);
369 }
370 
371 
372 #define autumn_rgb NULL
373 
374 
make_spring_colormap(int size,Xen ignored)375 static mus_float_t **make_spring_colormap(int size, Xen ignored)
376 {
377   /* (r 1.0) (g x) (b (- 1.0 x)) */
378   mus_float_t **rgb;
379   int i;
380   mus_float_t x, incr;
381   rgb = make_base_rgb(size);
382   incr = 1.0 / (mus_float_t)size;
383   for (i = 0, x = 0.0; i < size; i++, x += incr)
384     {
385       rgb[0][i] = 1.0;
386       rgb[1][i] = x;
387       rgb[2][i] = 1.0 - x;
388     }
389   return(rgb);
390 }
391 
392 
393 #define spring_rgb NULL
394 
395 
make_winter_colormap(int size,Xen ignored)396 static mus_float_t **make_winter_colormap(int size, Xen ignored)
397 {
398   /* (r 0.0) (g x) (b (- 1.0 (/ x 2))) */
399   mus_float_t **rgb;
400   int i;
401   mus_float_t x, incr;
402   rgb = make_base_rgb(size);
403   incr = 1.0 / (mus_float_t)size;
404   for (i = 0, x = 0.0; i < size; i++, x += incr)
405     {
406       rgb[0][i] = 0.0;
407       rgb[1][i] = x;
408       rgb[2][i] = 1.0 - (x * 0.5);
409     }
410   return(rgb);
411 }
412 
413 
414 #define winter_rgb NULL
415 
416 
make_summer_colormap(int size,Xen ignored)417 static mus_float_t **make_summer_colormap(int size, Xen ignored)
418 {
419   /* (r x) (g (+ 0.5 (/ x 2))) (b 0.4) */
420   mus_float_t **rgb;
421   int i;
422   mus_float_t x, incr;
423   rgb = make_base_rgb(size);
424   incr = 1.0 / (mus_float_t)size;
425   for (i = 0, x = 0.0; i < size; i++, x += incr)
426     {
427       rgb[0][i] = x;
428       rgb[1][i] = 0.5 + (0.5 * x);
429       rgb[2][i] = 0.4;
430     }
431   return(rgb);
432 }
433 
434 
435 #define summer_rgb NULL
436 
437 
make_cool_colormap(int size,Xen ignored)438 static mus_float_t **make_cool_colormap(int size, Xen ignored)
439 {
440   /* (r x) (g (- 1.0 x)) (b 1.0) */
441   mus_float_t **rgb;
442   int i;
443   mus_float_t x, incr;
444   rgb = make_base_rgb(size);
445   incr = 1.0 / (mus_float_t)size;
446   for (i = 0, x = 0.0; i < size; i++, x += incr)
447     {
448       rgb[0][i] = x;
449       rgb[1][i] = 1.0 - x;
450       rgb[2][i] = 1.0;
451     }
452   return(rgb);
453 }
454 
455 
456 #define cool_rgb NULL
457 
458 
make_copper_colormap(int size,Xen ignored)459 static mus_float_t **make_copper_colormap(int size, Xen ignored)
460 {
461   /* (r (if (< x 4/5) (* 5/4 x) 1.0)) (g (* 4/5 x)) (b (* 1/2 x)) */
462   mus_float_t **rgb;
463   int i;
464   mus_float_t x, incr;
465   rgb = make_base_rgb(size);
466   incr = 1.0 / (mus_float_t)size;
467   for (i = 0, x = 0.0; i < size; i++, x += incr)
468     {
469       rgb[0][i] = (x < 0.8) ? (1.25 * x) : 1.0;
470       rgb[1][i] = 0.8 * x;
471       rgb[2][i] = 0.5 * x;
472     }
473   return(rgb);
474 }
475 
476 
477 #define copper_rgb NULL
478 
make_flag_colormap(int size,Xen ignored)479 static mus_float_t **make_flag_colormap(int size, Xen ignored)
480 {
481   /* (r (if (or (= k 0) (= k 1)) 1.0 0.0)) (g (if (= k 1) 1.0 0.0)) (b (if (or (= k 1) (= k 2)) 1.0 0.0)) */
482   mus_float_t **rgb;
483   int i, k = 0;
484   rgb = make_base_rgb(size);
485   for (i = 0; i < size; i++)
486     {
487       rgb[0][i] = (k < 2) ? 1.0 : 0.0;
488       rgb[1][i] = (k == 1) ? 1.0 : 0.0;
489       rgb[2][i] = ((k == 1) || (k == 2)) ? 1.0 : 0.0;
490       k++;
491       if (k == 4) k = 0;
492     }
493   return(rgb);
494 }
495 
496 
497 #define flag_rgb NULL
498 
499 
make_prism_colormap(int size,Xen ignored)500 static mus_float_t **make_prism_colormap(int size, Xen ignored)
501 {
502   /* (r (list-ref (list 1 1 1 0 0 2/3) k)) (g (list-ref (list 0 1/2 1 1 0 0) k)) (b (list-ref (list 0 0 0 0 1 1) k)) */
503   mus_float_t **rgb;
504   int i, k = 0;
505   mus_float_t rs[6] = {1.0, 1.0, 1.0, 0.0, 0.0, 0.6667};
506   mus_float_t gs[6] = {0.0, 0.5, 1.0, 1.0, 0.0, 0.0};
507   mus_float_t bs[6] = {0.0, 0.0, 0.0, 0.0, 1.0, 1.0};
508   rgb = make_base_rgb(size);
509   for (i = 0; i < size; i++)
510     {
511       rgb[0][i] = rs[k];
512       rgb[1][i] = gs[k];
513       rgb[2][i] = bs[k];
514       k++;
515       if (k == 6) k = 0;
516     }
517   return(rgb);
518 }
519 
520 
521 #define prism_rgb NULL
522 
523 
make_bone_colormap(int size,Xen ignored)524 static mus_float_t **make_bone_colormap(int size, Xen ignored)
525 {
526   /* (r (if (< x 3/4) (* 7/8 x) (- (* 11/8 x) 3/8)))
527      (g (if (< x 3/8) (* 7/8 x) (if (< x 3/4) (- (* 29/24 x) 1/8) (+ (* 7/8 x) 1/8))))
528      (b (if (< x 3/8) (* 29/24 x) (+ (* 7/8 x) 1/8)))
529   */
530   mus_float_t **rgb;
531   int i;
532   mus_float_t x, incr;
533   rgb = make_base_rgb(size);
534   incr = 1.0 / (mus_float_t)size;
535   for (i = 0, x = 0.0; i < size; i++, x += incr)
536     {
537       rgb[0][i] = (x < .75) ? (x * .875) : ((x * 11.0 / 8.0) - .375);
538       rgb[1][i] = (x < .375) ? (x * .875) : ((x < .75) ? ((x * 29.0 / 24.0) - .125) : ((x * .875) + .125));
539       rgb[2][i] = (x < .375) ? (x * 29.0 / 24.0) : ((x * .875) + .125);
540     }
541   return(rgb);
542 }
543 
544 
545 #define bone_rgb NULL
546 
547 
make_hot_colormap(int size,Xen ignored)548 static mus_float_t **make_hot_colormap(int size, Xen ignored)
549 {
550   /* (mimicking matlab here, not octave)
551      (r (if (< x 3/8) (* 8/3 x) 1.0))
552      (g (if (< x 3/8) 0.0 (if (< x 3/4) (- (* 8/3 x) 1.0) 1.0)))
553      (b (if (< x 3/4) 0.0 (- (* 4 x) 3)))
554   */
555   mus_float_t **rgb;
556   int i;
557   mus_float_t x, incr;
558   rgb = make_base_rgb(size);
559   incr = 1.0 / (mus_float_t)size;
560   for (i = 0, x = 0.0; i < size; i++, x += incr)
561     {
562       rgb[0][i] = (x < .375) ? (x * 8.0 / 3.0) : 1.0;
563       rgb[1][i] = (x < .375) ? 0.0 : ((x < .75) ? ((x * 8.0 / 3.0) - 1.0) : 1.0);
564       rgb[2][i] = (x < .75) ? 0.0 : ((x * 4.0) - 3.0);
565     }
566   return(rgb);
567 }
568 
569 
570 #define hot_rgb NULL
571 
572 
make_jet_colormap(int size,Xen ignored)573 static mus_float_t **make_jet_colormap(int size, Xen ignored)
574 {
575   /*
576      (r (if (< x 3/8) 0.0 (if (< x 5/8) (- (* 4 x) 3/2) (if (< x 7/8) 1.0 (+ (* -4 x) 9/2)))))
577      (g (if (< x 1/8) 0.0 (if (< x 3/8)	(- (* 4 x) 1/2)	(if (< x 5/8) 1.0 (if (< x 7/8)	(+ (* -4 x) 7/2) 0.0)))))
578      (b (if (< x 1/8) (+ (* 4 x) 1/2) (if (< x 3/8) 1.0	(if (< x 5/8) (+ (* -4 x) 5/2) 0.0))))
579   */
580   mus_float_t **rgb;
581   int i;
582   mus_float_t x, incr;
583   rgb = make_base_rgb(size);
584   incr = 1.0 / (mus_float_t)size;
585   for (i = 0, x = 0.0; i < size; i++, x += incr)
586     {
587       rgb[0][i] = (x < .375) ? 0.0 : ((x < .625) ? ((x * 4.0) - 1.5) : ((x < .875) ? 1.0 : ((x * -4.0) + 4.5)));
588       rgb[1][i] = (x < .125) ? 0.0 : ((x < .375) ? ((x * 4.0) - 0.5) : ((x < .625) ? 1.0 : ((x < .875) ? ((x * -4.0) + 3.5) : 0.0)));
589       rgb[2][i] = (x < .125) ? ((x * 4.0) + 0.5) : ((x < .375) ? 1.0 : ((x < .625) ? ((x * -4.0) + 2.5) : 0.0));
590     }
591   return(rgb);
592 }
593 
594 
595 #define jet_rgb NULL
596 
597 
make_pink_colormap(int size,Xen ignored)598 static mus_float_t **make_pink_colormap(int size, Xen ignored)
599 {
600   /* matlab uses log here, or something like that -- this version is quite different
601      (r (if (< x 3/8) (* 14/9 x) (+ (* 2/3 x) 1/3)))
602      (g (if (< x 3/8) (* 2/3 x) (if (< x 3/4) (- (* 14/9 x) 1/3) (+ (* 2/3 x) 1/3))))
603      (b (if (< x 3/4) (* 2/3 x) (- (* 2 x) 1)))
604   */
605   mus_float_t **rgb;
606   int i;
607   mus_float_t x, incr;
608   rgb = make_base_rgb(size);
609   incr = 1.0 / (mus_float_t)size;
610   for (i = 0, x = 0.0; i < size; i++, x += incr)
611     {
612       rgb[0][i] = (x < .375) ? (x * 14.0 / 9.0) : ((x * 2.0 / 3.0) + 1.0 / 3.0);
613       rgb[1][i] = (x < .375) ? (x * 2.0 / 3.0) : ((x < .75) ? ((x * 14.0 / 9.0) - 1.0 / 3.0) : ((x * 2.0 / 3.0) + 1.0 / 3.0));
614       rgb[2][i] = (x < .75) ? (x * 2.0 / 3.0) : ((x * 2.0) - 1.0);
615     }
616   return(rgb);
617 }
618 
619 
620 #define pink_rgb NULL
621 
622 
make_rainbow_colormap(int size,Xen ignored)623 static mus_float_t **make_rainbow_colormap(int size, Xen ignored)
624 {
625   /*
626      (r (if (< x 2/5) 1.0 (if (< x 3/5) (+ (* -5 x) 3) (if (< x 4/5) 0.0 (- (* 10/3 x) 8/3)))))
627      (g (if (< x 2/5) (* 5/2 x) (if (< x 3/5) 1.0 (if (< x 4/5) (+ (* -5 x) 4) 0.0))))
628      (b (if (< x 3/5) 0.0 (if (< x 4/5)	(- (* 5 x) 3) 1.0)))
629   */
630   mus_float_t **rgb;
631   int i;
632   mus_float_t x, incr;
633   rgb = make_base_rgb(size);
634   incr = 1.0 / (mus_float_t)size;
635   for (i = 0, x = 0.0; i < size; i++, x += incr)
636     {
637       rgb[0][i] = (x < .4) ? 1.0 : ((x < .6) ? ((x * -5.0) + 3.0) : ((x < .8) ? 0.0 : ((x * 10.0 / 3.0) - 8.0 / 3.0)));
638       rgb[1][i] = (x < .4) ? (x * 2.5) : ((x < .6) ? 1.0 : ((x < .8) ? ((x * -5.0) + 4.0) : 0.0));
639       rgb[2][i] = (x < .6) ? 0.0 : ((x < .8) ? ((x * 5.0) - 3.0) : 1.0);
640     }
641   return(rgb);
642 }
643 
644 
645 #define rainbow_rgb NULL
646 
647 
make_phases_colormap(int size,Xen ignored)648 static mus_float_t **make_phases_colormap(int size, Xen ignored)
649 {
650   /* 0 and pi: blue->green, pi/2 and 3pi/2: red->black */
651   mus_float_t **rgb;
652   int i;
653   mus_float_t x, incr;
654   rgb = make_base_rgb(size);
655   incr = (2.0 * M_PI) / (mus_float_t)size;
656   for (i = 0, x = 0.0; i < size; i++, x += incr)
657     {
658       if (x <= 0.5 * M_PI)
659 	{
660 	  rgb[0][i] = x / (0.5 * M_PI);
661 	  rgb[1][i] = 0.0;
662 	  rgb[2][i] = 1.0 - rgb[0][i];
663 	}
664       else
665 	{
666 	  if (x <= M_PI)
667 	    {
668 	      rgb[0][i] = 1.0 - ((x - 0.5 * M_PI) / (0.5 * M_PI));
669 	      rgb[1][i] = 1.0 - rgb[0][i];
670 	      rgb[2][i] = 0.0;
671 	    }
672 	  else
673 	    {
674 	      if (x <= 1.5 * M_PI)
675 		{
676 		  rgb[0][i] = 0.0;
677 		  rgb[1][i] = 1.0 - ((x - M_PI) / (0.5 * M_PI));
678 		  rgb[2][i] = 0.0;
679 		}
680 	      else
681 		{
682 		  rgb[0][i] = 0.0;
683 		  rgb[1][i] = 1.0 - ((x - (1.5 * M_PI)) / (0.5 * M_PI));
684 		  rgb[2][i] = 0.0;
685 		}
686 	    }
687 	}
688     }
689   return(rgb);
690 }
691 
692 
693 #define phases_rgb NULL
694 
695 
696 /* ---------------------------------------- colormap objects ---------------------------------------- */
697 
698 typedef struct {
699   int n;
700 } xen_colormap;
701 
702 
703 #define Xen_to_xen_colormap(arg) ((xen_colormap *)Xen_object_ref(arg))
704 
xen_colormap_to_int(Xen n)705 static int xen_colormap_to_int(Xen n)
706 {
707   xen_colormap *col;
708   col = Xen_to_xen_colormap(n);
709   return(col->n);
710 }
711 
712 #define Xen_colormap_to_C_int(n) xen_colormap_to_int(n)
713 
714 
715 static Xen_object_type_t xen_colormap_tag;
716 
xen_is_colormap(Xen obj)717 static bool xen_is_colormap(Xen obj)
718 {
719   return(Xen_c_object_is_type(obj, xen_colormap_tag));
720 }
721 
722 #if (!HAVE_SCHEME)
xen_colormap_free(xen_colormap * v)723 static void xen_colormap_free(xen_colormap *v) {if (v) free(v);}
724 
Xen_wrap_free(xen_colormap,free_xen_colormap,xen_colormap_free)725 Xen_wrap_free(xen_colormap, free_xen_colormap, xen_colormap_free)
726 #else
727 static s7_pointer s7_xen_colormap_free(s7_scheme *sc, s7_pointer obj)
728 {
729   xen_colormap *v;
730   v = (xen_colormap *)s7_c_object_value(obj);
731   if (v) free(v);
732   return(NULL);
733 }
734 #endif
735 
736 static char *xen_colormap_to_string(xen_colormap *v)
737 {
738   #define COLORMAP_PRINT_BUFFER_SIZE 64
739   char *buf;
740   if (!v) return(NULL);
741   buf = (char *)calloc(COLORMAP_PRINT_BUFFER_SIZE, sizeof(char));
742   snprintf(buf, COLORMAP_PRINT_BUFFER_SIZE, "#<colormap %s>", colormap_name(v->n));
743   return(buf);
744 }
745 
746 
747 #if HAVE_FORTH || HAVE_RUBY
Xen_wrap_print(xen_colormap,print_xen_colormap,xen_colormap_to_string)748 Xen_wrap_print(xen_colormap, print_xen_colormap, xen_colormap_to_string)
749 #define S_xen_colormap_to_string "colormap->string"
750 
751 static Xen g_xen_colormap_to_string(Xen obj)
752 {
753   char *vstr;
754   Xen result;
755   Xen_check_type(xen_is_colormap(obj), obj, 1, S_xen_colormap_to_string, "a colormap");
756   vstr = xen_colormap_to_string(Xen_to_xen_colormap(obj));
757   result = C_string_to_Xen_string(vstr);
758   free(vstr);
759   return(result);
760 }
761 #else
762 #if HAVE_SCHEME
g_xen_colormap_to_string(s7_scheme * sc,s7_pointer args)763 static s7_pointer g_xen_colormap_to_string(s7_scheme *sc, s7_pointer args)
764 {
765   char *vstr;
766   s7_pointer result;
767   vstr = xen_colormap_to_string(Xen_to_xen_colormap(s7_car(args)));
768   result = C_string_to_Xen_string(vstr);
769   free(vstr);
770   return(result);
771 }
772 #endif
773 #endif
774 
775 #if (!HAVE_SCHEME)
xen_colormap_equalp(xen_colormap * v1,xen_colormap * v2)776 static bool xen_colormap_equalp(xen_colormap *v1, xen_colormap *v2)
777 {
778   return((v1 == v2) ||
779 	 (v1->n == v2->n));
780 }
781 
equalp_xen_colormap(Xen obj1,Xen obj2)782 static Xen equalp_xen_colormap(Xen obj1, Xen obj2)
783 {
784   if ((!(xen_is_colormap(obj1))) || (!(xen_is_colormap(obj2)))) return(Xen_false);
785   return(C_bool_to_Xen_boolean(xen_colormap_equalp(Xen_to_xen_colormap(obj1), Xen_to_xen_colormap(obj2))));
786 }
787 #endif
788 
789 
xen_colormap_make(int n)790 static xen_colormap *xen_colormap_make(int n)
791 {
792   xen_colormap *new_v;
793   new_v = (xen_colormap *)malloc(sizeof(xen_colormap));
794   new_v->n = n;
795   return(new_v);
796 }
797 
798 
new_xen_colormap(int n)799 static Xen new_xen_colormap(int n)
800 {
801   xen_colormap *mx;
802   if (n < 0)
803     return(Xen_false);
804 
805   mx = xen_colormap_make(n);
806   return(Xen_make_object(xen_colormap_tag, mx, 0, free_xen_colormap)); /* last 2 args ignored in s7 */
807 }
808 
809 #define C_int_to_Xen_colormap(Val) new_xen_colormap(Val)
810 
811 
812 #if HAVE_SCHEME
s7_xen_colormap_is_equal(s7_scheme * sc,s7_pointer args)813 static s7_pointer s7_xen_colormap_is_equal(s7_scheme *sc, s7_pointer args)
814 {
815   s7_pointer p1, p2;
816   p1 = s7_car(args);
817   p2 = s7_cadr(args);
818   if (p1 == p2) return(s7_t(sc));
819   if (s7_c_object_type(p2) == xen_colormap_tag)
820     return(s7_make_boolean(sc, (((xen_colormap *)s7_c_object_value(p1))->n == ((xen_colormap *)s7_c_object_value(p2))->n)));
821   return(s7_f(sc));
822 }
823 
s7_xen_colormap_length(s7_scheme * sc,Xen args)824 static Xen s7_xen_colormap_length(s7_scheme *sc, Xen args)
825 {
826   return(C_int_to_Xen_integer(color_map_size(ss)));
827 }
828 
829 
830 static Xen g_colormap_ref(Xen map, Xen pos);
s7_colormap_apply(s7_scheme * sc,Xen args1)831 static Xen s7_colormap_apply(s7_scheme *sc, Xen args1)
832 {
833   s7_pointer obj, args;
834   obj = s7_car(args1);
835   args = s7_cdr(args1);
836   if (!s7_is_pair(args))
837     s7_wrong_number_of_args_error(sc, "colormap ref", args);
838   return(g_colormap_ref(obj, Xen_car(args)));
839 }
840 #endif
841 
842 
init_xen_colormap(void)843 static void init_xen_colormap(void)
844 {
845 #if HAVE_SCHEME
846   xen_colormap_tag = s7_make_c_type(s7, "<colormap>");
847   s7_c_type_set_gc_free(s7, xen_colormap_tag, s7_xen_colormap_free);
848   s7_c_type_set_is_equal(s7, xen_colormap_tag, s7_xen_colormap_is_equal);
849   s7_c_type_set_length(s7, xen_colormap_tag, s7_xen_colormap_length);
850   s7_c_type_set_ref(s7, xen_colormap_tag, s7_colormap_apply);
851   s7_c_type_set_to_string(s7, xen_colormap_tag, g_xen_colormap_to_string);
852 #else
853 #if HAVE_RUBY
854   xen_colormap_tag = Xen_make_object_type("XenColormap", sizeof(xen_colormap));
855 #else
856   xen_colormap_tag = Xen_make_object_type("Colormap", sizeof(xen_colormap));
857 #endif
858 #endif
859 
860 #if HAVE_FORTH
861   fth_set_object_inspect(xen_colormap_tag,   print_xen_colormap);
862   fth_set_object_dump(xen_colormap_tag,      g_xen_colormap_to_string);
863   fth_set_object_equal(xen_colormap_tag,     equalp_xen_colormap);
864   fth_set_object_free(xen_colormap_tag,      free_xen_colormap);
865 #endif
866 
867 #if HAVE_RUBY
868   rb_define_method(xen_colormap_tag, "to_s",     Xen_procedure_cast print_xen_colormap, 0);
869   rb_define_method(xen_colormap_tag, "eql?",     Xen_procedure_cast equalp_xen_colormap, 1);
870   rb_define_method(xen_colormap_tag, "==",       Xen_procedure_cast equalp_xen_colormap, 1);
871   rb_define_method(xen_colormap_tag, "to_str",   Xen_procedure_cast g_xen_colormap_to_string, 0);
872 #endif
873 }
874 
875 
876 /* -------------------------------------------------------------------------------- */
877 
g_integer_to_colormap(Xen n)878 static Xen g_integer_to_colormap(Xen n)
879 {
880   #define H_integer_to_colormap "(" S_integer_to_colormap " n) returns a colormap object corresponding to the given integer"
881   int id;
882   Xen_check_type(Xen_is_integer(n), n, 1, S_integer_to_colormap, "an integer");
883   id = Xen_integer_to_C_int(n);
884   if (is_colormap(id))
885     return(new_xen_colormap(id));
886   return(Xen_false);
887 }
888 
889 
g_colormap_to_integer(Xen n)890 static Xen g_colormap_to_integer(Xen n)
891 {
892   #define H_colormap_to_integer "(" S_colormap_to_integer " id) returns the integer corresponding to the given colormap"
893   Xen_check_type(xen_is_colormap(n), n, 1, S_colormap_to_integer, "a colormap");
894   return(C_int_to_Xen_integer(xen_colormap_to_int(n)));
895 }
896 
897 
898 
g_colormap_ref(Xen map,Xen pos)899 static Xen g_colormap_ref(Xen map, Xen pos)
900 {
901   int index;
902   mus_float_t x;
903   rgb_t r = 0, g = 0, b = 0;
904 
905   #define H_colormap_ref "(" S_colormap_ref " colormap pos): (list r g b). Pos is between 0.0 and 1.0."
906 
907   Xen_check_type(xen_is_colormap(map), map, 1, S_colormap_ref, "a colormap object");
908   Xen_check_type(Xen_is_number(pos), pos, 2, S_colormap_ref, "a number between 0.0 and 1.0");
909 
910   index = Xen_colormap_to_C_int(map);
911   if (!(is_colormap(index)))
912     Xen_error(no_such_colormap,
913 	      Xen_list_2(C_string_to_Xen_string(S_colormap_ref ": no such colormap: ~A"),
914 			 map));
915 
916   x = Xen_real_to_C_double(pos);
917   if ((isnan(x)) || (x < 0.0) || (x > 1.0))
918     Xen_out_of_range_error(S_colormap_ref, 2, pos, "x must be between 0.0 and 1.0");
919 
920   get_current_color(index, (int)(color_map_size(ss) * x + 0.5), &r, &g, &b);
921   return(Xen_list_3(C_double_to_Xen_real(rgb_to_float(r)),
922 		    C_double_to_Xen_real(rgb_to_float(g)),
923 		    C_double_to_Xen_real(rgb_to_float(b))));
924 }
925 
926 /* can't use Colormap -- it's the X type name */
927 
928 
g_colormap(void)929 static Xen g_colormap(void)
930 {
931   #define H_colormap "(" S_colormap "): current colormap choice."
932   return(C_int_to_Xen_colormap(color_map(ss)));
933 }
934 
g_set_colormap(Xen val)935 static Xen g_set_colormap(Xen val)
936 {
937   int index;
938 
939   Xen_check_type(xen_is_colormap(val), val, 1, S_set S_colormap, "a colormap");
940 
941   index = Xen_colormap_to_C_int(val);
942   if (!(is_colormap(index)))
943     Xen_error(no_such_colormap,
944 	      Xen_list_2(C_string_to_Xen_string(S_colormap ": no such colormap: ~A"),
945 			 val));
946 
947   set_color_map(index); /* this normally redisplays */
948   return(val);
949 }
950 
951 
g_colormap_size(void)952 static Xen g_colormap_size(void) {return(C_int_to_Xen_integer(color_map_size(ss)));}
953 
g_set_colormap_size(Xen val)954 static Xen g_set_colormap_size(Xen val)
955 {
956   int size;
957   #define H_colormap_size "(" S_colormap_size "): current colormap size; default is 512."
958 
959   Xen_check_type(Xen_is_integer(val), val, 1, S_set S_colormap_size, "an integer");
960 
961   size = Xen_integer_to_C_int(val);
962   if (size < 0)
963     Xen_out_of_range_error(S_set S_colormap_size, 1, val, "size < 0?");
964   if (size > (1 << 26))
965     Xen_out_of_range_error(S_set S_colormap_size, 1, val, "size too large");
966 
967   set_color_map_size(size);
968   check_colormap_sizes(color_map_size(ss));
969 
970   return(C_int_to_Xen_integer(color_map_size(ss)));
971 }
972 
973 
g_colormap_name(Xen col)974 static Xen g_colormap_name(Xen col)
975 {
976   int map;
977   #define H_colormap_name "(" S_colormap_name " colormap) returns the colormap's name (used in the Color/Orientation dialog)."
978 
979   Xen_check_type(xen_is_colormap(col), col, 1, S_colormap_name, "a colormap");
980 
981   map = Xen_colormap_to_C_int(col);
982   if (!(is_colormap(map)))
983     Xen_error(no_such_colormap,
984 	      Xen_list_2(C_string_to_Xen_string(S_colormap_name ": no such colormap: ~A"),
985 			 col));
986 
987   return(C_string_to_Xen_string(cmaps[map]->name));
988 }
989 
990 
g_is_colormap(Xen obj)991 static Xen g_is_colormap(Xen obj)
992 {
993   #define H_is_colormap "(" S_is_colormap " obj) -> " PROC_TRUE " if 'obj' is a colormap."
994   return(C_bool_to_Xen_boolean(xen_is_colormap(obj) &&
995 			       is_colormap(Xen_colormap_to_C_int(obj))));
996 }
997 
998 
g_delete_colormap(Xen col)999 static Xen g_delete_colormap(Xen col)
1000 {
1001   int map;
1002   #define H_delete_colormap "(" S_delete_colormap " colormap) frees the specified colormap."
1003 
1004   Xen_check_type(xen_is_colormap(col), col, 1, S_delete_colormap, "a colormap");
1005 
1006   map = Xen_colormap_to_C_int(col);
1007   if (!(is_colormap(map)))
1008     Xen_error(no_such_colormap,
1009 	      Xen_list_2(C_string_to_Xen_string(S_delete_colormap ": no such colormap: ~A"),
1010 			 col));
1011 
1012   delete_cmap(map);
1013   reflect_color_list(false);
1014   if (color_map(ss) == map) set_color_map(DEFAULT_COLOR_MAP);
1015 
1016   return(col);
1017 }
1018 
1019 
1020 #include "clm2xen.h"
1021 
g_add_colormap(Xen name,Xen func)1022 static Xen g_add_colormap(Xen name, Xen func)
1023 {
1024   int index;
1025   #define H_add_colormap "(" S_add_colormap " name func) adds the colormap created by func to the colormap table, \
1026 returning the new colormap. 'name' is the colormap's name in the View:Color/Orientation dialog."
1027 
1028   Xen_check_type(Xen_is_string(name), name, 1, S_add_colormap, "a string");
1029   Xen_check_type(Xen_is_procedure(func) && (!mus_is_xen(func)), func, 2, S_add_colormap, "a function of 2 args");
1030 
1031   if (!(procedure_arity_ok(func, 1)))
1032     return(snd_bad_arity_error(S_add_colormap,
1033 			       C_string_to_Xen_string("func should take 1 arg"),
1034 			       func));
1035 
1036   index = add_colormap(Xen_string_to_C_string(name), func);
1037   reflect_color_list(false);
1038 
1039   return(C_int_to_Xen_colormap(index));
1040 }
1041 
1042 
Xen_wrap_2_args(g_colormap_ref_w,g_colormap_ref)1043 Xen_wrap_2_args(g_colormap_ref_w, g_colormap_ref)
1044 Xen_wrap_no_args(g_colormap_w, g_colormap)
1045 Xen_wrap_1_arg(g_is_colormap_w, g_is_colormap)
1046 Xen_wrap_1_arg(g_set_colormap_w, g_set_colormap)
1047 Xen_wrap_no_args(g_colormap_size_w, g_colormap_size)
1048 Xen_wrap_1_arg(g_set_colormap_size_w, g_set_colormap_size)
1049 Xen_wrap_1_arg(g_colormap_name_w, g_colormap_name)
1050 Xen_wrap_1_arg(g_delete_colormap_w, g_delete_colormap)
1051 Xen_wrap_2_args(g_add_colormap_w, g_add_colormap)
1052 Xen_wrap_1_arg(g_integer_to_colormap_w, g_integer_to_colormap)
1053 Xen_wrap_1_arg(g_colormap_to_integer_w, g_colormap_to_integer)
1054 
1055 #if HAVE_SCHEME
1056 static s7_pointer acc_colormap(s7_scheme *sc, s7_pointer args) {return(g_set_colormap(s7_cadr(args)));}
acc_colormap_size(s7_scheme * sc,s7_pointer args)1057 static s7_pointer acc_colormap_size(s7_scheme *sc, s7_pointer args) {return(g_set_colormap_size(s7_cadr(args)));}
1058 #endif
1059 
1060 #if (!HAVE_SCHEME)
1061 static Xen colormap_temp[16]; /* static for Ruby's sake */
1062 #endif
1063 
g_init_gxcolormaps(void)1064 void g_init_gxcolormaps(void)
1065 {
1066 #if HAVE_SCHEME
1067   s7_pointer i, p, t, b, r, s, col, fnc;
1068   b = s7_make_symbol(s7, "boolean?");
1069   i = s7_make_symbol(s7, "integer?");
1070   p = s7_make_symbol(s7, "pair?");
1071   r = s7_make_symbol(s7, "real?");
1072   s = s7_make_symbol(s7, "string?");
1073   col = s7_make_symbol(s7, "colormap?");
1074   fnc = s7_make_symbol(s7, "procedure?");
1075   t = s7_t(s7);
1076 #endif
1077 
1078   cmaps_size = NUM_BUILTIN_COLORMAPS;
1079   cmaps = (cmap **)calloc(cmaps_size, sizeof(cmap *));
1080 
1081   init_xen_colormap();
1082 
1083   cmaps[BLACK_AND_WHITE_COLORMAP] = make_builtin_cmap(1, "black-and-white", make_black_and_white_colormap, black_and_white_rgb);
1084   cmaps[GRAY_COLORMAP] =    make_builtin_cmap(1, "gray",    make_gray_colormap,    gray_rgb);
1085   cmaps[AUTUMN_COLORMAP] =  make_builtin_cmap(1, "autumn",  make_autumn_colormap,  autumn_rgb);
1086   cmaps[SPRING_COLORMAP] =  make_builtin_cmap(1, "spring",  make_spring_colormap,  spring_rgb);
1087   cmaps[WINTER_COLORMAP] =  make_builtin_cmap(1, "winter",  make_winter_colormap,  winter_rgb);
1088   cmaps[SUMMER_COLORMAP] =  make_builtin_cmap(1, "summer",  make_summer_colormap,  summer_rgb);
1089   cmaps[COOL_COLORMAP] =    make_builtin_cmap(1, "cool",    make_cool_colormap,    cool_rgb);
1090   cmaps[COPPER_COLORMAP] =  make_builtin_cmap(1, "copper",  make_copper_colormap,  copper_rgb);
1091   cmaps[FLAG_COLORMAP] =    make_builtin_cmap(1, "flag",    make_flag_colormap,    flag_rgb);
1092   cmaps[PRISM_COLORMAP] =   make_builtin_cmap(1, "prism",   make_prism_colormap,   prism_rgb);
1093   cmaps[BONE_COLORMAP] =    make_builtin_cmap(1, "bone",    make_bone_colormap,    bone_rgb);
1094   cmaps[HOT_COLORMAP] =     make_builtin_cmap(1, "hot",     make_hot_colormap,     hot_rgb);
1095   cmaps[JET_COLORMAP] =     make_builtin_cmap(1, "jet",     make_jet_colormap,     jet_rgb);
1096   cmaps[PINK_COLORMAP] =    make_builtin_cmap(1, "pink",    make_pink_colormap,    pink_rgb);
1097   cmaps[RAINBOW_COLORMAP] = make_builtin_cmap(1, "rainbow", make_rainbow_colormap, rainbow_rgb);
1098   cmaps[PHASES_COLORMAP] =  make_builtin_cmap(1, "phases",  make_phases_colormap,  phases_rgb);
1099 
1100 #if HAVE_SCHEME
1101   s7_define_constant(s7, "black-and-white-colormap", C_int_to_Xen_colormap(0));
1102   s7_define_constant(s7, "gray-colormap",            C_int_to_Xen_colormap(1));
1103   s7_define_constant(s7, "hot-colormap",             C_int_to_Xen_colormap(2));
1104   s7_define_constant(s7, "cool-colormap",            C_int_to_Xen_colormap(3));
1105   s7_define_constant(s7, "bone-colormap",            C_int_to_Xen_colormap(4));
1106   s7_define_constant(s7, "copper-colormap",          C_int_to_Xen_colormap(5));
1107   s7_define_constant(s7, "pink-colormap",            C_int_to_Xen_colormap(6));
1108   s7_define_constant(s7, "jet-colormap",             C_int_to_Xen_colormap(7));
1109   s7_define_constant(s7, "prism-colormap",           C_int_to_Xen_colormap(8));
1110   s7_define_constant(s7, "autumn-colormap",          C_int_to_Xen_colormap(9));
1111   s7_define_constant(s7, "winter-colormap",          C_int_to_Xen_colormap(10));
1112   s7_define_constant(s7, "spring-colormap",          C_int_to_Xen_colormap(11));
1113   s7_define_constant(s7, "summer-colormap",          C_int_to_Xen_colormap(12));
1114   s7_define_constant(s7, "rainbow-colormap",         C_int_to_Xen_colormap(13));
1115   s7_define_constant(s7, "flag-colormap",            C_int_to_Xen_colormap(14));
1116   s7_define_constant(s7, "phases-colormap",          C_int_to_Xen_colormap(15));
1117 #else
1118   Xen_define_variable("black-and-white-colormap", colormap_temp[0], C_int_to_Xen_colormap(0));
1119   Xen_define_variable("gray-colormap",            colormap_temp[1], C_int_to_Xen_colormap(1));
1120   Xen_define_variable("hot-colormap",             colormap_temp[2], C_int_to_Xen_colormap(2));
1121   Xen_define_variable("cool-colormap",            colormap_temp[3], C_int_to_Xen_colormap(3));
1122   Xen_define_variable("bone-colormap",            colormap_temp[4], C_int_to_Xen_colormap(4));
1123   Xen_define_variable("copper-colormap",          colormap_temp[5], C_int_to_Xen_colormap(5));
1124   Xen_define_variable("pink-colormap",            colormap_temp[6], C_int_to_Xen_colormap(6));
1125   Xen_define_variable("jet-colormap",             colormap_temp[7], C_int_to_Xen_colormap(7));
1126   Xen_define_variable("prism-colormap",           colormap_temp[8], C_int_to_Xen_colormap(8));
1127   Xen_define_variable("autumn-colormap",          colormap_temp[9], C_int_to_Xen_colormap(9));
1128   Xen_define_variable("winter-colormap",          colormap_temp[10], C_int_to_Xen_colormap(10));
1129   Xen_define_variable("spring-colormap",          colormap_temp[11], C_int_to_Xen_colormap(11));
1130   Xen_define_variable("summer-colormap",          colormap_temp[12], C_int_to_Xen_colormap(12));
1131   Xen_define_variable("rainbow-colormap",         colormap_temp[13], C_int_to_Xen_colormap(13));
1132   Xen_define_variable("flag-colormap",            colormap_temp[14], C_int_to_Xen_colormap(14));
1133   Xen_define_variable("phases-colormap",          colormap_temp[15], C_int_to_Xen_colormap(15));
1134 #endif
1135 
1136   Xen_define_typed_procedure(S_is_colormap,         g_is_colormap_w,         1, 0, 0, H_is_colormap,         s7_make_signature(s7, 2, b, t));
1137   Xen_define_typed_procedure(S_colormap_ref,        g_colormap_ref_w,        2, 0, 0, H_colormap_ref,        s7_make_signature(s7, 3, p, col, r));
1138   Xen_define_typed_procedure(S_add_colormap,        g_add_colormap_w,        2, 0, 0, H_add_colormap,        s7_make_signature(s7, 3, col, s, fnc));
1139   Xen_define_typed_procedure(S_colormap_name,       g_colormap_name_w,       1, 0, 0, H_colormap_name,       s7_make_signature(s7, 2, s, col));
1140   Xen_define_typed_procedure(S_delete_colormap,     g_delete_colormap_w,     1, 0, 0, H_delete_colormap,     s7_make_signature(s7, 2, col, col));
1141   Xen_define_typed_procedure(S_integer_to_colormap, g_integer_to_colormap_w, 1, 0, 0, H_integer_to_colormap,
1142 			     s7_make_signature(s7, 2, s7_make_signature(s7, 2, col, b), i));
1143   Xen_define_typed_procedure(S_colormap_to_integer, g_colormap_to_integer_w, 1, 0, 0, H_colormap_to_integer, s7_make_signature(s7, 2, i, col));
1144 
1145   Xen_define_typed_dilambda(S_colormap, g_colormap_w, H_colormap,
1146 			    S_set S_colormap, g_set_colormap_w, 0, 0, 1, 0,
1147 			    s7_make_signature(s7, 1, col),  s7_make_signature(s7, 2, col, col));
1148 
1149   Xen_define_typed_dilambda(S_colormap_size, g_colormap_size_w, H_colormap_size,
1150 			    S_set S_colormap_size, g_set_colormap_size_w, 0, 0, 1, 0,
1151 			    s7_make_signature(s7, 1, i),  s7_make_signature(s7, 2, i, i));
1152 
1153 #if HAVE_SCHEME
1154   s7_set_setter(s7, ss->color_map_size_symbol, s7_make_function(s7, "[acc-" S_colormap_size "]", acc_colormap_size, 2, 0, false, "accessor"));
1155   s7_set_setter(s7, ss->color_map_symbol, s7_make_function(s7, "[acc-" S_colormap "]", acc_colormap, 2, 0, false, "accessor"));
1156 
1157   s7_set_documentation(s7, ss->color_map_size_symbol, "*colormap-size*: current colormap size; default is 512.");
1158   s7_set_documentation(s7, ss->color_map_symbol, "*colormap*: current colormap choice.");
1159 #endif
1160 }
1161