Kill some variables in rtest_translator
[maxima.git] / src / gnuplot_def.lisp
blob6fadb7e0d45da1644ffdc3d1fcbfe1997ac570df
1 ;; gnuplot.lisp: routines for Maxima's interface to gnuplot
2 ;; Copyright (C) 2007-2019 J. Villate
3 ;;
4 ;; This program is free software; you can redistribute it and/or
5 ;; modify it under the terms of the GNU General Public License
6 ;; as published by the Free Software Foundation; either version 2
7 ;; of the License, or (at your option) any later version.
8 ;;
9 ;; This program is distributed in the hope that it will be useful,
10 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12 ;; GNU General Public License for more details.
13 ;;
14 ;; You should have received a copy of the GNU General Public License
15 ;; along with this program; if not, write to the Free Software
16 ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
17 ;; MA 02110-1301, USA
19 (in-package :maxima)
21 ;; Checks that color is a six-digit hexadecimal number with the prefix #,
22 ;; or a symbol for one of the 12 pre-defined colors, in which case the
23 ;; hexadecimal code for that color will be returned. Unknown colors are
24 ;; converted into black.
25 (defun rgb-color (color)
26 (if (plotcolorp color)
27 (case color
28 ($red "#ff0000")
29 ($green "#00ff00")
30 ($blue "#0000ff")
31 ($magenta "#ff00ff")
32 ($cyan "#00ffff")
33 ($yellow "#ffff00")
34 ($orange "#ffa500")
35 ($violet "#ee82ee")
36 ($brown "#a52a2a")
37 ($gray "#bebebe")
38 ($black "#000000")
39 ($white "#ffffff")
40 (t color))
41 "#000000"))
43 ;; Given a list of valid colors (see rgb-color function) and an object c
44 ;; that can be a real number or a string, produces a gnuplot color
45 ;; specification for c; when c is real, its nearest integer is assigned
46 ;; to one of the numbers in the list, using modulo length of the list.
47 (defun gnuplot-color (colors c)
48 (unless (listp colors) (setq colors (list colors)))
49 (when (realp c)
50 (unless (integerp c) (setq c (round c)))
51 (setq c (nth (mod (1- c) (length colors)) colors)))
52 (format nil "rgb ~s" (rgb-color c)))
54 (defun gnuplot-pointtype (type)
55 (case type
56 ($bullet 7) ($circle 6) ($plus 1) ($times 2) ($asterisk 3) ($box 5)
57 ($square 4) ($triangle 9) ($delta 8) ($wedge 11) ($nabla 10)
58 ($diamond 13) ($lozenge 12) (t 7)))
60 (defun gnuplot-pointtypes (types n)
61 (unless (integerp n) (setq n (round n)))
62 (unless (listp types) (setq types (list types)))
63 (gnuplot-pointtype (nth (mod (- n 1) (length types)) types)))
65 ;; style is a list starting with one of the symbols: points, lines,
66 ;; linespoints or dots,
67 ;; The meaning of the numbers that follow the symbol are:
69 ;; lines, linewidth, color
70 ;; points, radius, color, pointtype
71 ;; linespoints, linewidth, radius, color, pointtype
72 ;; dots, color
74 ;; linewidth and radius are measured in the same units and can be
75 ;; floating-point numbers.
77 ;; type must be an integer
78 ;; color can be an integer, used as index to get one of the colors defined
79 ;; by the color option, or a 6-digit hexadecimal number #rrggbb
81 (defun gnuplot-curve-style (style colors types i)
82 (unless (listp style) (setq style (list style)))
83 (unless (listp colors) (setq colors (list colors)))
84 (with-output-to-string
85 (st)
86 (case (first style)
87 ($dots
88 (format st "with dots")
89 (if (second style)
90 (format st " lt ~d" (gnuplot-color colors (second style)))
91 (format st " lt ~d" (gnuplot-color colors i))))
92 ($impulses
93 (format st "with impulses")
94 (if (integerp (second style))
95 (format st " lt ~d" (gnuplot-color colors (second style)))
96 (format st " lt ~d" (gnuplot-color colors i))))
97 ($lines
98 (format st "with lines")
99 (if (realp (second style))
100 (format st " lw ~,2f" (second style)))
101 (if (third style)
102 (format st " lt ~d" (gnuplot-color colors (third style)))
103 (format st " lt ~d" (gnuplot-color colors i))))
104 ($points
105 (format st "with points")
106 (if (realp (second style))
107 (format st " ps ~,2f" (/ (second style) 2))
108 (format st " ps 1.5"))
109 (if (third style)
110 (format st " lt ~d" (gnuplot-color colors (third style)))
111 (format st " lt ~d" (gnuplot-color colors i)))
112 (if (integerp (fourth style))
113 (format st " pt ~d" (gnuplot-pointtypes types (fourth style)))
114 (format st " pt ~d" (gnuplot-pointtypes types i))))
115 ($linespoints
116 (format st "with linespoints")
117 (if (realp (second style))
118 (format st " lw ~,2f" (second style)))
119 (if (realp (third style))
120 (format st " ps ~,2f" (/ (third style) 2))
121 (format st " ps 1.5"))
122 (if (fourth style)
123 (format st " lt ~d" (gnuplot-color colors (fourth style)))
124 (format st " lt ~d" (gnuplot-color colors i)))
125 (if (integerp (fifth style))
126 (format st " pt ~d" (gnuplot-pointtypes types (fifth style)))
127 (format st " pt ~d" (gnuplot-pointtypes types i))))
128 (t (format st "with lines lt ~d" (gnuplot-color colors i))))))
130 (defun gnuplot-palette (palette)
131 ;; palette should be a list starting with one of the symbols: hue,
132 ;; saturation, value, gray or gradient.
134 ;; If the symbol is gray, it should be followed by two floating point
135 ;; numbers that indicate the initial gray level and the interval of
136 ;; gray values.
138 ;; If the symbol is one of hue, saturation or value, it must be followed
139 ;; by three numbers that specify the hue, saturation and value for the
140 ;; initial color, and a fourth number that gives the range of values for
141 ;; the increment of hue, saturation or value.
142 ;; The values for the initial hue, saturation, value and grayness should
143 ;; be within 0 and 1, while the range can be higher or even negative.
145 ;; If the symbol is gradient, it must be followed by either a list of valid
146 ;; colors or by a list of lists with two elements, a number and a valid color.
148 (unless (listp palette) (setq palette (list palette)))
149 (let (hue sat val gray range fun)
150 (case (first palette)
151 ($gray
152 (case (length (rest palette))
153 (2 (setq gray (second palette)) (setq range (third palette)))
154 (t (merror
155 (intl:gettext
156 "palette: gray must be followed by two numbers."))))
157 (when (or (< gray 0) (> gray 1))
158 (setq gray (- gray (floor gray)))))
159 (($hue $saturation $value)
160 (case (length (rest palette))
161 (4 (setq hue (second palette))
162 (setq sat (third palette))
163 (setq val (fourth palette))
164 (setq range (fifth palette)))
165 (t (merror
166 (intl:gettext
167 "palette: ~M must be followed by four numbers.")
168 (first palette))))
169 (when (or (< hue 0) (> hue 1)) (setq hue (- hue (floor hue))))
170 (when (or (< sat 0) (> sat 1)) (setq sat (- sat (floor sat))))
171 (when (or (< val 0) (> val 1)) (setq val (- val (floor val))))))
172 (with-output-to-string (st)
173 (case (first palette)
174 ($hue
175 (if (or (< (+ hue range) 0) (> (+ hue range) 1))
176 (setq fun (format nil "~,3f+~,3f*gray-floor(~,3f+~,3f*gray)"
177 hue range hue range))
178 (setq fun (format nil "~,3f+~,3f*gray" hue range)))
179 (format st "model HSV functions ~a, ~,3f, ~,3f" fun sat val))
180 ($saturation
181 (if (or (< (+ sat range) 0) (> (+ sat range) 1))
182 (setq fun (format nil "~,3f+~,3f*gray-floor(~,3f+~,3f*gray)"
183 sat range sat range))
184 (setq fun (format nil "~,3f+~,3f*gray" sat range)))
185 (format st "model HSV functions ~,3f, ~a, ~,3f" hue fun val))
186 ($value
187 (if (or (< (+ val range) 0) (> (+ val range) 1))
188 (setq fun (format nil "~,3f+~,3f*gray" val range))
189 (setq fun (format nil "~,3f+~,3f*gray-floor(~,3f+~,3f*gray)"
190 val range val range)))
191 (format st "model HSV functions ~,3f, ~,3f, ~a" hue sat fun))
192 ($gray
193 (if (or (< (+ gray range) 0) (> (+ gray range) 1))
194 (setq fun (format nil "~,3f+~,3f*gray" gray range))
195 (setq fun (format nil "~,3f+~,3f*gray-floor(~,3f+~,3f*gray)"
196 gray range gray range)))
197 (format st "model RGB functions ~a, ~a, ~a" fun fun fun))
199 ($gradient
200 (let* ((colors (rest palette)) (n (length colors)) (map nil))
201 ;; map is constructed as (n1 c1 n2 c2 ... nj cj) where ni is a
202 ;; decreasing sequence of numbers (n1=1, nj=0) and ci are colors
203 (cond
204 ;; Maxima list of numbers and colors (((mlist) ni ci) ...)
205 ((listp (first colors))
206 (setq colors (sort colors #'< :key #'cadr))
207 (dotimes (i n)
208 (setq map (cons (rgb-color (third (nth i colors))) ;; color
209 (cons
210 (/ (- (second (nth i colors)) ;; ni minus
211 (second (first colors))) ;; smallest ni
212 (- (second (nth (- n 1) colors));; biggest
213 (second (first colors)))) ;; - smallest
214 map)))))
215 ;; list of only colors
216 (t (dotimes (i n)
217 (setq map (cons (rgb-color (nth i colors)) ;; color i
218 (cons (/ i (1- n)) map)))))) ;; number i
220 ;; prints map with the format: nj, "cj", ...,n1, "c1"
221 (setq fun (format nil "~{~,8f ~s~^, ~}" (reverse map)))
222 ;; outputs the string: defined (nj, "cj", ...,n1, "c1")
223 (format st "defined (~a)" fun)))
225 (merror
226 (intl:gettext
227 "palette: wrong keyword ~M. Must be hue, saturation, value, gray or gradient.")
228 (first palette)))))))
230 (defun gnuplot-print-header (dest plot-options)
231 (let (terminal-file (palette (getf plot-options :palette))
232 (meshcolor (if (member :mesh_lines_color plot-options)
233 (getf plot-options :mesh_lines_color)
234 '$black))
235 (gstrings (if (getf plot-options :gnuplot_strings) "" "noenhanced")))
236 (when (and (member :gnuplot_pm3d plot-options)
237 (not (getf plot-options :gnuplot_pm3d)))
238 (setq palette nil))
239 (when (find 'mlist palette :key #'car) (setq palette (list palette)))
240 ;; user's preamble
241 (when (and (getf plot-options :gnuplot_preamble)
242 (> (length (getf plot-options :gnuplot_preamble)) 0))
243 (format dest "~a~%" (getf plot-options :gnuplot_preamble)))
245 ;; sets-up terminal command and output file name
246 (setq terminal-file (gnuplot-terminal-and-file plot-options))
248 ;; By default gnuplot assumes everything below 1e-8 to be a rounding error
249 ;; and rounds it down to 0. This is handy for standalone gnuplot as it allows
250 ;; to suppress pixels with imaginary part while allowing for small calculation
251 ;; errors. As plot and draw handle the imaginary part without gnuplot's help
252 ;; this isn't needed here and is turned off as it often surprises users.
253 (format dest "set zero 0.0~%")
255 ;; prints terminal and output commands
256 (when (first terminal-file)
257 (format dest "~a~%" (first terminal-file)))
258 (when (second terminal-file)
259 (format dest "set output ~s~%" (second terminal-file)))
261 ;; options specific to plot3d
262 (when (string= (getf plot-options :type) "plot3d")
263 (format dest "set xyplane relative 0~%")
264 (if palette
265 (progn
266 (if meshcolor
267 (progn
268 (format dest "set style line 100 lt rgb ~s lw 1~%"
269 (rgb-color meshcolor))
270 (format dest "set pm3d hidden3d 100~%")
271 (unless (getf plot-options :gnuplot_4_0)
272 (format dest "set pm3d depthorder~%")))
273 (format dest "set pm3d~%"))
274 (format dest "unset hidden3d~%")
275 (format dest "set palette ~a~%"
276 (gnuplot-palette (rest (first palette)))))
277 (format dest "set hidden3d~%"))
278 (let ((elev (getf plot-options :elevation))
279 (azim (getf plot-options :azimuth)))
280 (when (or elev azim)
281 (if elev
282 (format dest "set view ~d" elev)
283 (format dest "set view "))
284 (when azim (format dest ", ~d" azim))
285 (format dest "~%"))))
287 ;; color_bar can be used by plot3d or plot2d
288 (unless (getf plot-options :color_bar)
289 (format dest "unset colorbox~%"))
291 ;; ----- BEGIN GNUPLOT 4.0 WORK-AROUND -----
292 ;; When the expression to be plotted is a constant, Gnuplot fails
293 ;; with a division by 0. Explicitly assigning cbrange prevents
294 ;; the error. Also set zrange to match cbrange.
295 ;; When the bug is fixed in Gnuplot (maybe 4.1 ?) this hack can go away.
296 (when (floatp (getf plot-options :const_expr))
297 (format
298 dest "set cbrange [~a : ~a]~%"
299 (1- (getf plot-options :const_expr))
300 (1+ (getf plot-options :const_expr)))
301 (format
302 dest "set zrange [~a : ~a]~%"
303 (1- (getf plot-options :const_expr))
304 (1+ (getf plot-options :const_expr))))
305 ;; ----- END GNUPLOT 4.0 WORK-AROUND -----
307 ;; logarithmic plots
308 (when (getf plot-options :logx) (format dest "set log x~%"))
309 (when (getf plot-options :logy) (format dest "set log y~%"))
311 ;; axes labels and legend
312 (when (getf plot-options :xlabel)
313 (format dest "set xlabel ~s ~a~%" (getf plot-options :xlabel) gstrings))
314 (when (getf plot-options :ylabel)
315 (format dest "set ylabel ~s ~a~%" (getf plot-options :ylabel) gstrings))
316 (when (getf plot-options :zlabel)
317 (format dest "set zlabel ~s ~a~%" (getf plot-options :zlabel) gstrings))
318 (when (and (member :legend plot-options)
319 (null (getf plot-options :legend)))
320 (format dest "unset key~%"))
322 ;; plotting box
323 (when (and (member :box plot-options) (not (getf plot-options :box)))
324 (format dest "unset border~%")
325 (if (and (getf plot-options :axes)
326 (string= (getf plot-options :type) "plot2d"))
327 (format dest "set xtics axis~%set ytics axis~%set ztics axis~%")
328 (format dest "unset xtics~%unset ytics~%unset ztics~%")))
330 (when (string= (getf plot-options :type) "plot2d")
332 ;; 2d grid (specific to plot2d)
333 (format dest "set grid front~%")
334 (if (getf plot-options :grid2d)
335 (format dest "set grid~%")
336 (format dest "unset grid~%"))
338 ;; plot size and aspect ratio for plot2d
339 (if (getf plot-options :same_xy)
340 (format dest "set size ratio -1~%")
341 (if (getf plot-options :yx_ratio)
342 (format dest "set size ratio ~,8f~%" (getf plot-options :yx_ratio))
343 (if (not (getf plot-options :xy_scale))
344 ;; emit the default only if there is no xy_scale specified.
345 (format dest "set size ratio 0.75~%"))))
346 (if (and (getf plot-options :xy_scale)
347 (listp (getf plot-options :xy_scale)))
348 (format dest "set size ~{~,8f~^, ~}~%" (getf plot-options :xy_scale))))
350 ;; plot size and aspect ratio for plot3d
351 (when (string= (getf plot-options :type) "plot3d")
352 (when (getf plot-options :same_xy)
353 (format dest "set view equal xy~%"))
354 (when (getf plot-options :same_xyz)
355 (format dest "set view equal xyz~%"))
356 (when (getf plot-options :zmin)
357 (format dest "set xyplane at ~,8f~%" (getf plot-options :zmin))))
359 ;; axes tics
360 (when (member :xtics plot-options)
361 (let ((xtics (getf plot-options :xtics)))
362 (if (consp xtics)
363 (format dest "set xtics ~{~,8f~^, ~}~%" xtics)
364 (if xtics
365 (format dest "set xtics ~,8f~%" xtics)
366 (format dest "unset xtics~%")))))
367 (when (member :ytics plot-options)
368 (let ((ytics (getf plot-options :ytics)))
369 (if (consp ytics)
370 (format dest "set ytics ~{~,8f~^, ~}~%" ytics)
371 (if ytics
372 (format dest "set ytics ~,8f~%" ytics)
373 (format dest "unset ytics~%")))))
374 (when (member :ztics plot-options)
375 (let ((ztics (getf plot-options :ztics)))
376 (if (consp ztics)
377 (format dest "set ztics ~{~,8f~^, ~}~%" ztics)
378 (if ztics
379 (format dest "set ztics ~,8f~%" ztics)
380 (format dest "unset ztics~%")))))
381 (when (member :color_bar_tics plot-options)
382 (let ((cbtics (getf plot-options :color_bar_tics)))
383 (if (consp cbtics)
384 (format dest "set cbtics ~{~,8f~^, ~}~%" cbtics)
385 (if cbtics
386 (format dest "set cbtics ~,8f~%" cbtics)
387 (format dest "unset cbtics~%")))))
389 ;; axes ranges and style
390 (when (and (getf plot-options :x) (listp (getf plot-options :x)))
391 (format dest "set xrange [~{~g~^ : ~}]~%" (getf plot-options :x)))
392 (when (and (getf plot-options :y) (listp (getf plot-options :y)))
393 (format dest "set yrange [~{~g~^ : ~}]~%" (getf plot-options :y)))
394 (when (and (getf plot-options :z) (listp (getf plot-options :z)))
395 (format dest "set zrange [~{~g~^ : ~}]~%" (getf plot-options :z)))
396 (when (and (string= (getf plot-options :type) "plot2d")
397 (member :axes plot-options))
398 (if (getf plot-options :axes)
399 (case (getf plot-options :axes)
400 ($x (format dest "set xzeroaxis~%"))
401 ($y (format dest "set yzeroaxis~%"))
402 ($solid (format dest "set zeroaxis lt -1~%"))
403 (t (format dest "set zeroaxis~%")))))
405 ;; title and labels
406 (when (getf plot-options :title)
407 (format dest "set title ~s ~a~%" (getf plot-options :title) gstrings))
408 (when (getf plot-options :label)
409 (dolist (label (getf plot-options :label))
410 (when (and (listp label) (= (length label) 4))
411 (format dest "set label ~s ~a at ~{~,8f~^, ~}~%"
412 (cadr label) gstrings (cddr label)))))
414 ;; identifier for missing data
415 (format dest "set datafile missing ~s~%" *missing-data-indicator*)
417 ;; user's commands; may overule any of the previous settings
418 (when (and (getf plot-options :gnuplot_postamble)
419 (> (length (getf plot-options :gnuplot_postamble)) 0))
420 (format dest "~a~%" (getf plot-options :gnuplot_postamble)))
422 ;;returns a list with the name of the file created, or nil
423 (if (null (second terminal-file)) nil (list (second terminal-file)))))
425 (defun gnuplot-plot3d-command (file palette gstyles colors gstrings titles n)
426 (let (title (style "with pm3d"))
427 (with-output-to-string (out)
428 (format out "splot ")
429 (do ((i 1 (+ i 1))) ((> i n) (format out "~%"))
430 (unless palette
431 (if gstyles
432 (setq style (ensure-string (nth (mod i (length gstyles)) gstyles)))
433 (setq style
434 (format nil "with lines lt ~a" (gnuplot-color colors i)))))
435 (when (> i 1) (format out ", "))
436 (if titles
437 (setq title (nth (mod i (length titles)) titles))
438 (setq title ""))
439 (format out "~s title ~s ~a ~a" file title gstrings style)))))
441 (defun gnuplot-terminal-and-file (plot-options)
442 (let (terminal-command out-file (preserve-file t))
443 (cond
444 ((getf plot-options :svg_file)
445 (if (getf plot-options :gnuplot_svg_term_command)
446 (setq terminal-command
447 (getf plot-options :gnuplot_svg_term_command))
448 (setq terminal-command "set term svg font \",14\""))
449 (setq out-file (getf plot-options :svg_file)))
450 ((getf plot-options :png_file)
451 (if (getf plot-options :gnuplot_png_term_command)
452 (setq terminal-command
453 (getf plot-options :gnuplot_png_term_command))
454 (setq terminal-command "set term pngcairo font \",12\""))
455 (setq out-file (getf plot-options :png_file)))
456 ((getf plot-options :pdf_file)
457 (if (getf plot-options :gnuplot_pdf_term_command)
458 (setq terminal-command
459 (getf plot-options :gnuplot_pdf_term_command))
460 (setq terminal-command "set term pdfcairo color solid lw 3 size 17.2 cm, 12.9 cm font \",18\""))
461 (setq out-file (getf plot-options :pdf_file)))
462 ((getf plot-options :ps_file)
463 (if (getf plot-options :gnuplot_ps_term_command)
464 (setq terminal-command
465 (getf plot-options :gnuplot_ps_term_command))
466 (setq terminal-command "set term postscript eps color solid lw 2 size 16.4 cm, 12.3 cm font \",24\""))
467 (setq out-file (getf plot-options :ps_file)))
468 ((eq (getf plot-options :gnuplot_term) '$ps)
469 (if (getf plot-options :gnuplot_ps_term_command)
470 (setq terminal-command
471 (getf plot-options :gnuplot_ps_term_command))
472 (setq terminal-command "set term postscript eps color solid lw 2 size 16.4 cm, 12.3 cm font \",24\""))
473 (if (getf plot-options :gnuplot_out_file)
474 (setq out-file (getf plot-options :gnuplot_out_file))
475 (setq out-file "maxplot.ps")))
476 ((eq (getf plot-options :gnuplot_term) '$dumb)
477 (if (getf plot-options :gnuplot_dumb_term_command)
478 (setq terminal-command
479 (getf plot-options :gnuplot_ps_term_command))
480 (setq terminal-command "set term dumb 79 22"))
481 (if (getf plot-options :gnuplot_out_file)
482 (setq out-file (getf plot-options :gnuplot_out_file))
483 (setq out-file "maxplot.txt")))
484 ((eq (getf plot-options :gnuplot_term) '$default)
485 (if (getf plot-options :gnuplot_default_term_command)
486 (setq terminal-command
487 (getf plot-options :gnuplot_default_term_command))
488 (setq terminal-command
489 "set term pop")))
490 ((getf plot-options :gnuplot_term)
491 (setq
492 terminal-command
493 (format nil "set term ~(~a~)"
494 (ensure-string (getf plot-options :gnuplot_term))))
495 (if (getf plot-options :gnuplot_out_file)
496 (setq out-file (getf plot-options :gnuplot_out_file))
497 (setq preserve-file nil
498 out-file
499 (format nil "maxplot.~(~a~)"
500 (get-gnuplot-term (getf plot-options :gnuplot_term)))))))
502 (unless (null out-file) (setq out-file (plot-file-path out-file preserve-file)))
503 (list terminal-command out-file)))