1 ;; xmaxima.lisp: routines for Maxima's interface to xmaxima
2 ;; Copyright (C) 2007-2021 J. Villate
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.
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.
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,
21 ;; Given a list of valid colors (see rgb-color function) and an object c
22 ;; that can be a real number or a string, produces an rgb color
23 ;; specification for c; when c is real, its nearest integer is assigned
24 ;; to one of the numbers in the list, using modulo length of the list.
25 (defun xmaxima-color (colors c
)
26 (unless (listp colors
) (setq colors
(list colors
)))
28 (unless (integerp c
) (setq c
(round c
)))
29 (setq c
(nth (mod (1- c
) (length colors
)) colors
)))
32 ;; style is a list starting with a symbol from the list: points, lines,
33 ;; linespoints or dots,
34 ;; The meaning of the numbers that follow the symbol are:
36 ;; lines, linewidth, color
37 ;; points, radius, color
38 ;; linespoints, linewidth, radius, color
41 ;; linewidth and radius are measured in the same units and can be
42 ;; floating-point numbers.
44 ;; type must be an integer
45 ;; color can be an integer, used as index to get one of the colors defined
46 ;; by the color option, or a 6-digit hexadecimal number #rrggbb
48 (defun xmaxima-curve-style (style colors i
)
49 (unless (listp style
) (setq style
(list style
)))
50 (unless (listp colors
) (setq colors
(list colors
)))
51 (with-output-to-string
55 (format st
"\{ nolines 1 \} \{ plotpoints 1 \} \{ pointsize 0.7 \}")
57 (format st
" \{ color ~a \}" (xmaxima-color colors
(second style
)))
58 (format st
" \{ color ~a \}" (xmaxima-color colors i
))))
60 (format st
"\{ nolines 0 \} \{ plotpoints 0 \}")
61 (if (realp (second style
))
62 (format st
" \{ linewidth ~,2f \}" (second style
)))
64 (format st
" \{ color ~a \}" (xmaxima-color colors
(third style
)))
65 (format st
" \{ color ~a \}" (xmaxima-color colors i
))))
67 (format st
"\{ nolines 1 \} \{ plotpoints 1 \}")
68 (if (realp (second style
))
69 (format st
" \{ pointsize ~,2f \}" (second style
))
70 (format st
" \{ pointsize 3 \}"))
72 (format st
" \{ color ~a \}" (xmaxima-color colors
(third style
)))
73 (format st
" \{ color ~a \}" (xmaxima-color colors i
))))
75 (format st
"\{ nolines 0 \} \{ plotpoints 1 \}")
76 (if (realp (second style
))
77 (format st
" \{ linewidth ~,2f \}" (second style
)))
78 (if (realp (third style
))
79 (format st
" \{ pointsize ~,2f \}" (third style
))
80 (format st
" \{ pointsize 3 \}"))
82 (format st
" \{ color ~a \}" (xmaxima-color colors
(fourth style
)))
83 (format st
" \{ color ~a \}" (xmaxima-color colors i
))))
85 (format st
"\{ nolines 0 \} \{ plotpoints 0 \} \{ color ~a \}"
86 (xmaxima-color colors i
))))))
88 (defun xmaxima-palette (palette)
89 ;; palette should be a list starting with one of the symbols: hue,
90 ;; saturation, value, gray or gradient.
92 ;; If the symbol is gray, it should be followed by two floating point
93 ;; numbers that indicate the initial gray level and the interval of
96 ;; If the symbol is one of hue, saturation or value, it must be followed
97 ;; by three numbers that specify the hue, saturation and value for the
98 ;; initial color, and a fourth number that gives the range of values for
99 ;; the increment of hue, saturation or value.
100 ;; The values for the initial hue, saturation, value and grayness should
101 ;; be within 0 and 1, while the range can be higher or even negative.
103 ;; If the symbol is gradient, it must be followed by either a list of valid
104 ;; colors or by a list of lists with two elements, a number and a valid color.
106 (unless (listp palette
) (setq palette
(list palette
)))
107 (let (hue sat val gray range fun
)
108 (case (first palette
)
110 (case (length (rest palette
))
111 (2 (setq gray
(second palette
)) (setq range
(third palette
)))
114 "palette: gray must be followed by two numbers."))))
115 (when (or (< gray
0) (> gray
1))
116 (setq gray
(- gray
(floor gray
))))
117 (setq fun
(format nil
"{value ~,8f} {colorrange ~,8f}" gray range
)))
118 (($hue $saturation $value
)
119 (case (length (rest palette
))
120 (4 (setq hue
(second palette
))
121 (setq sat
(third palette
))
122 (setq val
(fourth palette
))
123 (setq range
(fifth palette
)))
126 "palette: ~M must be followed by four numbers.")
128 (when (or (< hue
0) (> hue
1)) (setq hue
(- hue
(floor hue
))))
129 (when (or (< sat
0) (> sat
1)) (setq sat
(- sat
(floor sat
))))
130 (when (or (< val
0) (> val
1)) (setq val
(- val
(floor val
))))
132 (format nil
" {hue ~,8f} {saturation ~,8f} {value ~,8f} {colorrange ~,8f}"
133 hue sat val range
))))
134 (with-output-to-string (st)
135 (case (first palette
)
136 ($hue
(format st
"~&~a {colorscheme hue}" fun
))
137 ($saturation
(format st
"~&~a {colorscheme saturation}" fun
))
138 ($value
(format st
"~&~a {colorscheme value}" fun
))
139 ($gray
(format st
"~&~a {colorscheme gray}" fun
))
141 (let* ((colors (rest palette
)) (n (length colors
)) (map nil
))
142 ;; map is constructed as (n1 c1 n2 c2 ... nj cj) where ni is a
143 ;; decreasing sequence of numbers (n1=1, nj=0) and ci are colors
145 ;; Maxima list of numbers and colors (((mlist) ni ci) ...)
146 ((listp (first colors
))
147 (setq colors
(sort colors
#'< :key
#'cadr
))
149 (setq map
(cons (rgb-color (third (nth i colors
))) ;; color
151 (/ (- (second (nth i colors
)) ;; ni minus
152 (second (first colors
))) ;; smallest ni
153 (- (second (nth (- n
1) colors
));; biggest
154 (second (first colors
)))) ;; - smallest
156 ;; list of only colors
158 (setq map
(cons (rgb-color (nth i colors
)) ;; color i
159 (cons (/ i
(1- n
)) map
)))))) ;; number i
161 ;; prints map with the format: nj, "cj", ...,n1, "c1"
162 (setq fun
(format nil
"~{{ ~,8f ~s}~^ ~}" (reverse map
)))
163 (format st
"~&{colorscheme gradient} ")
164 ;; writes: {gradlist {{nj "cj"} ...{n1 "c1"}}}
165 (format st
"{gradlist {~a}}" fun
)))
169 "palette: wrong keyword ~M. Must be hue, saturation, value, gray or gradient.")
170 (first palette
)))))))
172 (defun xmaxima-palettes (palette n
)
173 (unless (integerp n
) (setq n
(round n
)))
174 (if (find 'mlist palette
:key
#'car
) (setq palette
(list palette
)))
175 (xmaxima-palette (rest (nth (mod (- n
1) (length palette
)) palette
))))
177 (defmethod plot-preamble ((plot xmaxima-plot
) plot-options
)
180 (slot-value plot
'data
)
183 (slot-value plot
'data
)
184 (with-output-to-string (dest)
185 (cond ($show_openplot
186 (format dest
"~a -data {~%" (getf plot-options
:type
)))
187 (t (format dest
"{~a " (getf plot-options
:type
))))
188 (when (string= (getf plot-options
:type
) "plot3d")
189 (let ((palette (getf plot-options
:palette
))
190 (meshcolor (if (member :mesh_lines_color plot-options
)
191 (getf plot-options
:mesh_lines_color
)
193 (elev (getf plot-options
:elevation
))
194 (azim (getf plot-options
:azimuth
)))
195 (if (find 'mlist palette
:key
#'car
) (setq palette
(list palette
)))
199 (format dest
" {mesh_lines ~a}" (rgb-color meshcolor
))
200 (format dest
" {mesh_lines 0}")))
201 (format dest
" {colorscheme 0}~%"))
202 (when elev
(format dest
" {el ~d}" elev
))
203 (when azim
(format dest
" {az ~d}" azim
))
205 (when (getf plot-options
:ps_file
)
206 (setq outfile
(plot-file-path (getf plot-options
:ps_file
) t
))
207 (format dest
" {psfile ~s}" outfile
))
208 (when (member :legend plot-options
)
209 (unless (getf plot-options
:legend
)
210 (format dest
" {nolegend 1}")))
211 (when (member :box plot-options
)
212 (unless (getf plot-options
:box
)
213 (format dest
" {nobox 1}")))
214 (if (getf plot-options
:axes
)
215 (case (getf plot-options
:axes
)
216 ($x
(format dest
" {axes {x} }"))
217 ($y
(format dest
" {axes {y} }"))
218 (t (format dest
" {axes {xy} }")))
219 (format dest
" {axes 0}"))
220 (when (getf plot-options
:x
)
221 (format dest
" {xrange ~{~g~^ ~}}" (getf plot-options
:x
)))
222 (when (getf plot-options
:y
)
223 (format dest
" {yrange ~{~g~^ ~}}" (getf plot-options
:y
)))
224 (when (getf plot-options
:xlabel
)
225 (format dest
" {xaxislabel ~s}" (getf plot-options
:xlabel
)))
226 (when (getf plot-options
:ylabel
)
227 (format dest
" {yaxislabel ~s}" (getf plot-options
:ylabel
)))
228 (when (getf plot-options
:z
)
229 (format $pstream
" {zcenter ~g }"
230 (/ (apply #'+ (getf plot-options
:z
)) 2))
231 (format $pstream
" {zradius ~g }~%"
232 (/ (apply #'-
(getf plot-options
:z
)) -
2)))
233 (format dest
"~%"))))
234 ;;returns a list with the name of the file to be created, or nil
235 (if (null outfile
) nil
(list outfile
))))
237 (defmethod plot2d-command ((plot xmaxima-plot
) fun options range
)
240 (mapcar #'(lambda (f) (cdr (draw2d f range options
))) (cdr fun
)))
241 (when (= (count-if #'(lambda (x) x
) points-lists
) 0)
242 (merror (intl:gettext
"plot2d: nothing to plot.~%")))
244 (slot-value plot
'data
)
247 (slot-value plot
'data
)
248 (with-output-to-string (st)
249 (let ((legend (getf options
:legend
))
250 (colors (getf options
:color
))
251 (styles (getf options
:style
)) (i 0) style plot-name
)
252 (unless (listp legend
) (setq legend
(list legend
)))
253 (unless (listp colors
) (setq colors
(list colors
)))
254 (unless (listp styles
) (setq styles
(list styles
)))
255 (loop for v in
(cdr fun
) for points-list in points-lists do
258 (setq style
(nth (mod i
(length styles
)) styles
))
260 (when ($listp style
) (setq style
(cdr style
)))
262 ;; label the expression according to the legend,
263 ;; unless it is "false" or there is only one expression
264 (if (member :legend options
)
268 (nth (mod (- i
1) (length legend
)) legend
)) nil
))
269 (if (= 2 (length fun
))
274 (with-output-to-string (pn)
275 (cond ((atom v
) (format pn
"~a" ($sconcat v
)))
276 ((eq (second v
) '$parametric
)
279 ($sconcat
(fourth v
))))
280 ((eq (second v
) '$discrete
)
281 (format pn
"discrete~a" i
))
282 (t (format pn
"~a" ($sconcat v
))))))
283 (when (> (length plot-name
) 50)
284 (setq plot-name
(format nil
"fun~a" i
))))))
286 (format st
" {label ~s} " plot-name
)
287 (format st
" {nolegend 1} "))
288 (format st
(xmaxima-curve-style style colors i
))
289 (format st
"~%{xversusy~%")
290 (let ((lis points-list
))
293 (loop while
(and lis
(not (eq (car lis
) 'moveto
)))
294 collecting
(car lis
) into xx
295 collecting
(cadr lis
) into yy
296 do
(setq lis
(cddr lis
))
298 ;; only output if at least two points for line
300 (tcl-output-list st xx
)
301 (tcl-output-list st yy
)))
303 (setq lis
(cddr lis
))))
305 (format st
"} ")))))))
307 (defmethod plot3d-command ((plot xmaxima-plot
) functions options titles
)
308 (let ((i 0) fun xrange yrange lvars trans
)
310 (slot-value plot
'data
)
313 (slot-value plot
'data
)
314 (with-output-to-string ($pstream
)
315 ;; generate the mesh points for each surface in the functions stack
316 (dolist (f functions
)
319 (setq xrange
(second f
))
320 (setq yrange
(third f
))
324 ($make_transform
`((mlist) ,(second xrange
)
326 (second fun
) (third fun
) (fourth fun
)))
327 (setq fun
'$zero_fun
))
333 (xmid (+ x0
(/ (- x1 x0
) 2)))
334 (ymid (+ y0
(/ (- y1 y0
) 2))))
335 (setq lvars
`((mlist) ,(second xrange
) ,(second yrange
)))
336 (setq fun
(coerce-float-fun fun lvars
))
337 ;; Evaluate FUN at the middle point of the range.
338 ;; Looking at a single point is somewhat unreliable.
339 ;; Call FUN with numerical arguments (symbolic arguments may
340 ;; fail due to trouble computing real/imaginary parts for
341 ;; complicated expressions, or it may be a numerical function)
342 (when (cdr ($listofvars
(mfuncall fun xmid ymid
)))
345 "plot3d: expected <expr. of v1 and v2>, [v1,min,max], [v2,min,max]~%"))
348 "plot3d: keep going and hope for the best.~%")))))
351 fun
(third xrange
) (fourth xrange
) (third yrange
)
352 (fourth yrange
) (first (getf options
:grid
))
353 (second (getf options
:grid
))))
354 (ar (polygon-pts pl
))
355 (colors (getf options
:color
))
356 (palettes (getf options
:palette
)))
357 (declare (type (cl:array t
) ar
))
358 (when trans
(mfuncall trans ar
))
359 (when (getf options
:transform_xy
)
360 (mfuncall (getf options
:transform_xy
) ar
))
362 (format $pstream
" ~a~%" (xmaxima-palettes palettes i
))
363 (format $pstream
" {mesh_lines ~a}" (xmaxima-color colors i
)))
364 (output-points-tcl $pstream pl
(first (getf options
:grid
)))))
365 (format $pstream
"}~%"))))))
367 (defmethod plot-shipout ((plot xmaxima-plot
) options
&optional output-file
)
368 (let ((file (plot-file-path (format nil
"maxout~d.xmaxima" (getpid)))))
369 (cond ($show_openplot
371 #+sbcl
(sb-ext:native-namestring file
)
373 :direction
:output
:if-exists
:supersede
)
374 (princ (slot-value plot
'data
) fl
))
375 ($system
(concatenate 'string
*maxima-prefix
*
376 (if (string= *autoconf-windows
* "true")
378 $xmaxima_plot_command
)
379 #-
(or (and sbcl win32
) (and sbcl win64
) (and ccl windows
))
380 (format nil
" ~s &" file
)
381 #+(or (and sbcl win32
) (and sbcl win64
) (and ccl windows
))
383 (t (princ (slot-value plot
'data
)) ""))
384 (cons '(mlist) (cons file output-file
))))