1;;;                 COPYRIGHT NOTICE
2;;;
3;;;  Copyright (C) 2007-2016 Mario Rodriguez Riotorto
4;;;
5;;;  This program is free software; you can redistribute
6;;;  it and/or modify it under the terms of the
7;;;  GNU General Public License as published by
8;;;  the Free Software Foundation; either version 2
9;;;  of the License, or (at your option) any later version.
10;;;
11;;;  This program is distributed in the hope that it
12;;;  will be useful, but WITHOUT ANY WARRANTY;
13;;;  without even the implied warranty of MERCHANTABILITY
14;;;  or FITNESS FOR A PARTICULAR PURPOSE. See the
15;;;  GNU General Public License for more details at
16;;;  http://www.gnu.org/copyleft/gpl.html
17
18;;; This is a maxima-gnuplot interface.
19
20;;; Visit
21;;; http://tecnostats.net/Maxima/gnuplot
22;;; for examples
23
24;;; For questions, suggestions, bugs and the like, feel free
25;;; to contact me at
26;;; riotorto @@@ yahoo DOT com
27
28
29;; use $draw_version to save package version
30;; and to know whether the package was loaded
31($put '$gnuplot 1 '$version); to be removed in the future
32(defvar $draw_version 2)
33
34
35(defun write-font-type ()
36   (if (and (string= (get-option '$font) "") (not (eq (get-option '$font_size) 10)))
37     (mwarning "Cannot set the gnuplot font size without a font name."))
38
39   (if (or (eq (get-option '$font) nil) (string= (get-option '$font) ""))
40     ""
41     (format nil "font '~a,~a'" (get-option '$font) (get-option '$font_size))))
42
43
44;; one-window multiplot: consecutive calls
45;; to draw allways plot on the same window
46(defvar *multiplot-is-active* nil)
47(defun $multiplot_mode (term)
48  (case term
49    ($screen
50      ($multiplot_mode '$none)
51      (send-gnuplot-command
52        (format nil "if(GPVAL_VERSION >= 5.0){set terminal x11 dashed ~a replotonresize~%set multiplot~%} else {set terminal x11 dashed ~a~%set multiplot~%}" (write-font-type) (write-font-type)))
53      (setf *multiplot-is-active* t))
54    ($wxt
55      ($multiplot_mode '$none)
56      (send-gnuplot-command
57        (format nil "set terminal wxt dashed ~a~%set multiplot~%" (write-font-type)))
58      (setf *multiplot-is-active* t))
59    ($qt
60      ($multiplot_mode '$none)
61     (send-gnuplot-command
62       (format nil "set terminal qt dashed ~a~%set multiplot~%" (write-font-type)))
63     (setf *multiplot-is-active* t))
64    ($windows
65      ($multiplot_mode '$none)
66     (send-gnuplot-command
67       (format nil "set terminal windows dashed ~a~%set multiplot~%" (write-font-type)))
68     (setf *multiplot-is-active* t))
69    ($none
70      (send-gnuplot-command
71        (format nil "unset multiplot~%unset output~%"))
72      (setf *multiplot-is-active* nil))
73    (otherwise
74      (merror "draw: ~M is not recognized as a multiplot mode" term))))
75
76
77
78;; This function is called from the graphic objects constructors
79;; (points, rectangle, etc.). When a new object is created, and if
80;; the user hasn't especified an x or y range, ranges are computed
81;; automaticallly by calling this function. There is a trick so
82;; that object constructors know if they can modify global variables
83;; xrange and yrange; if these lists are of length 2, it means that
84;; it was a user selection and they can't be altered; if they are of
85;; length 3 (with a dummy 0), object constructors should make the necessary changes
86;; to fit the objects in the window; if they are nil, default
87;; value, constructors are also allowed to make changes.
88(defmacro update-range (axi vmin vmax)
89   `(case (length (get-option ,axi))
90          (0 (setf (gethash ,axi *gr-options*) (list ,vmin ,vmax 0)))
91          (3 (setf (gethash ,axi *gr-options*) (list (min ,vmin (first  (get-option ,axi)))
92                                           (max ,vmax (second (get-option ,axi)))
93                                           0))) ))
94
95(defun update-ranges-2d (xmin xmax ymin ymax)
96   (if (get-option '$xaxis_secondary)
97      (update-range '$xrange_secondary xmin xmax)
98      (update-range '$xrange xmin xmax))
99   (if (get-option '$yaxis_secondary)
100      (update-range '$yrange_secondary ymin ymax)
101      (update-range '$yrange ymin ymax)) )
102
103(defun update-ranges-3d (xmin xmax ymin ymax zmin zmax)
104   (update-ranges-2d xmin xmax ymin ymax)
105   (update-range '$zrange zmin zmax))
106
107(defmacro check-extremes-x ()
108  '(when (numberp xx)
109    (when (< xx xmin) (setf xmin xx))
110    (when (> xx xmax) (setf xmax xx))))
111
112(defmacro check-extremes-y ()
113  '(when (numberp yy)
114    (when (< yy ymin) (setf ymin yy))
115    (when (> yy ymax) (setf ymax yy))))
116
117(defmacro check-extremes-z ()
118  '(when (numberp zz)
119    (when (< zz zmin) (setf zmin zz))
120    (when (> zz zmax) (setf zmax zz))))
121
122;; Controls whether the actual graphics object must
123;; be plotted against the primary or the secondary axes,
124;; both horizontal and vertical. Secondary axes in 3D
125;; are not yet supported.
126(defun axes-to-plot ()
127   (format nil "~a~a"
128           (if (get-option '$xaxis_secondary)
129               "x2"
130               "x1")
131           (if (get-option '$yaxis_secondary)
132               "y2"
133               "y1")))
134
135(defstruct gr-object
136   name command groups points)
137
138(defun make-obj-title (str)
139  (if (= (length str) 0)
140    "notitle"
141    (if (> (length str) 80)
142      (concatenate 'string "t '" (subseq str 0 75) " ...'")
143      (concatenate 'string "t '" str "'"))))
144
145
146
147
148
149;; Object: 'errors'
150;; Usage:
151;;     errors([[x1,y1,...], [x2,y2,...], [x3,y3,...],...])
152;; Options:
153;;     error_type
154;;     points_joined
155;;     line_width
156;;     key
157;;     line_type
158;;     color
159;;     fill_density
160;;     xaxis_secondary
161;;     yaxis_secondary
162(defun errors (arg)
163  (let ((etype  (get-option '$error_type))
164        (joined (get-option '$points_joined))
165        element-size
166        pts pltcmd grouping xmin xmax ymin ymax with)
167    (if (and ($listp arg)
168             (every #'$listp (rest arg)))
169        (setf element-size (length (cdadr arg)))
170        (merror "draw (errors object): incorrect input format"))
171    (unless (every #'(lambda (z) (= element-size ($length z))) (rest arg))
172      (merror "draw (errors object): lists of different sizes"))
173    ; create plot command
174    (cond ((and (eql etype '$x)
175                (or (= element-size 3)
176                    (= element-size 4)))
177             (if (null joined)
178               (setf with "xerrorbars")
179               (setf with "xerrorlines"))  )
180          ((and (eql etype '$y)
181                (or (= element-size 3)
182                    (= element-size 4)))
183             (if (null joined)
184               (setf with "yerrorbars")
185               (setf with "yerrorlines"))  )
186          ((and (eql etype '$xy)
187                (or (= element-size 4)
188                    (= element-size 6)))
189             (if (null joined)
190               (setf with "xyerrorbars")
191               (setf with "xyerrorlines"))  )
192          ((and (eql etype '$boxes)
193                (or (= element-size 4)
194                    (= element-size 6)))
195             (setf with "boxxyerrorbars") )
196          (t
197             (merror "draw (errors object): incompatibility with option error_type")))
198
199    (setf grouping `((,element-size 0)))
200    (setf pltcmd
201          (format nil
202                  " ~a w ~a ~a lw ~a lt ~a lc ~a axis ~a"
203                  (make-obj-title (get-option '$key))
204                  with
205                  (if (eql etype '$boxes)  ; in case of boxes, should they be filled?
206                      (format nil "fs solid ~a"
207                              (get-option '$fill_density))
208                      "")
209                  (get-option '$line_width)
210                  (get-option '$line_type)
211                  (hex-to-rgb (get-option '$color))
212                  (axes-to-plot)))
213    (setf pts (map 'list #'rest (rest ($float arg))))
214    (let ((x (map 'list #'first  pts))
215          (y (map 'list #'second pts)))
216      (setf xmin ($tree_reduce 'min (cons '(mlist simp) x))
217            xmax ($tree_reduce 'max (cons '(mlist simp) x))
218            ymin ($tree_reduce 'min (cons '(mlist simp) y))
219            ymax ($tree_reduce 'max (cons '(mlist simp) y))))
220    (update-ranges-2d xmin xmax ymin ymax)
221    (make-gr-object
222       :name 'errors
223       :command pltcmd
224       :groups grouping
225       :points (list (make-array (* element-size (length pts))
226                                 :element-type 'flonum
227                                 :initial-contents (flatten pts)))) ))
228
229
230
231
232
233
234;; Object: 'points'
235;; Usage:
236;;     points([[x1,y1], [x2,y2], [x3,y3],...])
237;;     points([x1,x2,x3,...], [y1,y2,y3,...])
238;;     points([y1,y2,y3,...]), abscissas are automatically chosen: 1,2,3,...
239;;     points(matrix), one-column, one-row, two-column or two-row matrix
240;;     points(array1d)
241;;     points(array1d, array1d)
242;;     points(array2d), two-column or two-row array
243;; Options:
244;;     point_size
245;;     point_type
246;;     points_joined
247;;     line_width
248;;     key
249;;     line_type
250;;     color
251;;     xaxis_secondary
252;;     yaxis_secondary
253;;     transform
254(defun points-command ()
255  (let ((pj (get-option '$points_joined))
256        (ps (get-option '$point_size))
257        (pt (get-option '$point_type)) )
258    (cond
259      ((null pj) ; draws isolated points
260         (format nil " ~a w p ps ~a pt ~a lc ~a axis ~a"
261                 (make-obj-title (get-option '$key))
262                 ps
263                 pt
264                 (hex-to-rgb (get-option '$color))
265                 (axes-to-plot)))
266      ((and (eq pj t) (or (= ps 0.0) (= pt 0)) ) ; draws joined points without symbols
267         (format nil " ~a w l lw ~a lt ~a lc ~a axis ~a"
268                 (make-obj-title (get-option '$key))
269                 (get-option '$line_width)
270                 (get-option '$line_type)
271                 (hex-to-rgb (get-option '$color))
272                 (axes-to-plot)))
273      ((eq pj t) ; draws joined points
274         (format nil " ~a w lp ps ~a pt ~a lw ~a lt ~a lc ~a axis ~a"
275                 (make-obj-title (get-option '$key))
276                 ps
277                 pt
278                 (get-option '$line_width)
279                 (get-option '$line_type)
280                 (hex-to-rgb (get-option '$color))
281                 (axes-to-plot)))
282      (t  ; draws impulses
283         (format nil " ~a w i lw ~a lt ~a lc ~a axis ~a"
284                 (make-obj-title (get-option '$key))
285                 (get-option '$line_width)
286                 pt
287                 (hex-to-rgb (get-option '$color))
288                 (axes-to-plot))))) )
289
290(defun points-array-2d (arg)
291   (let ((xmin most-positive-double-float)
292         (xmax most-negative-double-float)
293         (ymin most-positive-double-float)
294         (ymax most-negative-double-float)
295         (pos -1)
296         (dim (array-dimensions arg))
297         n xx yy pts twocolumns)
298      (cond
299         ((and (= (length dim) 2)   ; two-column array
300               (= (cadr dim) 2))
301            (setf n (car dim))
302            (setf twocolumns t))
303         ((and (= (length dim) 2)   ; two-row array
304               (= (car dim) 2))
305            (setf n (cadr dim))
306            (setf twocolumns nil))
307         (t (merror "draw (points2d): bad 2d array input format")))
308      (setf pts (make-array (* 2 n) :element-type 'flonum))
309      (loop for k below n do
310         (if twocolumns
311            (setf xx ($float (aref arg k 0))
312                  yy ($float (aref arg k 1)))
313            (setf xx ($float (aref arg 0 k))
314                  yy ($float (aref arg 1 k))))
315         (transform-point 2)
316         (check-extremes-x)
317         (check-extremes-y)
318         (setf (aref pts (incf pos)) xx)
319         (setf (aref pts (incf pos)) yy))
320      (update-ranges-2d xmin xmax ymin ymax)
321      (make-gr-object
322         :name 'points
323         :command (points-command)
324         :groups '((2 0)) ; numbers are sent to gnuplot in groups of 2
325         :points (list pts))))
326
327(defun points-array-1d (arg1 &optional (arg2 nil))
328   (let ((xmin most-positive-double-float)
329         (xmax most-negative-double-float)
330         (ymin most-positive-double-float)
331         (ymax most-negative-double-float)
332         (pos -1)
333         (dim (array-dimensions arg1))
334         n x y xx yy pts)
335      (cond
336         ((and (null arg2)
337               (= (length dim) 1))  ; y format
338            (setf n (car dim))
339            (setf x (make-array n
340                                :element-type 'flonum
341                                :initial-contents (loop for k from 1 to n collect ($float k)) ))
342            (setf y (make-array n
343                                :element-type 'flonum
344                                :initial-contents (loop for k below n collect ($float (aref arg1 k))))))
345         ((and (arrayp arg2)   ; xx yy format
346               (= (length dim) 1)
347               (equal dim (array-dimensions arg2)))
348            (setf n (car dim))
349            (setf x arg1
350                  y arg2))
351         (t (merror "draw (points2d): bad 1d array input format")))
352      (setf pts (make-array (* 2 n) :element-type 'flonum))
353      (loop for k below n do
354         (setf xx ($float (aref x k))
355               yy ($float (aref y k)))
356         (transform-point 2)
357         (check-extremes-x)
358         (check-extremes-y)
359         (setf (aref pts (incf pos)) xx)
360         (setf (aref pts (incf pos)) yy))
361      (update-ranges-2d xmin xmax ymin ymax)
362      (make-gr-object
363         :name 'points
364         :command (points-command)
365         :groups '((2 0)) ; numbers are sent to gnuplot in groups of 2
366         :points (list pts))))
367
368(defun points-list (arg1 &optional (arg2 nil))
369   (let (x y xmin xmax ymin ymax pts)
370      (cond
371            ((and ($listp arg1)
372                  (null arg2)
373                  (every #'$listp (rest arg1)))     ; xy format
374               (let ((tmp (mapcar #'rest (rest arg1))))
375                  (setf x (map 'list #'$float (map 'list #'first tmp))
376                        y (map 'list #'$float (map 'list #'second tmp)))) )
377            ((and ($matrixp arg1)
378                  (= (length (cadr arg1)) 3)
379                  (null arg2))                 ; two-column matrix
380               (let ((tmp (mapcar #'rest (rest arg1))))
381                  (setf x (map 'list #'$float (map 'list #'first tmp))
382                        y (map 'list #'$float (map 'list #'second tmp)) ) ) )
383            ((and ($listp arg1)
384                  (null arg2)
385                  (notany #'$listp (rest arg1)))   ; y format
386               (setf x (loop for xx from 1 to (length (rest arg1)) collect ($float xx))
387                     y (map 'list #'$float (rest arg1))))
388            ((and ($matrixp arg1)
389                  (= (length (cadr arg1)) 2)
390                  (null arg2))                 ; one-column matrix
391               (setf x (loop for xx from 1 to (length (rest arg1)) collect ($float xx))
392                     y (map 'list #'$float (map 'list #'second (rest arg1)))))
393            ((and ($matrixp arg1)
394                  (= ($length arg1) 1)
395                  (null arg2))                 ; one-row matrix
396               (setf x (loop for xx from 1 to (length (cdadr arg1)) collect ($float xx))
397                     y (map 'list #'$float (cdadr arg1))))
398            ((and ($listp arg1)
399                  ($listp arg2)
400                  (= (length arg1) (length arg2)))  ; xx yy format
401               (setf x (map 'list #'$float (rest arg1))
402                     y (map 'list #'$float (rest arg2))))
403            ((and ($matrixp arg1)
404                  (= ($length arg1) 2)
405                  (null arg2))            ; two-row matrix
406               (setf x (map 'list #'$float (cdadr arg1))
407                     y (map 'list #'$float (cdaddr arg1))))
408            (t (merror "draw (points2d): incorrect input format")))
409      (transform-lists 2)
410      (setf xmin ($tree_reduce 'min (cons '(mlist simp) x))
411            xmax ($tree_reduce 'max (cons '(mlist simp) x))
412            ymin ($tree_reduce 'min (cons '(mlist simp) y))
413            ymax ($tree_reduce 'max (cons '(mlist simp) y)) )
414      (setf pts (make-array (* 2 (length x)) :element-type 'flonum
415                                             :initial-contents (mapcan #'list x y)))
416      ;; update x-y ranges if necessary
417      (update-ranges-2d xmin xmax ymin ymax)
418      (make-gr-object
419         :name 'points
420         :command (points-command)
421         :groups '((2 0)) ; numbers are sent to gnuplot in groups of 2
422         :points (list pts) ) ))
423
424(defun points (arg1 &optional (arg2 nil))
425   (if (arrayp arg1)
426      (if (= (length (array-dimensions arg1)) 2)
427         (points-array-2d arg1)
428         (points-array-1d arg1 arg2))
429      (points-list arg1 arg2)))
430
431
432
433
434
435
436
437;; Object: 'points3d'
438;; Usage:
439;;     points([[x1,y1,z1], [x2,y2,z2], [x3,y3,z3],...])
440;;     points([x1,x2,x3,...], [y1,y2,y3,...], [z1,z2,z3,...])
441;;     points(matrix), three-column or three-row matrix
442;;     points(array2d),  three-column or three-row array
443;;     points(array1d, array1d, array1d, array1d)
444;; Options:
445;;     point_size
446;;     point_type
447;;     points_joined
448;;     line_width
449;;     key
450;;     line_type
451;;     color
452;;     enhanced3d
453;;     transform
454(defun points3d-command ()
455  (let ((pj (get-option '$points_joined))
456        (ps (get-option '$point_size))
457        (pt (get-option '$point_type))
458        (pal (if (> *draw-enhanced3d-type* 0)
459                 "palette"
460                 (hex-to-rgb (get-option '$color)) )))
461    (cond
462      ((null pj) ; draws isolated points
463         (format nil " ~a w p ps ~a pt ~a lc ~a"
464                 (make-obj-title (get-option '$key))
465                 ps
466                 pt
467                 pal ))
468      ((and (eq pj t) (or (= ps 0.0) (= pt 0)) ) ; draws joined points without symbols
469         (format nil " ~a w l lw ~a lt ~a lc ~a "
470                 (make-obj-title (get-option '$key))
471                 (get-option '$line_width)
472                 (get-option '$line_type)
473                 (hex-to-rgb (get-option '$color))))
474      ((eq pj t) ; draws joined points
475         (format nil " ~a w lp ps ~a pt ~a lw ~a lt ~a lc ~a"
476                 (make-obj-title (get-option '$key))
477                 ps
478                 pt
479                 (get-option '$line_width)
480                 (get-option '$line_type)
481                 pal ))
482      (t  ; draws impulses
483         (format nil " ~a w i lw ~a lt ~a lc ~a"
484                 (make-obj-title (get-option '$key))
485                 (get-option '$line_width)
486                 (get-option '$line_type)
487                 pal )))))
488
489(defun points3d (arg1 &optional (arg2 nil) (arg3 nil))
490   (let (pts x y z xmin xmax ymin ymax zmin zmax ncols col)
491      (check-enhanced3d-model "points" '(0 1 3))
492      (cond (($listp arg1)   ; list input
493               (cond ((and (every #'$listp (rest arg1))   ; xyz format
494                           (null arg2)
495                           (null arg3))
496                        (let ((tmp (mapcar #'rest (rest arg1))))
497                        (setf x (map 'list #'$float (map 'list #'first tmp))
498                              y (map 'list #'$float (map 'list #'second tmp))
499                              z (map 'list #'$float (map 'list #'third tmp)) ) ) )
500                     ((and ($listp arg2)                  ; xx yy zz format
501                           ($listp arg3)
502                           (= (length arg1) (length arg2) (length arg3)))
503                        (setf x (map 'list #'$float (rest arg1))
504                              y (map 'list #'$float (rest arg2))
505                              z (map 'list #'$float (rest arg3)) ))
506                     (t (merror "draw (points3d): bad list input format"))))
507            (($matrixp arg1)   ; matrix input
508               (cond ((and (= (length (cadr arg1)) 4)     ; three-column matrix
509                           (null arg2)
510                           (null arg3))
511                        (let ((tmp (mapcar #'rest (rest arg1))))
512                        (setf x (map 'list #'$float (map 'list #'first tmp))
513                              y (map 'list #'$float (map 'list #'second tmp))
514                              z (map 'list #'$float (map 'list #'third tmp)) ) ) )
515                     ((and (= ($length arg1) 3)           ; three-row matrix
516                           (null arg2)
517                           (null arg3))
518                        (setf x (map 'list #'$float (cdadr arg1))
519                              y (map 'list #'$float (cdaddr arg1))
520                              z (map 'list #'$float (cdaddr (rest arg1)) ) ) )
521                     (t (merror "draw (points3d): bad matrix input format"))))
522            ((arrayp arg1)   ; array input
523               (let ((dim (array-dimensions arg1)))
524               (cond ((and (= (length dim) 2)   ; three-row array
525                           (= (first dim) 3)
526                           (null arg2)
527                           (null arg3))
528                        (setf x (loop for k from 0 below (second dim)
529                                    collect ($float (aref arg1 0 k)))
530                              y (loop for k from 0 below (second dim)
531                                    collect ($float (aref arg1 1 k)))
532                              z (loop for k from 0 below (second dim)
533                                    collect ($float (aref arg1 2 k))) ))
534                     ((and (= (length dim) 2)   ; three-column array
535                           (= (second dim) 3)
536                           (null arg2)
537                           (null arg3))
538                        (setf x (loop for k from 0 below (first dim)
539                                    collect ($float (aref arg1 k 0)))
540                              y (loop for k from 0 below (first dim)
541                                    collect ($float (aref arg1 k 1)))
542                              z (loop for k from 0 below (first dim)
543                                    collect ($float (aref arg1 k 2))) ))
544                     ((and (= (length dim) 1)   ; three 1d arrays
545                           (arrayp arg2)
546                           (arrayp arg3)
547                           (equal dim (array-dimensions arg2))
548                           (equal dim (array-dimensions arg3)))
549                        (setf x (map 'list #'$float arg1)
550                              y (map 'list #'$float arg2)
551                              z (map 'list #'$float arg3) ) )
552                     (t (merror "draw (points3d): bad array input format")) ) ) )
553            (t (merror "draw (points3d): bad input format")))
554      (transform-lists 3)
555      ; set pm3d colors
556      (cond ((= *draw-enhanced3d-type* 0)
557                (setf ncols 3)
558                (setf pts (make-array (* ncols (length x))
559                                      :element-type 'flonum
560                                      :initial-contents (mapcan #'list x y z))))
561            ((= *draw-enhanced3d-type* 1)
562                (setf col (loop for k from 1 to (length x)
563                                collect (funcall *draw-enhanced3d-fun* k)))
564                (setf ncols 4)
565                (setf pts (make-array (* ncols (length x))
566                                      :element-type 'flonum
567                                      :initial-contents (mapcan #'list x y z col))))
568            ((= *draw-enhanced3d-type* 3)
569                (setf col (mapcar #'(lambda (xx yy zz) (funcall *draw-enhanced3d-fun* xx yy zz)) x y z))
570                (setf ncols 4)
571                (setf pts (make-array (* ncols (length x))
572                                      :element-type 'flonum
573                                      :initial-contents (mapcan #'list x y z col)))) )
574      (setf xmin ($tree_reduce 'min (cons '(mlist simp) x))
575            xmax ($tree_reduce 'max (cons '(mlist simp) x))
576            ymin ($tree_reduce 'min (cons '(mlist simp) y))
577            ymax ($tree_reduce 'max (cons '(mlist simp) y))
578            zmin ($tree_reduce 'min (cons '(mlist simp) z))
579            zmax ($tree_reduce 'max (cons '(mlist simp) z)) )
580      ;; update x-y-y ranges if necessary
581      (update-ranges-3d xmin xmax ymin ymax zmin zmax)
582      (make-gr-object
583         :name 'points
584         :command (points3d-command)
585         :groups `((,ncols 0)) ; numbers are sent to gnuplot in groups of 4 or 3
586                               ; (depending on colored 4th dimension or not), without blank lines
587         :points (list pts) )  ))
588
589
590
591
592
593
594;; Object: 'polygon'
595;; Usage:
596;;     polygon([[x1,y1], [x2,y2], [x3,y3],...])
597;;     polygon([x1,x2,x3,...], [y1,y2,y3,...])
598;; Options:
599;;     transparent
600;;     fill_color
601;;     border
602;;     line_width
603;;     line_type
604;;     color
605;;     key
606;;     xaxis_secondary
607;;     yaxis_secondary
608;;     transform
609(defun polygon (arg1 &optional (arg2 nil))
610   (if (and (get-option '$transparent)
611            (not (get-option '$border)))
612       (merror "draw (polygon): transparent is true and border is false; this is not consistent"))
613   (let (pltcmd pts grps x y xmin xmax ymin ymax)
614      (cond ((and ($listp arg1)
615                  (every #'$listp (rest arg1))
616                  (null arg2) )                    ; xy format
617               (let ((tmp (mapcar #'rest (rest arg1))))
618                  (setf x (map 'list #'(lambda (z) ($float (first z))) tmp)
619                        y (map 'list #'(lambda (z) ($float (second z))) tmp) ) )  )
620            ((and ($listp arg1)
621                  ($listp arg2)
622                  (= (length arg1) (length arg2)))  ; xx yy format
623               (setf x (map 'list #'$float (rest arg1))
624                     y (map 'list #'$float (rest arg2))) )
625            (t (merror "draw (polygon): bad input format"))  )
626      (transform-lists 2)
627      (setf xmin ($tree_reduce 'min (cons '(mlist simp) x))
628            xmax ($tree_reduce 'max (cons '(mlist simp) x))
629            ymin ($tree_reduce 'min (cons '(mlist simp) y))
630            ymax ($tree_reduce 'max (cons '(mlist simp) y)) )
631      ;; update x-y ranges if necessary
632      (update-ranges-2d xmin xmax ymin ymax)
633      (cond
634         ((get-option '$transparent)  ; if transparent, draw only the border
635             (setf pltcmd (format nil " ~a  w l lw ~a lt ~a lc ~a axis ~a"
636                                      (make-obj-title (get-option '$key))
637                                      (get-option '$line_width)
638                                      (get-option '$line_type)
639                                      (hex-to-rgb (get-option '$color))
640                                      (axes-to-plot)))
641             (setf grps '((2 0)))  ; numbers are sent to gnuplot in groups of 2
642             (setf pts (list (make-array (+ (* 2 (length x)) 2)
643                                         :element-type 'flonum
644                                         :initial-contents (append (mapcan #'list x y)
645                                                                   (list (first x) (first y))) )) ) )
646         ((not (get-option '$border)) ; no transparent, no border
647             (setf pltcmd (format nil " ~a w filledcurves lc ~a axis ~a"
648                                      (make-obj-title (get-option '$key))
649                                      (hex-to-rgb (get-option '$fill_color))
650                                      (axes-to-plot)))
651             (setf grps '((2 0)))  ; numbers are sent to gnuplot in groups of 2
652             (setf pts (list (make-array (* 2 (length x))
653                                         :element-type 'flonum
654                                         :initial-contents (mapcan #'list x y)) ) ))
655         (t ; no transparent with border
656             (setf pltcmd (list (format nil " ~a w filledcurves lc ~a axis ~a"
657                                        (make-obj-title (get-option '$key))
658                                        (hex-to-rgb (get-option '$fill_color))
659                                        (axes-to-plot))
660                                (format nil " t '' w l lw ~a lt ~a lc ~a axis ~a"
661                                        (get-option '$line_width)
662                                        (get-option '$line_type)
663                                        (hex-to-rgb (get-option '$color))
664                                        (axes-to-plot))))
665             (setf grps '((2 0) (2 0)))  ; both sets of vertices (interior and border)
666                                     ; are sent to gnuplot in groups of 2
667             (setf pts (list (make-array (* 2 (length x))
668                                         :element-type 'flonum
669                                         :initial-contents (mapcan #'list x y))
670                             (make-array (+ (* 2 (length x)) 2)
671                                         :element-type 'flonum
672                                         :initial-contents (append (mapcan #'list x y)
673                                                                   (list (first x) (first y))))))))
674      (make-gr-object
675         :name   'polygon
676         :command pltcmd
677         :groups  grps
678         :points  pts )))
679
680
681
682
683
684
685
686;; Object: 'triangle'
687;; Usage:
688;;     triangle([x1,y1], [x2,y2], [x3,y3])
689;; Options:
690;;     transparent
691;;     fill_color
692;;     border
693;;     line_width
694;;     line_type
695;;     color
696;;     key
697;;     xaxis_secondary
698;;     yaxis_secondary
699;;     transform
700(defun triangle (arg1 arg2 arg3)
701   (if (or (not ($listp arg1))
702           (not (= ($length arg1) 2))
703           (not ($listp arg2))
704           (not (= ($length arg2) 2))
705           (not ($listp arg3))
706           (not (= ($length arg3) 2)))
707       (merror "draw2d (triangle): vertices are not correct"))
708   (let* ((x1 ($float (cadr arg1)))
709          (y1 ($float (caddr arg1)))
710          (x2 ($float (cadr arg2)))
711          (y2 ($float (caddr arg2)))
712          (x3 ($float (cadr arg3)))
713          (y3 ($float (caddr arg3)))
714          (grobj (polygon `((mlist simp)
715                            ((mlist simp) ,x1 ,y1)
716                            ((mlist simp) ,x2 ,y2)
717                            ((mlist simp) ,x3 ,y3)
718                            ((mlist simp) ,x1 ,y1)))))
719      (setf (gr-object-name grobj) 'triangle)
720      grobj))
721
722
723
724
725
726
727;; Object: 'quadrilateral'
728;; Usage:
729;;     quadrilateral([x1,y1], [x2,y2], [x3,y3], [x4,y4])
730;; Options:
731;;     transparent
732;;     fill_color
733;;     border
734;;     line_width
735;;     line_type
736;;     color
737;;     key
738;;     xaxis_secondary
739;;     yaxis_secondary
740;;     transform
741(defun quadrilateral (arg1 arg2 arg3 arg4)
742   (if (or (not ($listp arg1))
743           (not (= ($length arg1) 2))
744           (not ($listp arg2))
745           (not (= ($length arg2) 2))
746           (not ($listp arg3))
747           (not (= ($length arg3) 2))
748           (not ($listp arg4))
749           (not (= ($length arg4) 2)))
750       (merror "draw2d (quadrilateral): vertices are not correct"))
751   (let* ((x1 ($float (cadr arg1)))
752          (y1 ($float (caddr arg1)))
753          (x2 ($float (cadr arg2)))
754          (y2 ($float (caddr arg2)))
755          (x3 ($float (cadr arg3)))
756          (y3 ($float (caddr arg3)))
757          (x4 ($float (cadr arg4)))
758          (y4 ($float (caddr arg4)))
759          (grobj (polygon `((mlist simp)
760                            ((mlist simp) ,x1 ,y1)
761                            ((mlist simp) ,x2 ,y2)
762                            ((mlist simp) ,x3 ,y3)
763                            ((mlist simp) ,x4 ,y4)
764                            ((mlist simp) ,x1 ,y1)))))
765      (setf (gr-object-name grobj) 'quadrilateral)
766      grobj))
767
768
769
770
771
772
773
774;; Object: 'rectangle'
775;; Usage:
776;;     rectangle([x1,y1], [x2,y2]), being [x1,y1] & [x2,y2] opposite vertices
777;; Options:
778;;     transparent
779;;     fill_color
780;;     border
781;;     line_width
782;;     line_type
783;;     color
784;;     key
785;;     xaxis_secondary
786;;     yaxis_secondary
787;;     transform
788(defun rectangle (arg1 arg2)
789   (if (or (not ($listp arg1))
790           (not (= ($length arg1) 2))
791           (not ($listp arg2))
792           (not (= ($length arg2) 2)))
793       (merror "draw2d (rectangle): vertices are not correct"))
794   (let* ((x1 ($float (cadr arg1)))
795          (y1 ($float (caddr arg1)))
796          (x2 ($float (cadr arg2)))
797          (y2 ($float (caddr arg2)))
798          (grobj (polygon `((mlist simp)
799                            ((mlist simp) ,x1 ,y1)
800                            ((mlist simp) ,x2 ,y1)
801                            ((mlist simp) ,x2 ,y2)
802                            ((mlist simp) ,x1 ,y2)
803                            ((mlist simp) ,x1 ,y1)))))
804      (setf (gr-object-name grobj) 'rectangle)
805      grobj))
806
807
808
809
810
811
812
813;; Object: 'ellipse'
814;; Usage:
815;;     ellipse(xc, yc, a, b, ang1 ang2)
816;; Options:
817;;     nticks
818;;     transparent
819;;     fill_color
820;;     border
821;;     line_width
822;;     line_type
823;;     key
824;;     color
825;;     xaxis_secondary
826;;     yaxis_secondary
827;;     transform
828(defun ellipse (xc yc a b ang1 ang2)
829  (if (and (get-option '$transparent)
830           (not (get-option '$border)))
831      (merror "draw2d (ellipse): transparent is true and border is false; this is not consistent"))
832  (let ((fxc ($float xc))
833        (fyc ($float yc))
834        (fa ($float a))
835        (fb ($float b))
836        (fang1 ($float ang1))
837        (fang2 ($float ang2))
838        (nticks (get-option '$nticks))
839        (xmin most-positive-double-float)
840        (xmax most-negative-double-float)
841        (ymin most-positive-double-float)
842        (ymax most-negative-double-float)
843        (result nil)
844        pts grps tmin tmax eps xx yy tt pltcmd)
845    (when (or (notevery #'floatp (list fxc fyc fa fb fang1 fang2))
846              (<= fa 0.0)
847              (<= fb 0.0))
848       (merror "draw (ellipse): illegal argument(s)"))
849    ; degrees to radians
850    (setf fang1 (* 0.017453292519943295 fang1)
851          fang2 (* 0.017453292519943295 fang2))
852    (setf tmin (min fang1 (+ fang1 fang2))
853          tmax (max fang1 (+ fang1 fang2))
854          eps (/ (- tmax tmin) (- nticks 1)))
855    (setf tt tmin)
856    (loop
857      (setf xx (+ fxc (* fa (cos tt))))
858      (setf yy (+ fyc (* fb (sin tt))))
859      (transform-point 2)
860      (check-extremes-x)
861      (check-extremes-y)
862      (setf result (append (list xx yy) result))
863      (if (>= tt tmax) (return))
864      (setf tt (+ tt eps))
865      (if (>= tt tmax) (setq tt tmax)) )
866    (when (> *draw-transform-dimensions* 0)
867      (let ((xold fxc)
868            (yold fyc))
869        (setf fxc (funcall *draw-transform-f1* xold yold)
870              fyc (funcall *draw-transform-f2* xold yold))) )
871    ; update x-y ranges if necessary
872    (setf xmin (min fxc xmin)
873          xmax (max fxc xmax)
874          ymin (min fyc ymin)
875          ymax (max fyc ymax))
876    (update-ranges-2d xmin xmax ymin ymax)
877    (cond
878       ((get-option '$transparent)  ; if transparent, draw only the border
879           (setf pltcmd (format nil " ~a w l lw ~a lt ~a lc ~a axis ~a"
880                                    (make-obj-title (get-option '$key))
881                                    (get-option '$line_width)
882                                    (get-option '$line_type)
883                                    (hex-to-rgb (get-option '$color))
884                                    (axes-to-plot)))
885           (setf grps '((2 0)))
886           (setf pts `( ,(make-array (length result) :element-type 'flonum
887                                                    :initial-contents result)))  )
888       ((not (get-option '$border)) ; no transparent, no border
889           (setf pltcmd (format nil " ~a w filledcurves xy=~a,~a lc ~a axis ~a"
890                                    (make-obj-title (get-option '$key))
891                                    fxc fyc
892                                    (hex-to-rgb (get-option '$fill_color))
893                                    (axes-to-plot)))
894           (setf grps '((2 0)))
895           (setf pts `( ,(make-array (length result) :element-type 'flonum
896                                                    :initial-contents result)))  )
897       (t ; no transparent with border
898             (setf pltcmd (list (format nil " ~a w filledcurves xy=~a,~a lc ~a axis ~a"
899                                            (make-obj-title (get-option '$key))
900                                            fxc fyc
901                                            (hex-to-rgb (get-option '$fill_color))
902                                            (axes-to-plot))
903                                (format nil " t '' w l lw ~a lt ~a lc ~a axis ~a"
904                                            (get-option '$line_width)
905                                            (get-option '$line_type)
906                                            (hex-to-rgb (get-option '$color))
907                                            (axes-to-plot))))
908           (setf grps '((2 0) (2 0)))
909           (setf pts (list (make-array (length result) :element-type 'flonum
910                                                       :initial-contents result)
911                           (make-array (length result) :element-type 'flonum
912                                                       :initial-contents result)))  ))
913    (make-gr-object
914       :name    'ellipse
915       :command pltcmd
916       :groups  grps
917       :points  pts ) ))
918
919
920
921
922
923
924
925
926;; Object: 'label'
927;; Usage in 2d:
928;;     label([string1,xx1,y1],[string2,xx2,y2],...)
929;; Usage in 3d:
930;;     label([string1,x1,y1,z1],[string2,x2,y2,z2],...)
931;; Options:
932;;     label_alignment
933;;     label_orientation
934;;     color
935;;     xaxis_secondary
936;;     yaxis_secondary
937
938(defun replace-substring (string part replacement)
939    (with-output-to-string (out)
940      (loop with part-length = (length part)
941            for old-pos = 0 then (+ pos part-length)
942            for pos = (search part string
943                              :start2 old-pos
944                              :test #'char=)
945            do (write-string string out
946                             :start old-pos
947                             :end (or pos (length string)))
948            when pos do (write-string replacement out)
949            while pos)))
950
951(defun label (&rest lab)
952  (let ((n (length lab))
953        (result nil)
954        is2d)
955    (cond ((= n 0)
956            (merror "draw (label): no arguments in object labels"))
957          ((every #'$listp lab)
958            (cond ((every #'(lambda (z) (= 3 ($length z))) lab)   ; labels in 2d
959                    (setf is2d t))
960                  ((every #'(lambda (z) (= 4 ($length z))) lab)   ; labels in 3d
961                    (setf is2d nil))
962                  (t
963                    (merror "draw (label): arguments of not equal length")))
964            (cond (is2d
965                    (let (fx fy text)
966                      (dolist (k lab)
967                        (setf fx   ($float ($second k))
968                              fy   ($float ($third k))
969                              ; backslashes are replaced by double backslashes to allow LaTeX code in labels.
970                              text (format nil "\"~a\"" (replace-substring ($first k) "\\" "\\\\")))
971                        (if (or (not (floatp fx))
972                                (not (floatp fy)))
973                            (merror "draw (label): non real 2d coordinates"))
974                        (update-ranges-2d fx fx fy fy)
975                        (setf result (append (list fx fy text) result)))))
976                  (t ; labels in 3d
977                    (let (fx fy fz text)
978                      (dolist (k lab)
979                        (setf fx   ($float ($second k))
980                              fy   ($float ($third k))
981                              fz   ($float ($fourth k))
982                              text (format nil "\"~a\"" ($first k)) )
983                        (if (or (not (floatp fx))
984                                (not (floatp fy))
985                                (not (floatp fz)))
986                            (merror "draw (label): non real 3d coordinates"))
987                        (update-ranges-3d fx fx fy fy fz fz)
988                        (setf result (append (list fx fy fz text) result)))))) )
989          (t (merror "draw (label): illegal arguments")))
990    (make-gr-object
991       :name 'label
992       :command (format nil " t '' w labels ~a ~a tc ~a ~a"
993                              (case (get-option '$label_alignment)
994                                 ($center "center")
995                                 ($left   "left")
996                                 ($right  "right"))
997                              (case (get-option '$label_orientation)
998                                 ($horizontal "norotate")
999                                 ($vertical  "rotate"))
1000                              (hex-to-rgb (get-option '$color))
1001                              (if is2d
1002                                 (format nil "axis ~a" (axes-to-plot))
1003                                 "") )
1004       :groups (if is2d '((3 0)) '((4 0)))
1005       :points (list (make-array (length result) :initial-contents result))) ))
1006
1007
1008
1009
1010
1011
1012
1013;; Object: 'bars'
1014;;     bars([x1,h1,w1],[x2,h2,w2],...), x, height and width
1015;; Options:
1016;;     key
1017;;     fill_color
1018;;     fill_density
1019;;     line_width
1020;;     xaxis_secondary
1021;;     yaxis_secondary
1022(defun bars (&rest boxes)
1023  (let ((n (length boxes))
1024        (count -1)
1025        (xmin most-positive-double-float)
1026        (xmax most-negative-double-float)
1027        (ymin most-positive-double-float)
1028        (ymax most-negative-double-float)
1029        result x h w w2)
1030    (when (= n 0)
1031      (merror "draw2d (bars): no arguments in object bars"))
1032    (when (not (every #'(lambda (z) (and ($listp z) (= 3 ($length z)))) boxes))
1033      (merror "draw2d (bars): arguments must be lists of length three"))
1034    (setf result (make-array (* 3 n) :element-type 'flonum))
1035    (dolist (k boxes)
1036       (setf x ($float ($first k))
1037             h ($float ($second k))
1038             w ($float ($third k)))
1039       (setf w2 (/ w 2))
1040       (setf (aref result (incf count)) x
1041             (aref result (incf count)) h
1042             (aref result (incf count)) w)
1043       (setf xmin (min xmin (- x w2))
1044             xmax (max xmax (+ x w2))
1045             ymin (min ymin h)
1046             ymax (max ymax h)) )
1047    (update-ranges-2d xmin xmax ymin ymax)
1048    (make-gr-object
1049       :name 'bars
1050       :command (format nil " ~a w boxes fs solid ~a lw ~a lc ~a axis ~a"
1051                            (make-obj-title (get-option '$key))
1052                            (get-option '$fill_density)
1053                            (get-option '$line_width)
1054                            (hex-to-rgb (get-option '$fill_color))
1055                            (axes-to-plot) )
1056       :groups '((3 0))  ; numbers are sent to gnuplot in groups of 3, without blank lines
1057       :points (list (make-array (length result) :initial-contents result))) ))
1058
1059
1060
1061
1062
1063
1064
1065
1066;; Object: 'vector'
1067;; Usage:
1068;;     vector([x,y], [dx,dy]), represents vector from [x,y] to [x+dx,y+dy]
1069;; Options:
1070;;     head_both
1071;;     head_length
1072;;     head_angle
1073;;     head_type
1074;;     line_width
1075;;     line_type
1076;;     key
1077;;     color
1078;;     unit_vectors
1079;;     xaxis_secondary
1080;;     yaxis_secondary
1081(defun vect (arg1 arg2)
1082   (if (or (not ($listp arg1))
1083           (not (= ($length arg1) 2))
1084           (not ($listp arg2))
1085           (not (= ($length arg2) 2)))
1086       (merror "draw (vector): coordinates are not correct"))
1087   (let ((xo ($float (cadr arg1)))
1088         (yo ($float (caddr arg1)))
1089         (dx ($float (cadr arg2)))
1090         (dy ($float (caddr arg2)))
1091         xdx ydy x y)
1092      (when (and (get-option '$unit_vectors)
1093                 (or (/= dx 0) (/= dy 0)))
1094         (let ((module (sqrt (+ (* dx dx) (* dy dy)))))
1095            (setf dx (/ dx module)
1096                  dy (/ dy module) )))
1097      (setf xdx ($float (+ xo dx))
1098            ydy ($float (+ yo dy)))
1099      ;; apply geometric transformation before plotting
1100      (setf x (list xo xdx)
1101            y (list yo ydy))
1102      (transform-lists 2)
1103      (update-ranges-2d (apply 'min x) (apply 'max x) (apply 'min y) (apply 'max y))
1104      (make-gr-object
1105         :name 'vector
1106         :command (format nil " ~a w vect ~a size ~a, ~a ~a lw ~a lt ~a lc ~a axis ~a"
1107                              (make-obj-title (get-option '$key))
1108                              (if (get-option '$head_both) "heads" "head")
1109                              (get-option '$head_length)
1110                              (get-option '$head_angle)
1111                              (case (get-option '$head_type)
1112                                 ($filled   "filled")
1113                                 ($empty    "empty")
1114                                 ($nofilled "nofilled"))
1115                              (get-option '$line_width)
1116                              (get-option '$line_type)
1117                              (hex-to-rgb (get-option '$color))
1118                              (axes-to-plot) )
1119         :groups '((4 0))
1120         :points `(,(make-array 4 :element-type 'flonum
1121                                  :initial-contents (list (car x)
1122                                                          (car y)
1123                                                          (- (cadr x) (car x))
1124                                                          (- (cadr y) (car y))))) ) ))
1125
1126
1127
1128
1129
1130
1131
1132;; Object: 'vector3d'
1133;; Usage:
1134;;     vector([x,y,z], [dx,dy,dz]), represents vector from [x,y,z] to [x+dx,y+dy,z+dz]
1135;; Options:
1136;;     head_both
1137;;     head_length
1138;;     head_angle
1139;;     head_type
1140;;     line_width
1141;;     line_type
1142;;     key
1143;;     color
1144;;     unit_vectors
1145(defun vect3d (arg1 arg2)
1146   (if (or (not ($listp arg1))
1147           (not (= ($length arg1) 3))
1148           (not ($listp arg2))
1149           (not (= ($length arg2) 3)))
1150       (merror "draw (vector): coordinates are not correct"))
1151   (let ((xo ($float (cadr arg1)))
1152         (yo ($float (caddr arg1)))
1153         (zo ($float (cadddr arg1)))
1154         (dx ($float (cadr arg2)))
1155         (dy ($float (caddr arg2)))
1156         (dz ($float (cadddr arg2)))
1157         xdx ydy zdz x y z)
1158      (when (and (get-option '$unit_vectors)
1159                 (or (/= dx 0) (/= dy 0) (/= dz 0)))
1160         (let ((module (sqrt (+ (* dx dx) (* dy dy) (* dz dz)))))
1161            (setf dx (/ dx module)
1162                  dy (/ dy module)
1163                  dz (/ dz module)  )))
1164      (setf xdx ($float (+ xo dx))
1165            ydy ($float (+ yo dy))
1166            zdz ($float (+ zo dz)) )
1167      ;; apply geometric transformation before plotting
1168      (setf x (list xo xdx)
1169            y (list yo ydy)
1170            z (list zo zdz))
1171      (transform-lists 3)
1172      (update-ranges-3d (apply 'min x) (apply 'max x) (apply 'min y) (apply 'max y) (apply 'min z) (apply 'max z))
1173      (make-gr-object
1174         :name 'vector
1175         :command (format nil " ~a w vect ~a size ~a, ~a ~a lw ~a lt ~a lc ~a"
1176                              (make-obj-title (get-option '$key))
1177                              (if (get-option '$head_both) "heads" "head")
1178                              (get-option '$head_length)
1179                              (get-option '$head_angle)
1180                              (case (get-option '$head_type)
1181                                 ($filled   "filled")
1182                                 ($empty    "empty")
1183                                 ($nofilled "nofilled"))
1184                              (get-option '$line_width)
1185                              (get-option '$line_type)
1186                              (hex-to-rgb (get-option '$color)) )
1187         :groups '((6 0))
1188         :points `(,(make-array 6 :element-type 'flonum
1189                                  :initial-contents (list (car x)
1190                                                          (car y)
1191                                                          (car z)
1192                                                          (- (cadr x) (car x))
1193                                                          (- (cadr y) (car y))
1194                                                          (- (cadr z) (car z))))) ) ))
1195
1196
1197
1198
1199
1200
1201
1202
1203;; Object: 'explicit'
1204;; Usage:
1205;;     explicit(fcn,var,minval,maxval)
1206;; Options:
1207;;     nticks
1208;;     adapt_depth
1209;;     line_width
1210;;     line_type
1211;;     color
1212;;     filled_func
1213;;     fill_color
1214;;     key
1215;;     xaxis_secondary
1216;;     yaxis_secondary
1217(defun explicit (fcn var minval maxval)
1218  (let* ((nticks (get-option '$nticks))
1219         (depth (get-option '$adapt_depth))
1220         ($numer t)
1221         (xmin ($float minval))
1222         (xmax ($float maxval))
1223         (x-step (/ (- xmax xmin) ($float nticks) 2))
1224         (ymin most-positive-double-float)
1225         (ymax most-negative-double-float)
1226         (*plot-realpart* *plot-realpart*)
1227         x-samples y-samples yy result pltcmd result-array)
1228    (when (< xmax xmin)
1229       (merror "draw2d (explicit): illegal range"))
1230    (setq *plot-realpart* (get-option '$draw_realpart))
1231    (setq fcn (coerce-float-fun fcn `((mlist) ,var)))
1232    (when (get-option '$logx)
1233      (setf xmin (log xmin))
1234      (setf xmax (log xmax))
1235      (setf x-step (/ (- xmax xmin) ($float nticks) 2)))
1236    (flet ((fun (x)
1237               (let ((y (if (get-option '$logx)
1238                            (funcall fcn (exp x))
1239                            (funcall fcn x))))
1240                 (if (and (get-option '$logy)
1241                          (numberp y))
1242                     (if (> y 0)
1243                       (log y)
1244                       (merror "draw2d (explicit): logarithm of negative number"))
1245                     y))))
1246      (dotimes (k (1+ (* 2 nticks)))
1247        (let ((x (+ xmin (* k x-step))))
1248          (push x x-samples)
1249          (push (fun x) y-samples)))
1250      (setf x-samples (nreverse x-samples))
1251      (setf y-samples (nreverse y-samples))
1252      ;; For each region, adaptively plot it.
1253      (do ((x-start x-samples (cddr x-start))
1254           (x-mid (cdr x-samples) (cddr x-mid))
1255           (x-end (cddr x-samples) (cddr x-end))
1256           (y-start y-samples (cddr y-start))
1257           (y-mid (cdr y-samples) (cddr y-mid))
1258           (y-end (cddr y-samples) (cddr y-end)))
1259          ((null x-end))
1260        ;; The region is x-start to x-end, with mid-point x-mid.
1261        (let ((sublst (adaptive-plot #'fun (car x-start) (car x-mid) (car x-end)
1262                                           (car y-start) (car y-mid) (car y-end)
1263                                           depth 1e-5)))
1264          (when (notevery #'(lambda (x) (or (numberp x) (eq x t) (eq x nil))) sublst)
1265            (let ((items sublst) (item 'nil))
1266	      ;; Search for the item in sublist that is the undefined variable
1267	      (while items
1268		(when (not (or (numberp (car items))
1269                               (eq (car items) t)
1270                               (eq (car items) nil)))
1271		    (setq item (car items)) )
1272		(setq items (cdr items)) )
1273	      (merror "draw2d (explicit): non defined variable in term: ~M" item) ) )
1274
1275          (when (not (null result))
1276            (setf sublst (cddr sublst)))
1277          (do ((lst sublst (cddr lst)))
1278              ((null lst) 'done)
1279            (setf result (cons (if (and (get-option '$logy) (numberp (second lst)))
1280                                 (exp (second lst))
1281                                 (second lst))
1282                               result))
1283            (setf result (cons (if (and (get-option '$logx) (numberp (first lst)))
1284                                 (exp (first lst))
1285                                 (first lst))
1286                               result)) ) )))
1287
1288    ; reset x extremes to original values
1289    (when (get-option '$logx)
1290      (setf xmin (exp xmin))
1291      (setf xmax (exp xmax)))
1292
1293    (cond ((null (get-option '$filled_func))
1294             (cond
1295               ((> *draw-transform-dimensions* 0)
1296                  ; With geometric transformation.
1297                  ; When option filled_func in not nil,
1298                  ; geometric transformation is ignored
1299                  (setf result-array (make-array (length result)))
1300                  (setf xmin most-positive-double-float
1301                        xmax most-negative-double-float)
1302                  (let (xold yold x y (count -1))
1303                    (do ((lis result (cddr lis)))
1304                        ((null lis))
1305                      (setf xold (first lis)
1306                            yold (second lis))
1307                      (setf x (funcall *draw-transform-f1* xold yold)
1308                            y (funcall *draw-transform-f2* xold yold))
1309                      (if (> x xmax) (setf xmax x))
1310                      (if (< x xmin) (setf xmin x))
1311                      (if (> y ymax) (setf ymax y))
1312                      (if (< y ymin) (setf ymin y))
1313                      (setf (aref result-array (incf count)) x)
1314                      (setf (aref result-array (incf count)) y)  )  ) )
1315               (t
1316                  ; No geometric transformation invoked.
1317                  (do ((y (cdr result) (cddr y)))
1318                      ((null y))
1319                    (setf yy (car y))
1320                    (check-extremes-y))
1321                  (setf result-array (make-array (length result)
1322                                                 :initial-contents result))))
1323             (update-ranges-2d xmin xmax ymin ymax)
1324             (setf pltcmd (format nil " ~a w l lw ~a lt ~a lc ~a axis ~a"
1325                                      (make-obj-title (get-option '$key))
1326                                      (get-option '$line_width)
1327                                      (get-option '$line_type)
1328                                      (hex-to-rgb (get-option '$color))
1329                                      (axes-to-plot)))
1330             (make-gr-object
1331                :name   'explicit
1332                :command pltcmd
1333                :groups '((2 0))  ; numbers are sent to gnuplot in groups of 2
1334                :points  (list result-array )) )
1335          ((equal (get-option '$filled_func) t)
1336             (do ((y (cdr result) (cddr y)))
1337                 ((null y))
1338                (setf yy (car y))
1339                (check-extremes-y))
1340             (update-ranges-2d xmin xmax ymin ymax)
1341             (setf result-array (make-array (length result)
1342                                            :element-type 'flonum
1343                                            :initial-contents result))
1344             (setf pltcmd (format nil " ~a w filledcurves x1 lc ~a axis ~a"
1345                                      (make-obj-title (get-option '$key))
1346                                      (hex-to-rgb (get-option '$fill_color))
1347                                      (axes-to-plot)))
1348             (make-gr-object
1349                :name   'explicit
1350                :command pltcmd
1351                :groups '((2 0))  ; numbers are sent to gnuplot in groups of 2
1352                :points  (list result-array )))
1353          (t
1354             (let (fcn2 yy2 (count -1))
1355                (setf result-array (make-array (* (/ (length result) 2) 3)
1356                                               :element-type 'flonum))
1357                (setq fcn2 (coerce-float-fun (get-option '$filled_func) `((mlist), var)))
1358                (flet ((fun (x) (funcall fcn2 x)))
1359                  (do ((xx result (cddr xx)))
1360                    ((null xx))
1361                    (setf yy  (second xx)
1362                          yy2 (fun (first xx)))
1363                    (setf ymax (max ymax yy yy2)
1364                          ymin (min ymin yy yy2))
1365                    (setf (aref result-array (incf count)) (first xx)
1366                          (aref result-array (incf count)) yy
1367                          (aref result-array (incf count)) yy2) )  ))
1368             (update-ranges-2d xmin xmax ymin ymax)
1369             (setf pltcmd (format nil " ~a w filledcurves lc ~a axis ~a"
1370                                      (make-obj-title (get-option '$key))
1371                                      (hex-to-rgb (get-option '$fill_color))
1372                                      (axes-to-plot)  ))
1373             (make-gr-object
1374                :name   'explicit
1375                :command pltcmd
1376                :groups '((3 0))  ; numbers are sent to gnuplot in groups of 3
1377                :points  (list result-array))))  ))
1378
1379
1380
1381
1382
1383
1384
1385;; Object: 'region'
1386;; Usage:
1387;;     region(ineq,x-var,x-minval,x-maxval,y-var,y-minval,y-maxval)
1388;; Options:
1389;;     fill_color
1390;;     key
1391;;     x_voxel
1392;;     y_voxel
1393(defmacro build-polygon (coord)
1394  (let ((len (1- (length coord))))
1395    `(push (make-array ,len :element-type 'flonum :initial-contents ,coord) pts)))
1396
1397(defun region (ineq x-var x-minval x-maxval y-var y-minval y-maxval)
1398  (let* ((nx (get-option '$x_voxel))
1399         (ny (get-option '$y_voxel))
1400         (xmin ($float x-minval))
1401         (xmax ($float x-maxval))
1402         (ymin ($float y-minval))
1403         (ymax ($float y-maxval))
1404         (dx (/ (- xmax xmin) nx))
1405         (dy (/ (- ymax ymin) ny))
1406         (err (* 0.02 (min dx dy)))
1407         (xarr (make-array (list (1+ nx) (1+ ny)) :element-type 'flonum))
1408         (yarr (make-array (list (1+ nx) (1+ ny)) :element-type 'flonum))
1409         (barr (make-array (list (1+ nx) (1+ ny)) :initial-element nil :element-type 'boolean))
1410         (pts '())
1411         pltcmd grouping x y)
1412
1413    (when (not (subsetp (rest ($listofvars ineq)) (list x-var y-var)))
1414       (merror "draw2d (region): non defined variable"))
1415
1416    ; build 2d arrays: x, y and boolean
1417    (labels ((fun (xx yy)  ; evaluates boolean expression
1418                  (is-boole-check
1419                    (simplify
1420                      ($substitute
1421                        (list '(mlist)
1422                              (list '(mequal) x-var xx)
1423                              (list '(mequal) y-var yy))
1424                        ineq))))
1425             (bipart (xx1 yy1 xx2 yy2) ; bipartition, (xx1, yy1) => T, (xx2, yy2) => NIL
1426                     (let ((xm (* 0.5 (+ xx1 xx2)))
1427                           (ym (* 0.5 (+ yy1 yy2))))
1428                       (cond
1429                         ((< (+ (* (- xx2 xx1) (- xx2 xx1))
1430                                (* (- yy2 yy1) (- yy2 yy1)))
1431                             (* err err))
1432                            (list xm ym))
1433                         ((fun xm ym)
1434                            (bipart xm ym xx2 yy2))
1435                         (t
1436                            (bipart xx1 yy1 xm ym)) ))  ))
1437      ; fill arrays
1438      (loop for i to nx do
1439        (loop for j to ny do
1440          (setf x (+ xmin (* i dx)))
1441          (setf y (+ ymin (* j dy)))
1442          (setf (aref xarr i j) x)
1443          (setf (aref yarr i j) y)
1444          (setf (aref barr i j) (fun x y))))
1445      ; check vertices of rectangles and cuts
1446      (loop for i below nx do
1447        (loop for j below ny do
1448          (let ((x1 (aref xarr i j))            ; SW point
1449                (y1 (aref yarr i j))
1450                (b1 (aref barr i j))
1451                (x2 (aref xarr (1+ i) j))       ; SE point
1452                (y2 (aref yarr (1+ i) j))
1453                (b2 (aref barr (1+ i) j))
1454                (x3 (aref xarr (1+ i) (1+ j)))  ; NE point
1455                (y3 (aref yarr (1+ i) (1+ j)))
1456                (b3 (aref barr (1+ i) (1+ j)))
1457                (x4 (aref xarr i (1+ j)))       ; NW point
1458                (y4 (aref yarr i (1+ j)))
1459                (b4 (aref barr i (1+ j)))
1460                pa pb pc)    ; pa and pb are frontier points
1461
1462            (cond ((and b1 b2 b3 b4)
1463                     (build-polygon (list x1 y1 x2 y2 x3 y3 x4 y4)))
1464                  ((and b1 b2 b3)
1465                     (setf pa (bipart x3 y3 x4 y4)
1466                           pb (bipart x1 y1 x4 y4))
1467                     (build-polygon (list x1 y1 x2 y2 x3 y3 (first pa) (second pa) (first pb) (second pb))))
1468                  ((and b4 b1 b2)
1469                     (setf pa (bipart x2 y2 x3 y3)
1470                           pb (bipart x4 y4 x3 y3))
1471                     (build-polygon (list x4 y4 x1 y1 x2 y2 (first pa) (second pa) (first pb) (second pb))))
1472                  ((and b3 b4 b1)
1473                     (setf pa (bipart x1 y1 x2 y2)
1474                           pb (bipart x3 y3 x2 y2))
1475                     (build-polygon (list x3 y3 x4 y4 x1 y1 (first pa) (second pa) (first pb) (second pb))))
1476                  ((and b2 b3 b4)
1477                     (setf pa (bipart x4 y4 x1 y1)
1478                           pb (bipart x2 y2 x1 y1))
1479                     (build-polygon (list x2 y2 x3 y3 x4 y4 (first pa) (second pa) (first pb) (second pb))))
1480                  ((and b2 b3)
1481                     (setf pa (bipart x3 y3 x4 y4)
1482                           pb (bipart x2 y2 x1 y1))
1483                     (build-polygon (list x2 y2 x3 y3 (first pa) (second pa) (first pb) (second pb))))
1484                  ((and b4 b1)
1485                     (setf pa (bipart x1 y1 x2 y2)
1486                           pb (bipart x4 y4 x3 y3))
1487                     (build-polygon (list x4 y4 x1 y1 (first pa) (second pa) (first pb) (second pb))))
1488                  ((and b3 b4)
1489                     (setf pa (bipart x4 y4 x1 y1)
1490                           pb (bipart x3 y3 x2 y2))
1491                     (build-polygon (list x3 y3 x4 y4 (first pa) (second pa) (first pb) (second pb))))
1492                  ((and b1 b2)
1493                     (setf pa (bipart x2 y2 x3 y3)
1494                           pb (bipart x1 y1 x4 y4))
1495                     (build-polygon (list x1 y1 x2 y2 (first pa) (second pa) (first pb) (second pb))))
1496                  (b1
1497                     (setf pa (bipart x1 y1 x2 y2)
1498                           pb (bipart x1 y1 x3 y4)
1499                           pc (bipart x1 y1 x4 y4))
1500                     (build-polygon (list x1 y1 (first pa) (second pa) (first pb) (second pb)(first pc) (second pc))))
1501                  (b2
1502                     (setf pa (bipart x2 y2 x3 y3)
1503                           pb (bipart x2 y2 x4 y4)
1504                           pc (bipart x2 y2 x1 y1))
1505                     (build-polygon (list x2 y2 (first pa) (second pa) (first pb) (second pb) (first pc) (second pc))))
1506                  (b3
1507                     (setf pa (bipart x3 y3 x4 y4)
1508                           pb (bipart x3 y3 x1 y1)
1509                           pc (bipart x3 y3 x2 y2))
1510                     (build-polygon (list x3 y3 (first pa) (second pa) (first pb) (second pb) (first pc) (second pc))))
1511                  (b4
1512                     (setf pa (bipart x4 y4 x1 y1)
1513                           pb (bipart x4 y4 x2 y2)
1514                           pc (bipart x4 y4 x3 y3))
1515                     (build-polygon (list x4 y4 (first pa) (second pa) (first pb) (second pb) (first pc) (second pc)))) )))))
1516
1517    ; list of commands
1518    (setf pltcmd
1519          (cons (format nil " ~a w filledcurves lc ~a axis ~a"
1520                        (make-obj-title (get-option '$key))
1521                        (hex-to-rgb (get-option '$fill_color))
1522                        (axes-to-plot))
1523                (make-list (- (length pts) 1)
1524                           :initial-element (format nil " t '' w filledcurves lc ~a axis ~a"
1525                                              (hex-to-rgb (get-option '$fill_color))
1526                                              (axes-to-plot) ))))
1527    (update-ranges-2d xmin xmax ymin ymax)
1528    (setf grouping
1529          (make-list (length pts)
1530                     :initial-element '(2 0)))
1531    (make-gr-object
1532       :name    'region
1533       :command pltcmd
1534       :groups  grouping
1535       :points  pts)    ))
1536
1537
1538
1539
1540
1541
1542
1543
1544;; Object: 'implicit'
1545;; Usage:
1546;;     implicit(fcn,x-var,x-minval,x-maxval,y-var,y-minval,y-maxval)
1547;; Options:
1548;;     ip_grid
1549;;     ip_grid_in
1550;;     line_width
1551;;     line_type
1552;;     key
1553;;     color
1554;;     xaxis_secondary
1555;;     yaxis_secondary
1556;; Note: taken from implicit_plot.lisp
1557
1558;; returns elements at odd positions
1559(defun x-elements (list)
1560  (if (endp list) list
1561      (list* (first list) (x-elements (rest (rest list))))))
1562
1563;; returns elements at even positions
1564(defun y-elements (list)
1565  (x-elements (rest list)))
1566
1567(defvar pts ())
1568
1569(defun contains-zeros (i j sample)
1570  (not (and (> (* (aref sample i j) (aref sample (1+ i)     j  )) 0)
1571	    (> (* (aref sample i j) (aref sample     i  (1+ j) )) 0)
1572	    (> (* (aref sample i j) (aref sample (1+ i) (1+ j) )) 0) )))
1573
1574(defun sample-data (expr xmin xmax ymin ymax sample grid)
1575  (let* ((xdelta (/ (- xmax xmin) ($first grid)))
1576	 (ydelta (/ (- ymax ymin) ($second grid)))
1577	 (epsilon #+gcl (float 1/1000000) #-gcl 1e-6))
1578    (do ((x-val xmin (+ x-val xdelta))
1579	 (i 0 (1+ i)))
1580	((> i ($first grid)))
1581      (do ((y-val ymin (+ y-val ydelta))
1582	   (j 0 (1+ j)))
1583	  ((> j ($second grid)))
1584	(let ((fun-val (funcall expr x-val y-val)))
1585          (when (and (not (floatp fun-val)) (not (eq fun-val t)))
1586                (merror "draw2d (implicit): non defined variable in condition ~M=0" fun-val))
1587	  (if (or (eq fun-val t) (>= fun-val epsilon))
1588	      (setf (aref sample i j) 1)
1589	      (setf (aref sample i j) -1)))))))
1590
1591(defun draw-print-segment (points xmin xdelta ymin ydelta)
1592  (let* ((point1 (car points)) (point2 (cadr points))
1593	 (x1 (coerce (+ xmin (/ (* xdelta (+ (car point1) (caddr point1))) 2)) 'flonum) )
1594	 (y1 (coerce (+ ymin (/ (* ydelta (+ (cadr point1) (cadddr point1))) 2)) 'flonum) )
1595	 (x2 (coerce (+ xmin (/ (* xdelta (+ (car point2) (caddr point2))) 2)) 'flonum) )
1596	 (y2 (coerce (+ ymin (/ (* ydelta (+ (cadr point2) (cadddr point2))) 2)) 'flonum) ))
1597     (setq pts (nconc (list x1 y1 x2 y2) pts))))
1598
1599(defun draw-print-square (xmin xmax ymin ymax sample grid)
1600  (let* ((xdelta (/ (- xmax xmin) ($first grid)))
1601	 (ydelta (/ (- ymax ymin) ($second grid))))
1602    (do ((i 0 (1+ i)))
1603	((= i ($first grid)))
1604      (do ((j 0 (1+ j)))
1605	  ((= j ($second grid)))
1606	(if (contains-zeros i j sample)
1607	    (let ((points ()))
1608	      (if (< (* (aref sample i j) (aref sample (1+ i) j)) 0)
1609		  (setq points (cons `(,i ,j ,(1+ i) ,j) points)))
1610	      (if (< (* (aref sample (1+ i) j) (aref sample (1+ i) (1+ j))) 0)
1611		  (setq points (cons `(,(1+ i) ,j ,(1+ i) ,(1+ j)) points)))
1612	      (if (< (* (aref sample i (1+ j)) (aref sample (1+ i) (1+ j))) 0)
1613		  (setq points (cons `(,i ,(1+ j) ,(1+ i) ,(1+ j)) points)))
1614	      (if (< (* (aref sample i j) (aref sample i (1+ j))) 0)
1615		  (setq points (cons `(,i ,j ,i ,(1+ j)) points)))
1616	      (draw-print-segment points xmin xdelta ymin ydelta)) )))))
1617
1618(defun imp-pl-prepare-factor (expr)
1619  (cond
1620    ((or ($numberp expr) (atom expr))
1621     expr)
1622    ((eq (caar expr) 'mexpt)
1623     (cadr expr))
1624    (t
1625     expr)))
1626
1627(defun imp-pl-prepare-expr (expr)
1628  (let ((expr1 ($factor (m- ($rhs expr) ($lhs expr)))))
1629    (cond ((or ($numberp expr) (atom expr1)) expr1)
1630	  ((eq (caar expr1) 'mtimes)
1631	   `((mtimes simp factored 1)
1632	     ,@(mapcar #'imp-pl-prepare-factor (cdr expr1))))
1633	  ((eq (caar expr) 'mexpt)
1634	   (imp-pl-prepare-factor expr1))
1635	  (t
1636	   expr1))))
1637
1638(defun implicit (expr x xmin xmax y ymin ymax)
1639  (let* (($numer t) ($plot_options $plot_options)
1640         (pts ())
1641         (expr (m- ($rhs expr) ($lhs expr)))
1642         (ip-grid (get-option '$ip_grid))
1643         (ip-grid-in (get-option '$ip_grid_in))
1644         e pltcmd
1645         (xmin ($float xmin))
1646         (xmax ($float xmax))
1647         (ymin ($float ymin))
1648         (ymax ($float ymax))
1649         (xdelta (/ (- xmax xmin) ($first ip-grid)))
1650         (ydelta (/ (- ymax ymin) ($second ip-grid)))
1651         (sample (make-array `(,(1+ ($first ip-grid))
1652			       ,(1+ ($second ip-grid)))))
1653	 (ssample (make-array `(,(1+ ($first ip-grid-in))
1654				,(1+ ($second ip-grid-in))))) )
1655
1656    (setq e (coerce-float-fun (imp-pl-prepare-expr expr)
1657			      `((mlist simp)
1658				,x ,y)))
1659    (update-ranges-2d xmin xmax ymin ymax)
1660    (sample-data e xmin xmax ymin ymax sample ip-grid)
1661    (do ((i 0 (1+ i)))
1662	((= i ($first ip-grid)))
1663      (do ((j 0 (1+ j)))
1664	  ((= j ($second ip-grid)))
1665	(if (contains-zeros i j sample)
1666	    (let* ((xxmin (+ xmin (* i xdelta)))
1667		   (xxmax (+ xxmin xdelta))
1668		   (yymin (+ ymin (* j ydelta)))
1669		   (yymax (+ yymin ydelta)))
1670	      (sample-data e xxmin xxmax yymin yymax
1671			   ssample ip-grid-in)
1672	      (draw-print-square xxmin xxmax yymin yymax
1673			    ssample ip-grid-in) )) ))
1674
1675    ; geometric transformation
1676    (when (> *draw-transform-dimensions* 0)
1677      (let ((x (x-elements pts))
1678            (y (y-elements pts))
1679            xmin xmax ymin ymax)
1680        (transform-lists 2)
1681        (setf xmin ($tree_reduce 'min (cons '(mlist simp) x))
1682              xmax ($tree_reduce 'max (cons '(mlist simp) x))
1683              ymin ($tree_reduce 'min (cons '(mlist simp) y))
1684              ymax ($tree_reduce 'max (cons '(mlist simp) y)) )
1685        (update-ranges-2d xmin xmax ymin ymax)
1686        (setf pts
1687          (loop
1688            collect (car x)
1689            collect (car y)
1690            do (setf x (cdr x))
1691               (setf y (cdr y))
1692            when (null x) do (loop-finish) ))) )
1693
1694    (setf pltcmd (format nil " ~a w l lw ~a lt ~a lc ~a axis ~a"
1695                              (make-obj-title (get-option '$key))
1696                              (get-option '$line_width)
1697                              (get-option '$line_type)
1698                              (hex-to-rgb (get-option '$color))
1699                              (axes-to-plot)))
1700    (make-gr-object
1701       :name   'implicit
1702       :command pltcmd
1703       :groups '((2 2))
1704       :points  `(,(make-array (length pts) :element-type 'flonum
1705                                            :initial-contents pts)) ) ))
1706
1707
1708
1709
1710
1711
1712;; Object: 'implicit3d'
1713;; Usage:
1714;;     implicit(expr,x,xmin,xmax,y,ymin,ymax,z,zmin,zmax)
1715;; Options:
1716;;     key
1717;;     x_voxel
1718;;     y_voxel
1719;;     z_voxel
1720;;     line_width
1721;;     line_type
1722;;     color
1723;;     enhanced3d
1724;;     wired_surface
1725;; Some functions and macros are defined in grcommon.lisp
1726(defun implicit3d (expr par1 xmin xmax par2 ymin ymax par3 zmin zmax)
1727  (let ((xmin ($float xmin))
1728        (xmax ($float xmax))
1729        (ymin ($float ymin))
1730        (ymax ($float ymax))
1731        (zmin ($float zmin))
1732        (zmax ($float zmax))
1733        (pts '())
1734        (grouping '())
1735        pltcmd ncols vertices)
1736    (when (not (subsetp (rest ($listofvars expr)) (list par1 par2 par3)))
1737       (merror "draw3d (implicit): non defined variable"))
1738    (check-enhanced3d-model "implicit" '(0 3 99))
1739    (when (= *draw-enhanced3d-type* 99)
1740       (update-enhanced3d-expression (list '(mlist) par1 par2 par3)))
1741    (setf ncols (if (= *draw-enhanced3d-type* 0) 3 4))
1742
1743    (setf vertices (find-triangles expr par1 xmin xmax par2 ymin ymax par3 zmin zmax))
1744    (when (null vertices)
1745      (merror "draw3d (implicit): no surface within these ranges"))
1746    (update-ranges-3d xmin xmax ymin ymax zmin zmax)
1747    (setf pltcmd
1748          (cons (format nil " ~a w ~a lw ~a lt ~a lc ~a"
1749                        (make-obj-title (get-option '$key))
1750                        (if (equal (get-option '$enhanced3d) '$none) "l" "pm3d")
1751                        (get-option '$line_width)
1752                        (get-option '$line_type)
1753                        (hex-to-rgb (get-option '$color)))
1754                (make-list (- (/ (length vertices) 3) 1)
1755                           :initial-element (format nil " t '' w ~a lw ~a lt ~a lc ~a"
1756                                              (if (equal (get-option '$enhanced3d) '$none) "l" "pm3d")
1757                                              (get-option '$line_width)
1758                                              (get-option '$line_type)
1759                                              (hex-to-rgb (get-option '$color)) ))))
1760    (do ((v vertices (cdddr v)))
1761        ((null v) 'done)
1762      (case ncols
1763        (3 (push (make-array 12 :element-type 'flonum
1764                                :initial-contents (flatten (list (first v) (second v) (first v) (third v))))
1765                 pts))
1766        (4 (let (v1 v2 v3
1767                 color1 color2 color3)
1768             (setf v1 (first v)
1769                   v2 (second v)
1770                   v3 (third v))
1771             (setf color1 (funcall *draw-enhanced3d-fun* (car v1) (cadr v1) (caddr v1))
1772                   color2 (funcall *draw-enhanced3d-fun* (car v2) (cadr v2) (caddr v2))
1773                   color3 (funcall *draw-enhanced3d-fun* (car v3) (cadr v3) (caddr v3)) )
1774             (push (make-array 16 :element-type 'flonum
1775                                  :initial-contents (flatten (list v1 color1 v2 color2 v1 color1 v3 color3)))
1776                    pts))) )
1777      (push `(,ncols 2)
1778            grouping) )
1779    (make-gr-object
1780       :name    'implicit
1781       :command pltcmd
1782       :groups  grouping
1783       :points  pts)))
1784
1785
1786
1787
1788
1789
1790
1791;; Object: 'explicit3d'
1792;; Usage:
1793;;     explicit(fcn,par1,minval1,maxval1,par2,minval2,maxval2)
1794;; Options:
1795;;     xu_grid
1796;;     yv_grid
1797;;     line_type
1798;;     line_width
1799;;     color
1800;;     key
1801;;     enhanced3d
1802;;     wired_surface
1803;;     surface_hide
1804;;     transform
1805(defun explicit3d (fcn par1 minval1 maxval1 par2 minval2 maxval2)
1806  (let* ((xu_grid (get-option '$xu_grid))
1807         (yv_grid (get-option '$yv_grid))
1808         (fminval1 ($float minval1))
1809         (fminval2 ($float minval2))
1810         (fmaxval1 ($float maxval1))
1811         (fmaxval2 ($float maxval2))
1812         (epsx (/ (- fmaxval1 fminval1) xu_grid))
1813         (epsy (/ (- fmaxval2 fminval2) yv_grid))
1814         (xx 0.0) (uu 0.0)
1815         (yy 0.0) (vv 0.0)
1816         (zz 0.0)
1817         (xmin most-positive-double-float)
1818         (xmax most-negative-double-float)
1819         (ymin most-positive-double-float)
1820         (ymax most-negative-double-float)
1821         (zmin most-positive-double-float)
1822         (zmax most-negative-double-float)
1823         (*plot-realpart* *plot-realpart*)
1824         (nx (+ xu_grid 1))
1825         (ny (+ yv_grid 1))
1826         ($numer t)
1827         (count -1)
1828         ncols result)
1829    (when (not (subsetp (rest ($listofvars fcn)) (list par1 par2)))
1830            (let ((items (rest ($listofvars fcn))) (item 'nil))
1831	      ;; Search for the item in sublist that is the undefined variable
1832	      (while items
1833		(if
1834		    (
1835		     not
1836		     (subsetp (list (car items)) (list par1 par2))
1837		     )
1838		    (setq item (car items))
1839		  )
1840		(setq items (cdr items))
1841		)
1842	      (merror "draw3d (explicit): non defined variable in term ~M" item)
1843	      )
1844	    )
1845    (setq *plot-realpart* (get-option '$draw_realpart))
1846    (check-enhanced3d-model "explicit" '(0 2 3 99))
1847    (when (= *draw-enhanced3d-type* 99)
1848       (update-enhanced3d-expression (list '(mlist) par1 par2)))
1849    (setq fcn (coerce-float-fun fcn `((mlist) ,par1 ,par2)))
1850    (setf ncols (if (= *draw-enhanced3d-type* 0) 3 4))
1851    (setf result (make-array (* ncols nx ny)))
1852    (loop for j below ny
1853           initially (setf vv fminval2)
1854           do (setf uu fminval1)
1855           (loop for i below nx
1856                  do
1857                  (setf xx uu
1858                        yy vv)
1859                  (setf zz (funcall fcn xx yy))
1860                  (transform-point 3)
1861                  (when (> *draw-transform-dimensions* 0)
1862                    (check-extremes-x)
1863                    (check-extremes-y))
1864                  (check-extremes-z)
1865                  (setf (aref result (incf count)) xx
1866                        (aref result (incf count)) yy
1867                        (aref result (incf count)) zz)
1868                  ; check texture model
1869                  (case *draw-enhanced3d-type*
1870                    ((2 99) (setf (aref result (incf count)) (funcall *draw-enhanced3d-fun* xx yy)))
1871                    (3  (setf (aref result (incf count)) (funcall *draw-enhanced3d-fun* xx yy zz))) )
1872                  (setq uu (+ uu epsx)))
1873           (setq vv (+ vv epsy)))
1874    (when (> *draw-transform-dimensions* 0)
1875      (setf fminval1 xmin
1876            fmaxval1 xmax
1877            fminval2 ymin
1878            fmaxval2 ymax))
1879    (update-ranges-3d fminval1 fmaxval1 fminval2 fmaxval2 zmin zmax)
1880    (make-gr-object
1881       :name   'explicit
1882       :command (format nil " ~a w ~a lw ~a lt ~a lc ~a"
1883                            (make-obj-title (get-option '$key))
1884                            (if (> *draw-enhanced3d-type* 0) "pm3d" "l")
1885                            (get-option '$line_width)
1886                            (get-option '$line_type)
1887                            (hex-to-rgb (get-option '$color)))
1888       :groups `((,ncols ,nx))
1889       :points  (list result))))
1890
1891
1892
1893
1894
1895
1896
1897
1898;; Object: 'elevation_grid'
1899;; Usage:
1900;;     elevation_grid(mat,x0,y0,width,height)
1901;; Options:
1902;;     line_type
1903;;     line_width
1904;;     color
1905;;     key
1906;;     enhanced3d
1907;;     wired_surface
1908;;     transform
1909(defun elevation_grid (mat x0 y0 width height)
1910  (let ( (fx0 ($float x0))
1911         (fy0 ($float y0))
1912         (fwidth ($float width))
1913         (fheight ($float height))
1914         (xmin most-positive-double-float)
1915         (xmax most-negative-double-float)
1916         (ymin most-positive-double-float)
1917         (ymax most-negative-double-float)
1918         (zmin most-positive-double-float)
1919         (zmax most-negative-double-float)
1920         ncols-file result nrows ncols)
1921    (check-enhanced3d-model "elevation_grid" '(0 2 3))
1922    (cond (($matrixp mat)
1923             (let ((xi 0.0)
1924                   (yi (+ fy0 fheight))
1925                   (xx 0.0)
1926                   (yy 0.0)
1927                   (zz 0.0)
1928                   (count -1)
1929                   dx dy)
1930                (setf ncols (length (cdadr mat))
1931                      nrows (length (cdr mat)))
1932                (setf dx (/ fwidth (1- ncols))
1933                      dy (/ fheight (1- nrows)))
1934                (setf ncols-file (if (= *draw-enhanced3d-type* 0) 3 4))
1935                (setf result (make-array (* ncols nrows ncols-file) :element-type 'flonum))
1936                (loop for row on (cdr mat) by #'cdr do
1937                   (setf xi fx0)
1938                   (loop for col on (cdar row) by #'cdr do
1939                      (setf xx xi
1940                            yy yi)
1941                      (setf zz ($float (car col)))
1942                      (transform-point 3)
1943                      (when (> *draw-transform-dimensions* 0)
1944                        (check-extremes-x)
1945                        (check-extremes-y))
1946                      (check-extremes-z)
1947                      (setf (aref result (incf count)) xx
1948                            (aref result (incf count)) yy
1949                            (aref result (incf count)) zz)
1950                      ; check texture model
1951                      (case *draw-enhanced3d-type*
1952                        (2 (setf (aref result (incf count)) (funcall *draw-enhanced3d-fun* xx yy)))
1953                        (3 (setf (aref result (incf count)) (funcall *draw-enhanced3d-fun* xx yy zz))) )
1954                      (setf xi (+ xi dx)))
1955                   (setf yi (- yi dy)))))
1956          (t
1957             (merror "draw3d (elevation_grid): Argument not recognized")))
1958    (when (= *draw-transform-dimensions* 0)
1959       (setf xmin fx0
1960             xmax (+ fx0 fwidth)
1961             ymin fy0
1962             ymax (+ fy0 fheight)))
1963    (update-ranges-3d xmin xmax ymin ymax zmin zmax)
1964    (make-gr-object
1965       :name   'elevation_grid
1966       :command (format nil " ~a w ~a lw ~a lt ~a lc ~a"
1967                            (make-obj-title (get-option '$key))
1968                            (if (> *draw-enhanced3d-type* 0) "pm3d" "l")
1969                            (get-option '$line_width)
1970                            (get-option '$line_type)
1971                            (hex-to-rgb (get-option '$color)))
1972       :groups `((,ncols-file ,ncols))
1973       :points  (list result)) ))
1974
1975
1976
1977
1978
1979
1980
1981
1982;; Object: 'mesh'
1983;; Usage:
1984;;     mesh([[x_11,y_11,z_11], ...,[x_1n,y_1n,z_1n]],
1985;;          [[x_21,y_21,z_21], ...,[x_2n,y_2n,z_2n]],
1986;;          ...,
1987;;          [[x_m1,y_m1,z_m1], ...,[x_mn,y_mn,z_mn]])
1988;; Options:
1989;;     line_type
1990;;     line_width
1991;;     color
1992;;     key
1993;;     enhanced3d
1994;;     wired_surface
1995;;     transform
1996(defun mesh (&rest row)
1997  (let (result xx yy zz
1998        (xmin most-positive-double-float)
1999        (xmax most-negative-double-float)
2000        (ymin most-positive-double-float)
2001        (ymax most-negative-double-float)
2002        (zmin most-positive-double-float)
2003        (zmax most-negative-double-float)
2004        m n ncols-file col-num row-num
2005        (count -1))
2006    (cond
2007      ; let's see if the user wants to use mesh in the old way,
2008      ; what we now call elevation_grid
2009      ((and (= (length row) 5)
2010            ($matrixp (first row)))
2011        (print "Warning: Seems like you want to draw an elevation_grid object...")
2012        (print "         Please, see documentation for object elevation_grid.")
2013        (apply #'elevation_grid row))
2014      (t
2015        (check-enhanced3d-model "mesh" '(0 2 3))
2016        (when (or (< (length row) 2)
2017                  (not (every #'$listp row)))
2018          (merror "draw3d (mesh): Arguments must be two or more lists"))
2019        (setf ncols-file (if (= *draw-enhanced3d-type* 0) 3 4))
2020        (setf m (length row)
2021              n ($length (first row)))
2022        (setf result (make-array (* m n ncols-file) :element-type 'flonum))
2023        (setf row-num 0)
2024        (dolist (r row)
2025          (incf row-num)
2026          (setf col-num 0)
2027          (dolist (c (rest r))
2028            (incf col-num)
2029            (setf xx ($float ($first c))
2030                  yy ($float ($second c))
2031                  zz ($float ($third c)))
2032            (transform-point 3)
2033            (check-extremes-x)
2034            (check-extremes-y)
2035            (check-extremes-z)
2036            (setf (aref result (incf count)) xx
2037                  (aref result (incf count)) yy
2038                  (aref result (incf count)) zz)
2039            ; check texture model
2040            (case *draw-enhanced3d-type*
2041              (2 (setf (aref result (incf count)) (funcall *draw-enhanced3d-fun* row-num col-num)))
2042              (3 (setf (aref result (incf count)) (funcall *draw-enhanced3d-fun* xx yy zz))))  )   )
2043        (update-ranges-3d xmin xmax ymin ymax zmin zmax)
2044        (make-gr-object
2045          :name   'mesh
2046          :command (format nil " ~a w ~a lw ~a lt ~a lc ~a"
2047                           (make-obj-title (get-option '$key))
2048                           (if (> *draw-enhanced3d-type* 0) "pm3d" "l")
2049                           (get-option '$line_width)
2050                           (get-option '$line_type)
2051                           (hex-to-rgb (get-option '$color)))
2052          :groups `((,ncols-file ,n))
2053          :points  (list result))))))
2054
2055
2056
2057
2058
2059
2060
2061;; Object: 'triangle3d'
2062;; Usage:
2063;;     triangle([x1,y1,z1], [x2,y2,z2], [x3,y3,z3])
2064;; Options:
2065;;     line_type
2066;;     line_width
2067;;     color
2068;;     key
2069;;     enhanced3d
2070;;     transform
2071(defun triangle3d (arg1 arg2 arg3)
2072   (if (or (not ($listp arg1))
2073           (not (= ($length arg1) 3))
2074           (not ($listp arg2))
2075           (not (= ($length arg2) 3))
2076           (not ($listp arg3))
2077           (not (= ($length arg3) 3)))
2078       (merror "draw3d (triangle): vertices are not correct"))
2079   (let* ((x1 ($float (cadr arg1)))
2080          (y1 ($float (caddr arg1)))
2081          (z1 ($float (cadddr arg1)))
2082          (x2 ($float (cadr arg2)))
2083          (y2 ($float (caddr arg2)))
2084          (z2 ($float (cadddr arg2)))
2085          (x3 ($float (cadr arg3)))
2086          (y3 ($float (caddr arg3)))
2087          (z3 ($float (cadddr arg3)))
2088          (grobj (mesh `((mlist simp)
2089                            ((mlist simp) ,x1 ,y1 ,z1)
2090                            ((mlist simp) ,x1 ,y1 ,z1) )
2091
2092                       `((mlist simp)
2093                            ((mlist simp) ,x2 ,y2 ,z2)
2094                            ((mlist simp) ,x3 ,y3 ,z3) ) )))
2095      (setf (gr-object-name grobj) 'triangle)
2096      grobj))
2097
2098
2099
2100
2101
2102
2103
2104;; Object: 'quadrilateral3d'
2105;; Usage:
2106;;     quadrilateral([x1,y1,z1], [x2,y2,z2], [x3,y3,z3], [x4,y4,z4])
2107;; Options:
2108;;     line_type
2109;;     line_width
2110;;     color
2111;;     key
2112;;     enhanced3d
2113;;     transform
2114(defun quadrilateral3d (arg1 arg2 arg3 arg4)
2115   (if (or (not ($listp arg1))
2116           (not (= ($length arg1) 3))
2117           (not ($listp arg2))
2118           (not (= ($length arg2) 3))
2119           (not ($listp arg3))
2120           (not (= ($length arg3) 3))
2121           (not ($listp arg4))
2122           (not (= ($length arg4) 3)))
2123       (merror "draw3d (quadrilateral): vertices are not correct"))
2124   (let* ((x1 ($float (cadr arg1)))
2125          (y1 ($float (caddr arg1)))
2126          (z1 ($float (cadddr arg1)))
2127          (x2 ($float (cadr arg2)))
2128          (y2 ($float (caddr arg2)))
2129          (z2 ($float (cadddr arg2)))
2130          (x3 ($float (cadr arg3)))
2131          (y3 ($float (caddr arg3)))
2132          (z3 ($float (cadddr arg3)))
2133          (x4 ($float (cadr arg4)))
2134          (y4 ($float (caddr arg4)))
2135          (z4 ($float (cadddr arg4)))
2136          (grobj (mesh `((mlist simp)
2137                         ((mlist simp) ,x1 ,y1 ,z1)
2138                         ((mlist simp) ,x2 ,y2 ,z2))
2139                       `((mlist simp)
2140                         ((mlist simp) ,x3 ,y3 ,z3)
2141                         ((mlist simp) ,x4 ,y4 ,z4)))))
2142      (setf (gr-object-name grobj) 'quadrilateral)
2143      grobj))
2144
2145
2146
2147
2148
2149
2150
2151;; Object: 'parametric'
2152;; Usage:
2153;;     parametric(xfun,yfun,par,parmin,parmax)
2154;; Options:
2155;;     nticks
2156;;     line_width
2157;;     line_type
2158;;     key
2159;;     color
2160;;     xaxis_secondary
2161;;     yaxis_secondary
2162;;     transform
2163;; Note: similar to draw2d-parametric in plot.lisp
2164(defun parametric (xfun yfun par parmin parmax)
2165  (let* ((nticks (get-option '$nticks))
2166         ($numer t)
2167         (tmin ($float parmin))
2168         (tmax ($float parmax))
2169         (xmin most-positive-double-float)
2170         (xmax most-negative-double-float)
2171         (ymin most-positive-double-float)
2172         (ymax most-negative-double-float)
2173         (*plot-realpart* *plot-realpart*)
2174         (tt ($float parmin))
2175         (eps (/ (- tmax tmin) (- nticks 1)))
2176         result f1 f2 xx yy)
2177    (when (< tmax tmin)
2178       (merror "draw2d (parametric): illegal range"))
2179    (when (not (subsetp (append (rest ($listofvars xfun)) (rest ($listofvars yfun))) (list par)))
2180       (merror "draw2d (parametric): non defined variable"))
2181    (setq *plot-realpart* (get-option '$draw_realpart))
2182    (setq f1 (coerce-float-fun xfun `((mlist), par)))
2183    (setq f2 (coerce-float-fun yfun `((mlist), par)))
2184    (setf result
2185       (loop
2186          do (setf xx ($float (funcall f1 tt)))
2187             (setf yy ($float (funcall f2 tt)))
2188             (transform-point 2)
2189             (check-extremes-x)
2190             (check-extremes-y)
2191          collect xx
2192          collect yy
2193          when (>= tt tmax) do (loop-finish)
2194          do (setq tt (+ tt eps))
2195             (if (>= tt tmax) (setq tt tmax)) ))
2196    ; update x-y ranges if necessary
2197    (update-ranges-2d xmin xmax ymin ymax)
2198    (make-gr-object
2199       :name 'parametric
2200       :command (format nil " ~a w l lw ~a lt ~a lc ~a axis ~a"
2201                            (make-obj-title (get-option '$key))
2202                            (get-option '$line_width)
2203                            (get-option '$line_type)
2204                            (hex-to-rgb (get-option '$color))
2205                            (axes-to-plot))
2206       :groups '((2 0))
2207       :points `(,(make-array (length result) :initial-contents result)))   ) )
2208
2209
2210
2211
2212
2213
2214
2215;; Object: 'polar'
2216;; Usage:
2217;;     polar(radius,ang,minang,maxang)
2218;; Options:
2219;;     nticks
2220;;     line_width
2221;;     line_type
2222;;     key
2223;;     color
2224;;     xaxis_secondary
2225;;     yaxis_secondary
2226;; This object is constructed as a parametric function
2227(defun polar (radius ang minang maxang)
2228  (let ((grobj (parametric `((mtimes simp) ,radius ((%cos simp) ,ang))
2229                            `((mtimes simp) ,radius ((%sin simp) ,ang))
2230                            ang minang maxang)))
2231    (setf (gr-object-name grobj) 'polar)
2232    grobj ))
2233
2234
2235
2236
2237
2238
2239
2240;; Object: 'spherical'
2241;; Usage:
2242;;     spherical(radius,az,minazi,maxazi,zen,minzen,maxzen)
2243;; Options:
2244;;     xu_grid
2245;;     yv_grid
2246;;     line_type
2247;;     color
2248;;     key
2249;;     enhanced3d
2250;;     wired_surface
2251;; This object is constructed as a parametric surface in 3d.
2252;; Functions are defined in format r=r(azimuth,zenith),
2253;; where, normally, azimuth is an angle in [0,2*%pi] and zenith in [0,%pi]
2254(defun spherical (radius azi minazi maxazi zen minzen maxzen)
2255  (let ((grobj (parametric_surface
2256                     `((mtimes simp) ,radius ((%sin simp) ,zen) ((%cos simp) ,azi))
2257                     `((mtimes simp) ,radius ((%sin simp) ,zen) ((%sin simp) ,azi))
2258                     `((mtimes simp) ,radius ((%cos simp) ,zen))
2259                     azi minazi maxazi
2260                     zen minzen maxzen)))
2261    (setf (gr-object-name grobj) 'spherical)
2262    grobj ))
2263
2264
2265
2266
2267
2268
2269
2270
2271;; Object: 'cylindrical'
2272;; Usage:
2273;;     cylindrical(r,z,minz,maxz,azi,minazi,maxazi)
2274;; Options:
2275;;     xu_grid
2276;;     yv_grid
2277;;     line_type
2278;;     color
2279;;     key
2280;;     enhanced3d
2281;;     wired_surface
2282;; This object is constructed as a parametric surface in 3d.
2283;; Functions are defined in format z=z(radius,azimuth), where,
2284;; normally, azimuth is an angle in [0,2*%pi] and r any real
2285(defun cylindrical (r z minz maxz azi minazi maxazi)
2286  (let ((grobj (parametric_surface
2287                     `((mtimes simp) ,r ((%cos simp) ,azi))
2288                     `((mtimes simp) ,r ((%sin simp) ,azi))
2289                     z
2290                     z minz maxz
2291                     azi minazi maxazi)))
2292    (setf (gr-object-name grobj) 'cylindrical)
2293    grobj ))
2294
2295
2296
2297
2298
2299
2300
2301
2302;; Object: 'parametric3d'
2303;; Usage:
2304;;     parametric(xfun,yfun,zfun,par1,parmin,parmax)
2305;; Options:
2306;;     nticks
2307;;     line_width
2308;;     line_type
2309;;     color
2310;;     key
2311;;     enhanced3d
2312;;     surface_hide
2313;;     transform
2314(defun parametric3d (xfun yfun zfun par1 parmin parmax)
2315  (let* ((nticks (get-option '$nticks))
2316         ($numer t)
2317         (tmin ($float parmin))
2318         (tmax ($float parmax))
2319         (xmin most-positive-double-float)
2320         (xmax most-negative-double-float)
2321         (ymin most-positive-double-float)
2322         (ymax most-negative-double-float)
2323         (zmin most-positive-double-float)
2324         (zmax most-negative-double-float)
2325         (*plot-realpart* *plot-realpart*)
2326         (tt tmin)
2327         (eps (/ (- tmax tmin) (- nticks 1)))
2328         (count -1)
2329         ncols result f1 f2 f3 xx yy zz)
2330     (when (not (subsetp (rest ($append ($listofvars xfun) ($listofvars yfun) ($listofvars zfun))) (list par1)))
2331        (merror "draw3d (parametric): non defined variable"))
2332    (setq *plot-realpart* (get-option '$draw_realpart))
2333    (check-enhanced3d-model "parametric" '(0 1 3 99))
2334    (when (= *draw-enhanced3d-type* 99)
2335       (update-enhanced3d-expression (list '(mlist) par1)))
2336    (if (< tmax tmin)
2337       (merror "draw3d (parametric): illegal range"))
2338    (setq f1 (coerce-float-fun xfun `((mlist) ,par1)))
2339    (setq f2 (coerce-float-fun yfun `((mlist) ,par1)))
2340    (setq f3 (coerce-float-fun zfun `((mlist) ,par1)))
2341    (setf ncols (if (= *draw-enhanced3d-type* 0) 3 4))
2342    (setf result (make-array (* ncols nticks)))
2343    (dotimes (k nticks)
2344      (setf xx (funcall f1 tt))
2345      (setf yy (funcall f2 tt))
2346      (setf zz (funcall f3 tt))
2347      (transform-point 3)
2348      (check-extremes-x)
2349      (check-extremes-y)
2350      (check-extremes-z)
2351      (setf (aref result (incf count)) xx)
2352      (setf (aref result (incf count)) yy)
2353      (setf (aref result (incf count)) zz)
2354      ; check texture model
2355      (case *draw-enhanced3d-type*
2356        ((1 99) (setf (aref result (incf count)) (funcall *draw-enhanced3d-fun* tt)))
2357        (3      (setf (aref result (incf count)) (funcall *draw-enhanced3d-fun* xx yy zz))))
2358      (setf tt (+ tt eps)) )
2359    ; update x-y ranges if necessary
2360    (update-ranges-3d xmin xmax ymin ymax zmin zmax)
2361    (make-gr-object
2362       :name 'parametric
2363       :command (format nil " ~a w l lw ~a lt ~a lc ~a"
2364                            (make-obj-title (get-option '$key))
2365                            (get-option '$line_width)
2366                            (get-option '$line_type)
2367                            (if (> *draw-enhanced3d-type* 0)
2368                                "palette"
2369                                (hex-to-rgb (get-option '$color))) )
2370       :groups `((,ncols 0))
2371       :points (list result) )) )
2372
2373
2374
2375
2376
2377
2378
2379
2380;; Object: 'parametric_surface'
2381;; Usage:
2382;;     parametric_surface(xfun,yfun,zfun,par1,par1min,par1max,par2,par2min,par2max)
2383;; Options:
2384;;     xu_grid
2385;;     yv_grid
2386;;     line_type
2387;;     line_width
2388;;     color
2389;;     key
2390;;     enhanced3d
2391;;     wired_surface
2392;;     surface_hide
2393;;     transform
2394(defun parametric_surface (xfun yfun zfun par1 par1min par1max par2 par2min par2max)
2395  (let* ((ugrid (get-option '$xu_grid))
2396         (vgrid (get-option '$yv_grid))
2397         ($numer t)
2398         (umin ($float par1min))
2399         (umax ($float par1max))
2400         (vmin ($float par2min))
2401         (vmax ($float par2max))
2402         (xmin most-positive-double-float)
2403         (xmax most-negative-double-float)
2404         (ymin most-positive-double-float)
2405         (ymax most-negative-double-float)
2406         (zmin most-positive-double-float)
2407         (zmax most-negative-double-float)
2408         (*plot-realpart* *plot-realpart*)
2409         (ueps (/ (- umax umin) (- ugrid 1)))
2410         (veps (/ (- vmax vmin) (- vgrid 1)))
2411         (nu (+ ugrid 1))
2412         (nv (+ vgrid 1))
2413         (count -1)
2414         ncols result f1 f2 f3 xx yy zz uu vv)
2415     (when (not (subsetp (rest ($append ($listofvars xfun) ($listofvars yfun) ($listofvars zfun))) (list par1 par2)))
2416        (merror "draw3d (parametric_surface): non defined variable"))
2417    (setq *plot-realpart* (get-option '$draw_realpart))
2418    (check-enhanced3d-model "parametric_surface" '(0 2 3 99))
2419    (when (= *draw-enhanced3d-type* 99)
2420       (update-enhanced3d-expression (list '(mlist) par1 par2)))
2421    (if (or (< umax umin)
2422            (< vmax vmin))
2423       (merror "draw3d (parametric_surface): illegal range"))
2424    (setq f1 (coerce-float-fun xfun `((mlist) ,par1 ,par2)))
2425    (setq f2 (coerce-float-fun yfun `((mlist) ,par1 ,par2)))
2426    (setq f3 (coerce-float-fun zfun `((mlist) ,par1 ,par2)))
2427    (setf ncols (if (= *draw-enhanced3d-type* 0) 3 4))
2428    (setf result (make-array (* ncols nu nv)))
2429    (loop for j below nv
2430           initially (setq vv vmin)
2431           do (setq uu umin)
2432           (loop for i below nu
2433                  do
2434                  (setf xx (funcall f1 uu vv))
2435                  (setf yy (funcall f2 uu vv))
2436                  (setf zz (funcall f3 uu vv))
2437                  (transform-point 3)
2438                  (check-extremes-x)
2439                  (check-extremes-y)
2440                  (check-extremes-z)
2441                  (setf (aref result (incf count)) xx)
2442                  (setf (aref result (incf count)) yy)
2443                  (setf (aref result (incf count)) zz)
2444                  ; check texture model
2445                  (case *draw-enhanced3d-type*
2446                    ((2 99) (setf (aref result (incf count)) (funcall *draw-enhanced3d-fun* uu vv)))
2447                    (3      (setf (aref result (incf count)) (funcall *draw-enhanced3d-fun* xx yy zz))) )
2448                  (setq uu (+ uu ueps))
2449                  (if (> uu umax) (setf uu umax)))
2450           (setq vv (+ vv veps))
2451           (if (> vv vmax) (setf vv vmax)))
2452    ; update x-y-z ranges if necessary
2453    (update-ranges-3d xmin xmax ymin ymax zmin zmax)
2454    (make-gr-object
2455       :name 'parametric_surface
2456       :command (format nil " ~a w ~a lw ~a lt ~a lc ~a"
2457                            (make-obj-title (get-option '$key))
2458                            (if (> *draw-enhanced3d-type* 0) "pm3d" "l")
2459                            (get-option '$line_width)
2460                            (get-option '$line_type)
2461                            (hex-to-rgb (get-option '$color)))
2462       :groups `((,ncols ,nu)) ; ncols is 4 or 3, depending on colored 4th dimension or not
2463       :points (list result))))
2464
2465
2466
2467
2468
2469
2470
2471;; Object: 'tube'
2472;; Usage:
2473;;     tube(xfun,yfun,zfun,rad,par1,parmin,parmax)
2474;; Options:
2475;;     xu_grid
2476;;     yv_grid
2477;;     line_type
2478;;     line_width
2479;;     color
2480;;     key
2481;;     enhanced3d
2482;;     wired_surface
2483;;     surface_hide
2484;;     transform
2485(defmacro check-tube-extreme (ex cx cy cz circ)
2486    `(when (equal (nth ,ex (get-option '$capping)) t)
2487       (let ((cxx ,cx)
2488             (cyy ,cy)
2489             (czz ,cz))
2490          (when (> *draw-transform-dimensions* 0)
2491            (setf cxx (funcall *draw-transform-f1* ,cx ,cy ,cz)
2492                  cyy (funcall *draw-transform-f2* ,cx ,cy ,cz)
2493                  czz (funcall *draw-transform-f3* ,cx ,cy ,cz)))
2494          (case *draw-enhanced3d-type*
2495            (0      (setf ,circ (list cxx cyy czz)))
2496            ((1 99) (setf ,circ (list cxx cyy czz (funcall *draw-enhanced3d-fun* tt))))
2497            (3      (setf ,circ (list cxx cyy czz (funcall *draw-enhanced3d-fun* cxx cyy czz)))))
2498          (dotimes (k vgrid)
2499            (setf result (append result ,circ))))))
2500
2501(defun tube (xfun yfun zfun rad par1 parmin parmax)
2502  (let* ((ugrid (get-option '$xu_grid))
2503         (vgrid (get-option '$yv_grid))
2504         ($numer t)
2505         (tmin ($float parmin))
2506         (tmax ($float parmax))
2507         (vmax 6.283185307179586) ; = float(2*%pi)
2508         (xmin most-positive-double-float)
2509         (xmax most-negative-double-float)
2510         (ymin most-positive-double-float)
2511         (ymax most-negative-double-float)
2512         (zmin most-positive-double-float)
2513         (zmax most-negative-double-float)
2514         (teps (/ (- tmax tmin) (- ugrid 1)))
2515         (veps (/ vmax (- vgrid 1)))
2516         (tt tmin)
2517         ncols circ result
2518         f1 f2 f3 radius
2519         cx cy cz nx ny nz
2520         ux uy uz vx vy vz
2521         xx yy zz module r vv rcos rsin
2522         cxold cyold czold
2523         uxold uyold uzold ttnext)
2524    (when (< tmax tmin)
2525       (merror "draw3d (tube): illegal range"))
2526    (when (not (subsetp (rest ($append ($listofvars xfun) ($listofvars yfun)
2527                                       ($listofvars zfun) ($listofvars rad)))
2528                        (list par1)))
2529       (merror "draw3d (tube): non defined variable"))
2530    (check-enhanced3d-model "tube" '(0 1 3 99))
2531    (when (= *draw-enhanced3d-type* 99)
2532       (update-enhanced3d-expression (list '(mlist) par1)))
2533    (setq f1 (coerce-float-fun xfun `((mlist) ,par1)))
2534    (setq f2 (coerce-float-fun yfun `((mlist) ,par1)))
2535    (setq f3 (coerce-float-fun zfun `((mlist) ,par1)))
2536    (setf ncols (if (= *draw-enhanced3d-type* 0) 3 4))
2537    (setf radius
2538          (coerce-float-fun rad `((mlist) ,par1)))
2539    (loop do
2540      ; calculate center and radius of circle
2541      (cond
2542        ((= tt tmin)  ; 1st iteration
2543           (setf cx (funcall f1 tt)
2544                 cy (funcall f2 tt)
2545                 cz (funcall f3 tt)
2546                 ttnext (+ tt teps))
2547           (check-tube-extreme 1 cx cy cz circ)
2548           (setf nx (- (funcall f1 ttnext) cx)
2549                 ny (- (funcall f2 ttnext) cy)
2550                 nz (- (funcall f3 ttnext) cz)))
2551        (t  ; all next iterations along the parametric curve
2552           (setf cxold cx
2553                 cyold cy
2554                 czold cz)
2555           (setf cx (funcall f1 tt)
2556                 cy (funcall f2 tt)
2557                 cz (funcall f3 tt))
2558           (setf nx (- cx cxold)
2559                 ny (- cy cyold)
2560                 nz (- cz czold))))
2561      (setf r (funcall radius tt))
2562      ; calculate the unitary normal vector
2563      (setf module (sqrt (+ (* nx nx) (* ny ny) (* nz nz))))
2564      (setf nx (/ nx module)
2565            ny (/ ny module)
2566            nz (/ nz module))
2567      ; calculate unitary vector perpendicular to n=(nx,ny,nz)
2568      ; ux.nx+uy.ny+uz.nz=0 => ux=-t(ny+nz)/nx, uy=uz=t
2569      ; let's take t=1
2570      (cond
2571        ((= nx 0.0)
2572           (setf ux 1.0 uy 0.0 uz 0.0))
2573        ((= ny 0.0)
2574           (setf ux 0.0 uy 1.0 uz 0.0))
2575        ((= nz 0.0)
2576           (setf ux 0.0 uy 0.0 uz 1.0))
2577        (t  ; all other cases
2578           (setf ux (- (/ (+ ny nz) nx))
2579                 uy 1.0
2580                 uz 1.0)))
2581      (setf module (sqrt (+ (* ux ux) (* uy uy) (* uz uz))))
2582      (setf ux (/ ux module)
2583            uy (/ uy module)
2584            uz (/ uz module))
2585      (when (and (> tt tmin)
2586                 (< (+ (* uxold ux)
2587                       (* uyold uy)
2588                       (* uzold uz))
2589                    0))
2590        (setf ux (- ux)
2591              uy (- uy)
2592              uz (- uz)))
2593      (setf uxold ux
2594            uyold uy
2595            uzold uz)
2596      ; vector v = n times u
2597      (setf vx (- (* ny uz) (* nz uy))
2598            vy (- (* nz ux) (* nx uz))
2599            vz (- (* nx uy) (* ny ux)))
2600      ; parametric equation of the circumference of radius
2601      ; r and centered at c=(cx,cy,cz):
2602      ; x(t) = c + r(cos(t)u + sin(t)v),
2603      ; for t in (0, 2*%pi)
2604      (setf vv 0.0)
2605      (setf circ '())
2606      (loop for i below vgrid do
2607        (setf rcos (* r (cos vv))
2608              rsin (* r (sin vv)))
2609        (setf xx (+ cx (* rcos ux) (* rsin vx))
2610              yy (+ cy (* rcos uy) (* rsin vy))
2611              zz (+ cz (* rcos uz) (* rsin vz)))
2612        (transform-point 3)
2613        (check-extremes-x)
2614        (check-extremes-y)
2615        (check-extremes-z)
2616        ; check texture model
2617        (case *draw-enhanced3d-type*
2618          (0      (setf circ (cons (list xx yy zz) circ)))
2619          ((1 99) (setf circ (cons (list xx yy zz (funcall *draw-enhanced3d-fun* tt)) circ)))
2620          (3      (setf circ (cons (list xx yy zz (funcall *draw-enhanced3d-fun* xx yy zz)) circ))))
2621        (setf vv (+ vv veps))
2622        (when (> vv vmax) (setf vv vmax))  ) ; loop for
2623      (setf result (append result (apply #'append circ)))
2624      when (>= tt tmax) do (loop-finish)
2625      do (setf tt (+ tt teps))
2626         (when (> tt tmax) (setf tt tmax))  ) ; loop do
2627      (check-tube-extreme 2 cx cy cz circ)
2628    ; update x-y-z ranges
2629    (update-ranges-3d xmin xmax ymin ymax zmin zmax)
2630    (make-gr-object
2631       :name 'tube
2632       :command (format nil " ~a w ~a lw ~a lt ~a lc ~a"
2633                            (make-obj-title (get-option '$key))
2634                            (if (> *draw-enhanced3d-type* 0) "pm3d" "l")
2635                            (get-option '$line_width)
2636                            (get-option '$line_type)
2637                            (hex-to-rgb (get-option '$color)))
2638       :groups `((,ncols ,vgrid))
2639       :points `(,(make-array (length result) :element-type 'flonum
2640                                              :initial-contents result)))))
2641
2642
2643
2644
2645
2646
2647
2648;; Object: 'image'
2649;; Usages:
2650;;     image(matrix_of_numbers,x0,y0,width,height)
2651;;     image(matrix_of_[r,g,b],x0,y0,width,height)
2652;;     image(picture_object,x0,y0,width,height)
2653;; Options:
2654;;     colorbox
2655;;     palette
2656(defun image (mat x0 y0 width height)
2657  (let ( (fx0 ($float x0))
2658         (fy0 ($float y0))
2659         (fwidth ($float width))
2660         (fheight ($float height))
2661         result nrows ncols dx dy n)
2662    (cond (($matrixp mat)
2663             (setf nrows (length (cdr mat))
2664                   ncols (length (cdadr mat)))
2665             (setf dx (/ fwidth ncols)
2666                   dy (/ fheight nrows))
2667             (if (not ($listp (cadadr mat)))  ; it's a matrix of reals
2668                 (setf n 3)   ; 3 numbers to be sent to gnuplot: x,y,value
2669                 (setf n 5))  ; 5 numbers to be sent: x,y,r,g,b
2670             (case n
2671               (3 (setf result (make-array (* 3 nrows ncols) :element-type 'flonum))
2672                  (let ((yi (+ fy0 height (* dy -0.5)))
2673                        (counter -1)
2674                         xi)
2675                     (loop for row on (cdr mat) by #'cdr do
2676                       (setf xi (+ fx0 (* dx 0.5)))
2677                       (loop for col on (cdar row) by #'cdr do
2678                         (setf (aref result (incf counter)) xi
2679                               (aref result (incf counter)) yi
2680                               (aref result (incf counter)) ($float (car col)))
2681                         (setf xi (+ xi dx)))
2682                       (setf yi (- yi dy)) )))
2683               (5 (setf result (make-array (* 5 nrows ncols) :element-type 'flonum))
2684                  (let ((yi (+ fy0 height (* dy -0.5)))
2685                        (counter -1)
2686                         xi colors)
2687                     (loop for row on (cdr mat) by #'cdr do
2688                       (setf xi (+ fx0 (* dx 0.5)))
2689                       (loop for col on (cdar row) by #'cdr do
2690                         (setf colors (cdar col))
2691                         (setf (aref result (incf counter)) xi
2692                               (aref result (incf counter)) yi
2693                               (aref result (incf counter)) ($float (car colors))
2694                               (aref result (incf counter)) ($float (cadr colors))
2695                               (aref result (incf counter)) ($float (caddr colors)))
2696                         (setf xi (+ xi dx)))
2697                       (setf yi (- yi dy)) )))))
2698          (($picturep mat)
2699             (setf nrows (nth 3 mat)   ; picture height
2700                   ncols (nth 2 mat))  ; picture width
2701             (setf dx (/ fwidth ncols)
2702                   dy (/ fheight nrows))
2703             (if (equal (nth 1 mat) '$level)  ; gray level picture
2704                 (setf n 3)   ; 3 numbers to be sent to gnuplot: x,y,value
2705                 (setf n 5))  ; 5 numbers to be sent: x,y,r,g,b
2706             (setf result (make-array (* n nrows ncols) :element-type 'flonum))
2707             (let ((yi (+ fy0 height (* dy -0.5)))
2708                   (count1 -1)
2709                   (count2 -1)
2710                   xi)
2711                (loop for r from 0 below nrows do
2712                  (setf xi (+ fx0 (* dx 0.5)))
2713                  (loop for c from 0 below ncols do
2714                    (setf (aref result (incf count1)) xi)
2715                    (setf (aref result (incf count1)) yi)
2716                    (loop for q from 3 to n do
2717                      (setf (aref result (incf count1))
2718                            ($float (aref (nth 4 mat) (incf count2)))))
2719                    (setf xi (+ xi dx)))
2720                  (setf yi (- yi dy)))))
2721          (t
2722             (merror "draw2d (image): Argument not recognized")))
2723    ; update x-y ranges if necessary
2724    (update-ranges-2d fx0 (+ fx0 fwidth) fy0 (+ fy0 fheight))
2725    (make-gr-object
2726       :name 'image
2727       :command (case n
2728                   (3 (format nil " t '' w image"))
2729                   (5 (format nil " t '' w rgbimage")))
2730       :groups (case n
2731                   (3 '((3 0)))   ; numbers are sent to gnuplot in gropus of 3, no blank lines
2732                   (5 '((5 0))  ))  ; numbers in groups of 5, no blank lines
2733       :points (list result)) ) )
2734
2735
2736
2737
2738
2739
2740(defmacro write-palette-code ()
2741  '(let ((pal (get-option '$palette)))
2742     (cond
2743       ((equal pal '$gray)
2744          (format nil "set palette gray~%"))
2745       ((equal pal '$color)
2746          (format nil "set palette rgbformulae 7,5,15~%"))
2747       ((and (listp pal)
2748             (= (length pal) 3)
2749             (every #'(lambda (x) (and (integerp x) (<= (abs x) 36))) pal) )
2750          (format nil "set palette rgbformulae ~a,~a,~a~%"
2751                  (car pal) (cadr pal) (caddr pal)))
2752       ((and (listp pal)
2753             (every #'(lambda (x) (and (listp x) (= (length x) 3))) pal) )
2754          (let (triplete
2755                (n (length pal)))
2756            (with-output-to-string (stream)
2757              (format stream "set palette defined ( \\~%")
2758              (dotimes (k n)
2759                (setf triplete (nth k pal))
2760                (format stream "  ~a ~a ~a ~a "
2761                        k (car triplete) (cadr triplete) (caddr triplete))
2762                (if (= (1+ k) n)
2763                  (format stream ")~%")
2764                  (format stream ", \\~%") )))))
2765       (t
2766          (merror "draw: illegal palette description")))))
2767
2768
2769
2770(defvar *2d-graphic-objects* (make-hash-table))
2771
2772; table of basic 2d graphic objects
2773(setf (gethash '$points        *2d-graphic-objects*) 'points
2774      (gethash '$errors        *2d-graphic-objects*) 'errors
2775      (gethash '$polygon       *2d-graphic-objects*) 'polygon
2776      (gethash '$ellipse       *2d-graphic-objects*) 'ellipse
2777      (gethash '$triangle      *2d-graphic-objects*) 'triangle
2778      (gethash '$rectangle     *2d-graphic-objects*) 'rectangle
2779      (gethash '$quadrilateral *2d-graphic-objects*) 'quadrilateral
2780      (gethash '$region        *2d-graphic-objects*) 'region
2781      (gethash '$explicit      *2d-graphic-objects*) 'explicit
2782      (gethash '$implicit      *2d-graphic-objects*) 'implicit
2783      (gethash '$parametric    *2d-graphic-objects*) 'parametric
2784      (gethash '$vector        *2d-graphic-objects*) 'vect
2785      (gethash '$label         *2d-graphic-objects*) 'label
2786      (gethash '$bars          *2d-graphic-objects*) 'bars
2787      (gethash '$polar         *2d-graphic-objects*) 'polar
2788      (gethash '$image         *2d-graphic-objects*) 'image
2789      (gethash '%points        *2d-graphic-objects*) 'points
2790      (gethash '%errors        *2d-graphic-objects*) 'errors
2791      (gethash '%polygon       *2d-graphic-objects*) 'polygon
2792      (gethash '%ellipse       *2d-graphic-objects*) 'ellipse
2793      (gethash '%triangle      *2d-graphic-objects*) 'triangle
2794      (gethash '%rectangle     *2d-graphic-objects*) 'rectangle
2795      (gethash '%quadrilateral *2d-graphic-objects*) 'quadrilateral
2796      (gethash '%region        *2d-graphic-objects*) 'region
2797      (gethash '%explicit      *2d-graphic-objects*) 'explicit
2798      (gethash '%implicit      *2d-graphic-objects*) 'implicit
2799      (gethash '%parametric    *2d-graphic-objects*) 'parametric
2800      (gethash '%vector        *2d-graphic-objects*) 'vect
2801      (gethash '%label         *2d-graphic-objects*) 'label
2802      (gethash '%bars          *2d-graphic-objects*) 'bars
2803      (gethash '%polar         *2d-graphic-objects*) 'polar
2804      (gethash '%image         *2d-graphic-objects*) 'image )
2805
2806(defun make-scene-2d (args)
2807   (let ((objects nil)
2808         plotcmd largs aux)
2809      (ini-gr-options)
2810      (ini-local-option-variables)
2811      (user-defaults)
2812      (setf largs (listify-arguments args))
2813      ; update option values and detect objects to be plotted
2814      (dolist (x largs)
2815         (cond ((equal ($op x) "=")
2816                   (update-gr-option ($lhs x) ($rhs x)))
2817               ((not (null (gethash (setf aux (caar x)) *2d-graphic-objects*)))
2818                  (setf objects
2819                         (append
2820                            objects
2821                            (list (apply (gethash aux *2d-graphic-objects*) (rest x))))))
2822               (t (merror "draw: 2D graphic object not recognized, ~M" aux))))
2823      ; save in plotcmd the gnuplot preamble
2824      (setf plotcmd
2825         (concatenate 'string
2826            (unless (or *multiplot-is-active*
2827                        (member (get-option '$terminal) '($eps $epslatex $epslatex_standalone)))
2828               (format nil "set obj 1 fc rgb '~a' fs solid 1.0 noborder ~%"
2829                       (get-option '$background_color)) )
2830            (if (equal (get-option '$proportional_axes) '$none)
2831               (format nil "set size noratio~%")
2832               (format nil "set size ratio -1~%") )
2833            ; this let statement is to prevent error messages from gnuplot when
2834            ; the amplitude of the ranges equals zero
2835            (let ((xi (first  (get-option '$xrange)))
2836                  (xf (second (get-option '$xrange)))
2837                  (yi (first  (get-option '$yrange)))
2838                  (yf (second (get-option '$yrange)))
2839                  (x2i (first  (get-option '$xrange_secondary)))
2840                  (x2f (second (get-option '$xrange_secondary)))
2841                  (y2i (first  (get-option '$yrange_secondary)))
2842                  (y2f (second (get-option '$yrange_secondary))) )
2843               (when (and (get-option '$xrange) (near-equal xi xf))
2844                  (setf xi (- xi 0.01)
2845                        xf (+ xf 0.01)))
2846               (when (and (get-option '$xrange_secondary) (near-equal x2i x2f))
2847                  (setf x2i (- x2i 0.01)
2848                        x2f (+ x2f 0.01)))
2849               (when (and (get-option '$yrange) (near-equal yi yf))
2850                  (setf yi (- yi 0.01)
2851                        yf (+ yf 0.01)))
2852               (when (and (get-option '$yrange_secondary) (near-equal y2i y2f))
2853                  (setf y2i (- y2i 0.01)
2854                        y2f (+ y2f 0.01)))
2855               (format nil "~a~a~a~a"
2856                       (if (get-option '$xrange)
2857                         (format nil "set xrange [~a:~a]~%" xi xf)
2858                         "")
2859                       (if (get-option '$xrange_secondary)
2860                         (format nil "set x2range [~a:~a]~%" x2i x2f)
2861                         "")
2862                       (if (get-option '$yrange)
2863                         (format nil "set yrange [~a:~a]~%" yi yf)
2864                         "")
2865                       (if (get-option '$yrange_secondary)
2866                         (format nil "set y2range [~a:~a]~%" y2i y2f)
2867                         "") ) )
2868            (if (get-option '$cbrange)
2869               (format nil "set cbrange [~a:~a]~%"
2870                  (first (get-option '$cbrange))
2871                  (second (get-option '$cbrange)))
2872               (format nil "set cbrange [*:*]~%") )
2873            (if (get-option '$logx)
2874               (format nil "set logscale x~%")
2875               (format nil "unset logscale x~%"))
2876            (if (get-option '$logx_secondary)
2877               (format nil "set logscale x2~%")
2878               (format nil "unset logscale x2~%"))
2879            (if (get-option '$logy)
2880               (format nil "set logscale y~%")
2881               (format nil "unset logscale y~%"))
2882            (if (get-option '$logy_secondary)
2883               (format nil "set logscale y2~%")
2884               (format nil "unset logscale y2~%"))
2885            (if (get-option '$logcb)
2886               (format nil "set logscale cb~%")
2887	      (format nil "unset logscale cb~%") )
2888
2889	    ( if (equal (car (get-option '$grid)) 0)
2890		(format nil "unset grid~%")
2891	        (format nil "set grid xtics ytics mxtics mytics~%set mxtics ~d~%set mytics ~d~%"
2892		      (car  (get-option '$grid))
2893		      (cadr (get-option '$grid))
2894		      )
2895	      )
2896
2897            (format nil "set title '~a'~%"  (get-option '$title))
2898            (format nil "set xlabel '~a'~%" (get-option '$xlabel))
2899            (format nil "set x2label '~a'~%" (get-option '$xlabel_secondary))
2900            (format nil "set ylabel '~a'~%" (get-option '$ylabel))
2901            (format nil "set y2label '~a'~%" (get-option '$ylabel_secondary))
2902            (let ((suma 0))
2903              (if (get-option '$axis_bottom)  (setf suma (+ suma 1)))
2904              (if (get-option '$axis_left) (setf suma (+ suma 2)))
2905              (if (get-option '$axis_top) (setf suma (+ suma 4)))
2906              (if (get-option '$axis_right) (setf suma (+ suma 8)))
2907              (format nil "set border ~a~%" suma) )
2908            (if (get-option '$key_pos)
2909              (format nil "set key ~a~%" (get-option '$key_pos))
2910              (format nil "set key top right~%") )
2911            (if (get-option '$xaxis)
2912               (format nil "set xzeroaxis lw ~a lt ~a lc ~a~%"
2913                           (get-option '$xaxis_width)
2914                           (get-option '$xaxis_type)
2915                           (hex-to-rgb (get-option '$xaxis_color)) )
2916               (format nil "unset xzeroaxis~%"))
2917            (if (get-option '$yaxis)
2918               (format nil "set yzeroaxis lw ~a lt ~a lc ~a~%"
2919                           (get-option '$yaxis_width)
2920                           (get-option '$yaxis_type)
2921                           (hex-to-rgb (get-option '$yaxis_color)) )
2922               (format nil "unset yzeroaxis~%"))
2923            (if (null (get-option '$xtics_secondary))
2924               (format nil "unset x2tics~%set xtics nomirror~%")
2925               (format nil "set x2tics ~a ~a ~a~%"
2926                       (if (get-option '$xtics_secondary_rotate) "rotate" "norotate")
2927                       (if (get-option '$xtics_secondary_axis) "axis" "border")
2928                       (get-option '$xtics_secondary)))
2929            (if (null (get-option '$xtics))
2930               (format nil "unset xtics~%")
2931               (format nil "set xtics ~a ~a ~a~%"
2932                       (if (get-option '$xtics_rotate) "rotate" "norotate")
2933                       (if (get-option '$xtics_axis) "axis" "border")
2934                       (get-option '$xtics)))
2935            (if (null (get-option '$ytics_secondary))
2936               (format nil "unset y2tics~%set ytics nomirror~%")
2937               (format nil "set ytics nomirror~%set y2tics ~a ~a ~a~%"
2938                       (if (get-option '$ytics_secondary_rotate) "rotate" "norotate")
2939                       (if (get-option '$ytics_secondary_axis) "axis" "border")
2940                       (get-option '$ytics_secondary)))
2941            (if (null (get-option '$ytics))
2942               (format nil "unset ytics~%")
2943               (format nil "set ytics ~a ~a ~a~%"
2944                       (if (get-option '$ytics_rotate) "rotate" "norotate")
2945                       (if (get-option '$ytics_axis) "axis" "border")
2946                       (get-option '$ytics)))
2947            (if (null (get-option '$cbtics))
2948               (format nil "unset cbtics~%")
2949               (format nil "set cbtics ~a~%" (get-option '$cbtics) ))
2950            (if (get-option '$colorbox)
2951               (format nil "set colorbox~%")
2952               (format nil "unset colorbox~%"))
2953            (format nil "set cblabel '~a'~%"
2954                        (if (stringp (get-option '$colorbox))
2955                          (get-option '$colorbox)
2956                          ""))
2957            (write-palette-code)
2958            (if (not (string= (get-option '$user_preamble) ""))
2959               (format nil "~a~%" (get-option '$user_preamble))) ) )
2960      ; scene allocation
2961      (setf *allocations* (cons (get-option '$allocation) *allocations*))
2962      ; scene description: (dimensions, gnuplot preamble in string format, list of objects)
2963      (list
2964         2       ; it's a 2d scene
2965         plotcmd ; gnuplot preamble
2966         objects ; list of objects to be plotted
2967         )))
2968
2969
2970
2971
2972
2973
2974(defvar *3d-graphic-objects* (make-hash-table))
2975
2976; table of basic 3d graphic objects
2977(setf (gethash '$points             *3d-graphic-objects*) 'points3d
2978      (gethash '$elevation_grid     *3d-graphic-objects*) 'elevation_grid
2979      (gethash '$mesh               *3d-graphic-objects*) 'mesh
2980      (gethash '$triangle           *3d-graphic-objects*) 'triangle3d
2981      (gethash '$quadrilateral      *3d-graphic-objects*) 'quadrilateral3d
2982      (gethash '$explicit           *3d-graphic-objects*) 'explicit3d
2983      (gethash '$implicit           *3d-graphic-objects*) 'implicit3d
2984      (gethash '$parametric         *3d-graphic-objects*) 'parametric3d
2985      (gethash '$vector             *3d-graphic-objects*) 'vect3d
2986      (gethash '$label              *3d-graphic-objects*) 'label
2987      (gethash '$parametric_surface *3d-graphic-objects*) 'parametric_surface
2988      (gethash '$tube               *3d-graphic-objects*) 'tube
2989      (gethash '$spherical          *3d-graphic-objects*) 'spherical
2990      (gethash '$cylindrical        *3d-graphic-objects*) 'cylindrical
2991      (gethash '%points             *3d-graphic-objects*) 'points3d
2992      (gethash '%elevation_grid     *3d-graphic-objects*) 'elevation_grid
2993      (gethash '%mesh               *3d-graphic-objects*) 'mesh
2994      (gethash '%triangle           *3d-graphic-objects*) 'triangle3d
2995      (gethash '%quadrilateral      *3d-graphic-objects*) 'quadrilateral3d
2996      (gethash '%explicit           *3d-graphic-objects*) 'explicit3d
2997      (gethash '%implicit           *3d-graphic-objects*) 'implicit3d
2998      (gethash '%parametric         *3d-graphic-objects*) 'parametric3d
2999      (gethash '%vector             *3d-graphic-objects*) 'vect3d
3000      (gethash '%label              *3d-graphic-objects*) 'label
3001      (gethash '%parametric_surface *3d-graphic-objects*) 'parametric_surface
3002      (gethash '%tube               *3d-graphic-objects*) 'tube
3003      (gethash '%spherical          *3d-graphic-objects*) 'spherical
3004      (gethash '%cylindrical        *3d-graphic-objects*) 'cylindrical  )
3005
3006;; This function builds a 3d scene by calling the
3007;; graphic objects constructors.
3008(defun make-scene-3d (args)
3009   (let ((objects nil)
3010         plotcmd largs aux)
3011      (ini-gr-options)
3012      (ini-local-option-variables)
3013      (user-defaults)
3014      (setf largs (listify-arguments args))
3015      ; update option values and detect objects to be plotted
3016      (dolist (x largs)
3017         (cond ((equal ($op x) "=")
3018                  (update-gr-option ($lhs x) ($rhs x)))
3019               ((not (null (gethash (setf aux (caar x)) *3d-graphic-objects*)))
3020                  (setf objects
3021                         (append
3022                            objects
3023                            (list (apply (gethash aux *3d-graphic-objects*) (rest x))))))
3024               (t (merror "draw: 3D graphic object not recognized, ~M" aux) )))
3025      ; save in plotcmd the gnuplot preamble
3026      (setf plotcmd
3027         (concatenate 'string
3028            (format nil "set style rectangle fillcolor rgb '~a' fs solid 1.0 noborder~%"
3029                        (get-option '$background_color)) ; background rectangle
3030            ; this let statement is to prevent error messages in gnuplot when
3031            ; the amplitude of the ranges equals zero
3032            (let ((xi (first  (get-option '$xrange)))
3033                  (xf (second (get-option '$xrange)))
3034                  (yi (first  (get-option '$yrange)))
3035                  (yf (second (get-option '$yrange)))
3036                  (zi (first  (get-option '$zrange)))
3037                  (zf (second (get-option '$zrange))))
3038               (when (near-equal xi xf)
3039                  (setf xi (- xi 0.01)
3040                        xf (+ xf 0.01)))
3041               (when (near-equal yi yf)
3042                  (setf yi (- yi 0.01)
3043                        yf (+ yf 0.01)))
3044               (when (near-equal zi zf)
3045                  (setf zi (- zi 0.01)
3046                        zf (+ zf 0.01)))
3047               (format nil "set xrange [~a:~a]~%set yrange [~a:~a]~%set zrange [~a:~a]~%"
3048                           xi xf yi yf zi zf))
3049            (if (get-option '$cbrange)
3050               (format nil "set cbrange [~a:~a]~%"
3051                  (first (get-option '$cbrange))
3052                  (second (get-option '$cbrange)) )
3053               (format nil "set cbrange [*:*]~%") )
3054            (case (get-option '$contour)
3055               ($surface (format nil "set contour surface~%set cntrparam levels ~a~%"
3056                                      (get-option '$contour_levels) ))
3057               ($base    (format nil "set contour base~%set cntrparam levels ~a~%"
3058                                      (get-option '$contour_levels) ))
3059               ($both    (format nil "set contour both~%set cntrparam levels ~a~%"
3060                                      (get-option '$contour_levels) ))
3061               ($map     (format nil "set contour base~%unset surface~%set cntrparam levels ~a~%"
3062                                      (get-option '$contour_levels))) )
3063            (format nil "set title '~a'~%"  (get-option '$title))
3064            (format nil "set xlabel '~a'~%" (get-option '$xlabel))
3065            (format nil "set ylabel '~a'~%" (get-option '$ylabel))
3066            (if (< (length (get-option '$zlabel)) 5)
3067               (format nil "set zlabel '~a'~%" (get-option '$zlabel))
3068               (format nil "set zlabel '~a' rotate~%" (get-option '$zlabel)) )
3069            (format nil "set datafile missing 'NIL'~%")
3070            (if (get-option '$logx)
3071               (format nil "set logscale x~%")
3072               (format nil "unset logscale x~%"))
3073            (if (get-option '$logy)
3074               (format nil "set logscale y~%")
3075               (format nil "unset logscale y~%"))
3076            (if (get-option '$logz)
3077               (format nil "set logscale z~%")
3078               (format nil "unset logscale z~%"))
3079            (if (get-option '$key_pos)
3080               (format nil "set key ~a~%" (get-option '$key_pos))
3081               (format nil "set key top center~%") )
3082            (if (get-option '$logcb)
3083               (format nil "set logscale cb~%")
3084               (format nil "unset logscale cb~%") )
3085	    (if (equal (car (get-option '$grid)) 0)
3086		(format nil "unset grid~%")
3087	        (format nil "set grid xtics ytics ztics mxtics mytics mztics~%set mxtics ~d~%set mytics ~d~%"
3088		      (car  (get-option '$grid))
3089		      (cadr (get-option '$grid))
3090		      )
3091	      )
3092            (if (get-option '$xaxis)
3093               (format nil "set xzeroaxis lw ~a lt ~a lc ~a~%"
3094                           (get-option '$xaxis_width)
3095                           (get-option '$xaxis_type)
3096                           (hex-to-rgb (get-option '$xaxis_color)) )
3097               (format nil "unset xzeroaxis~%"))
3098            (if (get-option '$yaxis)
3099               (format nil "set yzeroaxis lw ~a lt ~a lc ~a~%"
3100                           (get-option '$yaxis_width)
3101                           (get-option '$yaxis_type)
3102                           (hex-to-rgb (get-option '$yaxis_color)) )
3103               (format nil "unset yzeroaxis~%"))
3104            (if (get-option '$zaxis)
3105               (format nil "set zzeroaxis lw ~a lt ~a lc ~a~%"
3106                           (get-option '$zaxis_width)
3107                           (get-option '$zaxis_type)
3108                           (hex-to-rgb (get-option '$zaxis_color)))
3109               (format nil "unset zzeroaxis~%"))
3110            (if (null (get-option '$xtics))
3111               (format nil "unset xtics~%")
3112               (format nil "set xtics ~a ~a ~a~%"
3113                       (if (get-option '$xtics_rotate) "rotate" "norotate")
3114                       (if (get-option '$xtics_axis) "axis" "border")
3115                       (get-option '$xtics)))
3116            (if (null (get-option '$ytics))
3117               (format nil "unset ytics~%")
3118               (format nil "set ytics ~a ~a ~a~%"
3119                       (if (get-option '$ytics_rotate) "rotate" "norotate")
3120                       (if (get-option '$ytics_axis) "axis" "border")
3121                       (get-option '$ytics)))
3122            (if (null (get-option '$ztics))
3123               (format nil "unset ztics~%")
3124               (format nil "set ztics ~a ~a ~a~%"
3125                       (if (get-option '$ztics_rotate) "rotate" "norotate")
3126                       (if (get-option '$ztics_axis) "axis" "border")
3127                       (get-option '$ztics)))
3128            (if (null (get-option '$cbtics))
3129               (format nil "unset cbtics~%")
3130               (format nil "set cbtics ~a~%"
3131                       (get-option '$cbtics)) )
3132            (if (or (eql (get-option '$contour) '$map)
3133                    (eql (get-option '$view) '$map) )
3134               (format nil "set view map~%~a~%"
3135                            (if (equal (get-option '$proportional_axes) '$none)
3136                               "set size noratio"
3137                               "set size ratio -1") )
3138               (format nil "set view ~a, ~a, 1, 1~%~a~%"
3139                            (first  (get-option '$view))
3140                            (second (get-option '$view))
3141                            (case (get-option '$proportional_axes)
3142                               ($xy       "set view equal xy" )
3143                               ($xyz      "set view equal xyz")
3144                               (otherwise ""))))
3145            (if (not (get-option '$axis_3d))
3146                (format nil "set border 0~%unset xtics~%unset ytics~%unset ztics~%"))
3147            (when (not (null (get-option '$enhanced3d)))
3148              (if (null (get-option '$wired_surface))
3149                (format nil "set pm3d at s ~a explicit~%" (get-option '$interpolate_color))
3150                (format nil "set style line 1 lt 1 lw 1 lc rgb '#000000'~%set pm3d at s depthorder explicit hidden3d 1~%") ))
3151            (if (get-option '$surface_hide)
3152               (format nil "set hidden3d nooffset~%"))
3153            (if (get-option '$xyplane)
3154               (format nil "set xyplane at ~a~%" (get-option '$xyplane)))
3155            (if (get-option '$colorbox)
3156               (format nil "set colorbox~%")
3157               (format nil "unset colorbox~%"))
3158            (format nil "set cblabel '~a'~%"
3159                        (if (stringp (get-option '$colorbox))
3160                          (get-option '$colorbox)
3161                          ""))
3162            (write-palette-code)
3163            (if (not (string= (get-option '$user_preamble) ""))
3164               (format nil "~a~%" (get-option '$user_preamble)))  ))
3165      ; scene allocation
3166      (setf *allocations* (cons (get-option '$allocation) *allocations*))
3167      ; scene description: (dimensions, gnuplot preamble in string format, list of objects)
3168      (list
3169         3       ; it's a 3d scene
3170         plotcmd ; gnuplot preamble
3171         objects ; list of objects to be plotted
3172         ) ))
3173
3174
3175
3176
3177
3178
3179
3180(defmacro write-subarray (arr str)
3181  `(format ,str
3182           "~a~%"
3183           (apply
3184             #'concatenate 'string
3185             (map
3186                'list
3187                #'(lambda (z) (format nil "~a " z))
3188                ,arr))))
3189
3190
3191
3192(defun draw_gnuplot (&rest args)
3193  (ini-global-options)
3194  (user-defaults)
3195  (setf *allocations* nil)
3196  (let ((counter 0)
3197        (scenes-list '((mlist simp)))  ; these two variables will be used
3198        gfn ; gnuplot_file_name
3199        dfn ; data_file_name
3200        scene-short-description        ; to build the text output
3201        scenes
3202        cmdstorage  ; file maxout.gnuplot
3203        datastorage ; file data.gnuplot
3204        datapath    ; path to data.gnuplot
3205        (ncols 1)
3206        nrows width height ; multiplot parameters
3207        isanimatedgif ismultipage is1stobj biglist grouplist largs)
3208
3209    (setf largs (listify-arguments args))
3210    (dolist (x largs)
3211      (cond ((equal ($op x) "=")
3212              (case ($lhs x)
3213                ($terminal          (update-gr-option '$terminal ($rhs x)))
3214                ($columns           (update-gr-option '$columns ($rhs x)))
3215                ($dimensions        (update-gr-option '$dimensions ($rhs x)))
3216                ($file_name         (update-gr-option '$file_name ($rhs x)))
3217                ($gnuplot_file_name (update-gr-option '$gnuplot_file_name ($rhs x)))
3218                ($data_file_name    (update-gr-option '$data_file_name ($rhs x)))
3219                ($delay             (update-gr-option '$delay ($rhs x)))
3220
3221                ; deprecated global options
3222                ($file_bgcolor      (update-gr-option '$file_bgcolor ($rhs x)))
3223                ($pic_width         (update-gr-option '$pic_width ($rhs x)))
3224                ($pic_height        (update-gr-option '$pic_height ($rhs x)))
3225                ($eps_width         (update-gr-option '$eps_width ($rhs x)))
3226                ($eps_height        (update-gr-option '$eps_height ($rhs x)))
3227                ($pdf_width         (update-gr-option '$pdf_width ($rhs x)))
3228                ($pdf_height        (update-gr-option '$pdf_height ($rhs x)))
3229
3230                (otherwise (merror "draw: unknown global option ~M " ($lhs x)))))
3231            ((equal (caar x) '$gr3d)
3232              (setf scenes (append scenes (list (funcall #'make-scene-3d (rest x))))))
3233            ((equal (caar x) '$gr2d)
3234              (setf scenes (append scenes (list (funcall #'make-scene-2d (rest x))))))
3235            (t
3236              (merror "draw: item ~M is not recognized" x)))   )
3237    (setf isanimatedgif
3238          (equal (get-option '$terminal) '$animated_gif))
3239    (setf ismultipage
3240          (member (get-option '$terminal)
3241                  '($multipage_pdf $multipage_pdfcairo $multipage_eps $multipage_eps_color)))
3242
3243    (setf
3244       gfn (plot-temp-file (get-option '$gnuplot_file_name))
3245       dfn (plot-temp-file (get-option '$data_file_name)))
3246
3247    ;; we now create two files: maxout.gnuplot and data.gnuplot
3248    (setf cmdstorage
3249          (open gfn
3250                :direction :output :if-exists :supersede))
3251    (if (eql cmdstorage nil)
3252      (merror "draw: Cannot create file '~a'. Probably maxima_tempdir doesn't point to a writable directory." gfn))
3253    (setf datastorage
3254          (open dfn
3255                :direction :output :if-exists :supersede))
3256    (if (eql datastorage nil)
3257      (merror "draw: Cannot create file '~a'. Probably maxima_tempdir doesn't point to a writable directory." dfn))
3258
3259    (setf datapath (format nil "'~a'" dfn))
3260    ; when one multiplot window is active, change of terminal is not allowed
3261    (if (not *multiplot-is-active*)
3262      (case (get-option '$terminal)
3263        ($dumb (format cmdstorage "set terminal dumb size ~a, ~a"
3264                           (round (/ (first (get-option '$dimensions)) 10))
3265                           (round (/ (second (get-option '$dimensions)) 10))))
3266        ($dumb_file (format cmdstorage "set terminal dumb size ~a, ~a~%set out '~a.dumb'"
3267                           (round (/ (first (get-option '$dimensions)) 10))
3268                           (round (/ (second (get-option '$dimensions)) 10))
3269                           (get-option '$file_name)))
3270 	($canvas (format cmdstorage "set terminal canvas enhanced ~a size ~a, ~a~%set out '~a.html'"
3271 			 (write-font-type)
3272 			 (round (first (get-option '$dimensions)))
3273 			 (round (second (get-option '$dimensions)))
3274 			 (get-option '$file_name)))
3275        ($png (format cmdstorage "set terminal png enhanced truecolor ~a size ~a, ~a~%set out '~a.png'"
3276                           (write-font-type)
3277                           (round (first (get-option '$dimensions)))
3278                           (round (second (get-option '$dimensions)))
3279                           (get-option '$file_name) ) )
3280        ($pngcairo (format cmdstorage "set terminal pngcairo dashed enhanced truecolor ~a size ~a, ~a~%set out '~a.png'"
3281                           (write-font-type)
3282                           (round (first (get-option '$dimensions)))
3283                           (round (second (get-option '$dimensions)))
3284                           (get-option '$file_name) ) )
3285        (($eps $multipage_eps) (format cmdstorage "set terminal postscript dashed eps enhanced ~a size ~acm, ~acm~%set out '~a.eps'"
3286                           (write-font-type)
3287                           (/ (first (get-option '$dimensions)) 100.0)
3288                           (/ (second (get-option '$dimensions)) 100.0)
3289                           (get-option '$file_name)))
3290        (($eps_color $multipage_eps_color) (format cmdstorage "set terminal postscript dashed eps enhanced ~a color size ~acm, ~acm~%set out '~a.eps'"
3291                           (write-font-type)
3292                           (/ (first (get-option '$dimensions)) 100.0)
3293                           (/ (second (get-option '$dimensions)) 100.0)
3294                           (get-option '$file_name)))
3295        ($epslatex (format cmdstorage "set terminal epslatex ~a color size ~acm, ~acm~%set out '~a.tex'"
3296                           (write-font-type)
3297                           (/ (first (get-option '$dimensions)) 100.0)
3298                           (/ (second (get-option '$dimensions)) 100.0)
3299                           (get-option '$file_name)))
3300        ($epslatex_standalone (format cmdstorage "set terminal epslatex dashed standalone ~a color size ~acm, ~acm~%set out '~a.tex'"
3301                           (write-font-type)
3302                           (/ (first (get-option '$dimensions)) 100.0)
3303                           (/ (second (get-option '$dimensions)) 100.0)
3304                           (get-option '$file_name)))
3305        (($pdf $multipage_pdf) (format cmdstorage "set terminal pdf dashed enhanced ~a color size ~acm, ~acm~%set out '~a.pdf'"
3306                           (write-font-type)
3307                           (/ (first (get-option '$dimensions)) 100.0)
3308                           (/ (second (get-option '$dimensions)) 100.0)
3309                           (get-option '$file_name)))
3310        (($pdfcairo $multipage_pdfcairo) (format cmdstorage "set terminal pdfcairo dashed enhanced ~a color size ~acm, ~acm~%set out '~a.pdf'"
3311                           (write-font-type)
3312                           (/ (first (get-option '$dimensions)) 100.0)
3313                           (/ (second (get-option '$dimensions)) 100.0)
3314                           (get-option '$file_name)))
3315        ($jpg (format cmdstorage "set terminal jpeg enhanced ~a size ~a, ~a~%set out '~a.jpg'"
3316                           (write-font-type)
3317                           (round (first (get-option '$dimensions)))
3318                           (round (second (get-option '$dimensions)))
3319                           (get-option '$file_name)))
3320        ($gif (format cmdstorage "set terminal gif enhanced ~a size ~a, ~a~%set out '~a.gif'"
3321                           (write-font-type)
3322                           (round (first (get-option '$dimensions)))
3323                           (round (second (get-option '$dimensions)))
3324                           (get-option '$file_name)))
3325        ($svg (format cmdstorage "set terminal svg dashed enhanced ~a size ~a, ~a~%set out '~a.svg'"
3326                           (write-font-type)
3327                           (round (first (get-option '$dimensions)))
3328                           (round (second (get-option '$dimensions)))
3329                           (get-option '$file_name)))
3330        ($animated_gif (format cmdstorage "set terminal gif enhanced animate ~a size ~a, ~a delay ~a~%set out '~a.gif'"
3331                           (write-font-type)
3332                           (round (first (get-option '$dimensions)))
3333                           (round (second (get-option '$dimensions)))
3334                           (get-option '$delay)
3335                           (get-option '$file_name)))
3336        ($aquaterm (format cmdstorage "set terminal aqua enhanced ~a ~a size ~a ~a~%"
3337                           *draw-terminal-number*
3338                           (write-font-type)
3339                           (round (first (get-option '$dimensions)))
3340                           (round (second (get-option '$dimensions)))))
3341        ($wxt (format cmdstorage "set terminal wxt dashed enhanced ~a ~a size ~a, ~a~%"
3342                           *draw-terminal-number*
3343                           (write-font-type)
3344                           (round (first (get-option '$dimensions)))
3345                           (round (second (get-option '$dimensions)))))
3346        ($qt (format cmdstorage "set terminal qt dashed enhanced ~a ~a size ~a, ~a~%"
3347                           *draw-terminal-number*
3348                           (write-font-type)
3349                           (round (first (get-option '$dimensions)))
3350                           (round (second (get-option '$dimensions)))))
3351        ($x11 (format cmdstorage "if(GPVAL_VERSION >= 5.0){set terminal x11 dashed enhanced ~a ~a size ~a, ~a replotonresize} else {set terminal x11 dashed enhanced ~a ~a size ~a, ~a}~%"
3352                           *draw-terminal-number*
3353                           (write-font-type)
3354                           (round (first (get-option '$dimensions)))
3355                           (round (second (get-option '$dimensions)))
3356                           *draw-terminal-number*
3357                           (write-font-type)
3358                           (round (first (get-option '$dimensions)))
3359                           (round (second (get-option '$dimensions)))))
3360	($windows (format cmdstorage "set terminal windows enhanced ~a ~a size ~a, ~a~%"
3361                           *draw-terminal-number*
3362                           (write-font-type)
3363                           (round (first (get-option '$dimensions)))
3364                           (round (second (get-option '$dimensions)))))
3365
3366        (otherwise ; default screen output
3367          (cond
3368            ((string= *autoconf-windows* "true")  ; running on windows operating system
3369              (format cmdstorage "set terminal windows enhanced ~a ~a size ~a, ~a~%"
3370                          *draw-terminal-number*
3371                          (write-font-type)
3372                          (round (first (get-option '$dimensions)))
3373                          (round (second (get-option '$dimensions)))))
3374            (t  ; other platforms
3375              (format cmdstorage "if(GPVAL_VERSION >= 5.0){set terminal x11 dashed enhanced ~a ~a size ~a, ~a replotonresize} else {set terminal x11 dashed enhanced ~a ~a size ~a, ~a}~%"
3376                           *draw-terminal-number*
3377                           (write-font-type)
3378                           (round (first (get-option '$dimensions)))
3379                           (round (second (get-option '$dimensions)))
3380			   *draw-terminal-number*
3381                           (write-font-type)
3382                           (round (first (get-option '$dimensions)))
3383                           (round (second (get-option '$dimensions))))))) ))
3384
3385    ; compute some parameters for multiplot
3386    (when (and (not isanimatedgif) (not ismultipage))
3387      (setf ncols (get-option '$columns))
3388      (setf nrows (ceiling (/ (length scenes) ncols)))
3389      (if (> (length scenes) 1)
3390        (format cmdstorage "~%set size 1.0, 1.0~%set origin 0.0, 0.0~%set multiplot~%")) )
3391
3392    ; Make gnuplot versions newer than 5.0 understand that linetype means
3393    ; we try to set the dash type
3394    (format cmdstorage "~%if(GPVAL_VERSION >= 5.0){set for [i=1:8] linetype i dashtype i; set format '%h'}")
3395
3396    ;; By default gnuplot assumes everything below 1e-8 to be a rounding error
3397    ;; and rounds it down to 0. This is handy for standalone gnuplot as it allows
3398    ;; to suppress pixels with imaginary part while allowing for small calculation
3399    ;; errors. As plot and draw handle the imaginary part without gnuplot's help
3400    ;; this isn't needed here and is turned off as it often surprises users.
3401    (format cmdstorage "~%set zero 0.0")
3402
3403    ; write descriptions of 2d and 3d scenes
3404    (let ((i -1)
3405          (alloc (reverse *allocations*))
3406          (nilcounter 0)
3407          thisalloc origin1 origin2 size1 size2)
3408
3409      ; recalculate nrows for automatic scene allocations
3410      (setf nrows (ceiling (/ (count nil alloc) ncols)))
3411
3412      (when (> nrows 0)
3413        (setf width (/ 1.0 ncols)
3414              height (/ 1.0 nrows)))
3415      (dolist (scn scenes)
3416        ; write size and origin if necessary
3417        (cond ((or isanimatedgif ismultipage)
3418                (format cmdstorage "~%set size 1.0, 1.0~%")
3419                (format cmdstorage "set obj 1 rectangle behind from screen 0.0,0.0 to screen 1.0,1.0~%") )
3420              (t ; it's not an animated gif
3421                (setf thisalloc (car alloc))
3422                (setf alloc (cdr alloc))
3423                (cond
3424                  (thisalloc ; user defined scene allocation
3425                     (setf origin1 (first thisalloc)
3426                           origin2 (second thisalloc)
3427                           size1   (third thisalloc)
3428                           size2   (fourth thisalloc)))
3429                  (t ; automatic scene allocation
3430                     (setf origin1 (* width (mod nilcounter ncols))
3431                           origin2 (* height (- nrows 1.0 (floor (/ nilcounter ncols))))
3432                           size1   width
3433                           size2   height)
3434                     (incf nilcounter)))
3435                (format cmdstorage "~%set size ~a, ~a~%" size1 size2)
3436                (format cmdstorage "set origin ~a, ~a~%" origin1 origin2)
3437                (unless (or *multiplot-is-active*
3438                            (member (get-option '$terminal) '($epslatex $epslatex_standalone)))
3439                  (format cmdstorage "set obj 1 rectangle behind from screen ~a,~a to screen ~a,~a~%"
3440                                     origin1 origin2 (+ origin1 size1 ) (+ origin2 size2)))  ))
3441        (setf is1stobj t
3442              biglist '()
3443              grouplist '())
3444        (format cmdstorage "~a" (second scn))
3445        (cond ((= (first scn) 2)    ; it's a 2d scene
3446                 (setf scene-short-description '(($gr2d simp)))
3447                 (format cmdstorage "plot "))
3448              ((= (first scn) 3)    ; it's a 3d scene
3449                 (setf scene-short-description '(($gr3d simp)))
3450                 (format cmdstorage "splot ")))
3451        (dolist (obj (third scn))
3452           (setf scene-short-description
3453                 (cons (gr-object-name obj) scene-short-description))
3454           (if is1stobj
3455             (setf is1stobj nil)
3456             (format cmdstorage ", \\~%")  )
3457           (let ((pcom (gr-object-command obj)))
3458             (cond
3459               ((listp pcom)
3460                  (while (consp pcom)
3461                    (format cmdstorage "~a~a~a~a"
3462                                       datapath
3463                                       (format nil " index ~a" (incf i))
3464                                       (pop pcom)
3465                                       (if (null pcom)
3466                                           ""
3467                                           "," )) ) )
3468               (t (format cmdstorage "~a~a~a"
3469                                     datapath
3470                                     (format nil " index ~a" (incf i))
3471                                     pcom) )))
3472           (setf grouplist (append grouplist (gr-object-groups obj)))
3473           (setf biglist (append biglist (gr-object-points obj))) )
3474
3475        ; let's write data in data.gnuplot
3476        (do ( (blis biglist (cdr blis))
3477              (glis grouplist (cdr glis) ))
3478            ((null blis) 'done)
3479          (let* ((vect (car blis))
3480                 (k (length vect))
3481                 (ncol (caar glis))
3482                 (l 0)
3483                 (m (cadar glis))
3484                 (non-numeric-region nil)
3485                 coordinates)
3486             (cond
3487                ((= m 0)     ; no blank lines
3488                   (do ((cont 0 (+ cont ncol)))
3489                       ((= cont k) 'done)
3490                     (setf coordinates (subseq vect cont (+ cont ncol)))
3491                     ; control of non numeric y values,
3492                     ; code related to draw_realpart
3493                     (cond
3494                       (non-numeric-region
3495                         (when (numberp (aref coordinates 1))
3496                           (setf non-numeric-region nil)
3497                           (write-subarray coordinates datastorage) ))
3498                       (t
3499                         (cond
3500                           ((numberp (aref coordinates 1))
3501                             (write-subarray coordinates datastorage))
3502                           (t
3503                             (setf non-numeric-region t)
3504                             (format datastorage "~%")))))) )
3505
3506                (t           ; blank lines every m lines
3507                   (do ((cont 0 (+ cont ncol)))
3508                       ((= cont k) 'done)
3509                     (when (eql l m)
3510                           (format datastorage "~%")
3511                           (setf l 0) )
3512                     (write-subarray (subseq vect cont (+ cont ncol)) datastorage)
3513                     (incf l)))))
3514          (format datastorage "~%~%") )
3515        (incf counter)
3516        (setf scenes-list (cons (reverse scene-short-description) scenes-list)) ))  ; end let-dolist scenes
3517    (close datastorage)
3518
3519    (cond ((or isanimatedgif ismultipage)  ; this is an animated gif or multipage plot file
3520             (if isanimatedgif
3521               (format cmdstorage "~%unset output~%quit~%~%")
3522               (format cmdstorage "~%set term dumb~%~%") )
3523             (close cmdstorage)
3524	     #+(or (and sbcl win32) (and sbcl win64) (and ccl windows))
3525             ($system $gnuplot_command gfn)
3526	     #-(or (and sbcl win32) (and sbcl win64) (and ccl windows))
3527	     ($system (format nil "~a \"~a\""
3528			      $gnuplot_command
3529			      gfn) ))
3530          (t ; non animated gif
3531             ; command file maxout.gnuplot is now ready
3532             (format cmdstorage "~%")
3533             (cond ((> (length scenes) 1)
3534                      (format cmdstorage "unset multiplot~%unset output ~%"))
3535                   ; if we want to save the coordinates in a file,
3536                   ; print them when hitting the x key after clicking the mouse button
3537                   ((not (string= (get-option '$xy_file) ""))
3538                      (format cmdstorage
3539                              "set print \"~a\" append~%bind x \"print MOUSE_X,MOUSE_Y\"~%"
3540                              (get-option '$xy_file))) )
3541
3542             ; in svg and pdfcairo terminals it is necessary to unset output to force
3543	     ; Gnuplot to write the last few bytes ("</svg>" in the svg case)
3544	     ; at the end of the file. On windows in all other terminals that write
3545	     ; to files if the output isn't unset the file isn't closed and therefore
3546	     ; cannot be moved or removed after a plot is finished.
3547	     ;
3548	     ; If the plot isn't written to a file the variable "output" is empty and
3549	     ; unused and unsetting it a second time doesn't change anything
3550	     ; => It is always save to unset the output at the end of a scene.
3551             (when (not *multiplot-is-active*) ; not in a one window multiplot
3552                 (format cmdstorage "unset output~%"))
3553             (close cmdstorage)
3554             ; get the plot
3555             (cond
3556                ; connect to gnuplot via pipes
3557                ((and (member (get-option '$terminal) '($screen $aquaterm $wxt $x11 $qt $windows))
3558                      (equal $draw_renderer '$gnuplot_pipes))
3559                   (check-gnuplot-process)
3560                   (when (not *multiplot-is-active*) ; not in a one window multiplot
3561                     (send-gnuplot-command "unset output"))
3562                   (send-gnuplot-command "reset")
3563                   (send-gnuplot-command
3564                        (format nil "load '~a'" gfn)))
3565                ; call gnuplot via system command
3566                (t
3567
3568		 #+(or (and sbcl win32) (and sbcl win64) (and ccl windows))
3569		 (if (member (get-option '$terminal) '($screen $aquaterm $wxt $x11 $qt $windows))
3570		     ($system $gnuplot_command "-persist" gfn)
3571		     ($system $gnuplot_command gfn))
3572		 #-(or (and sbcl win32) (and sbcl win64) (and ccl windows))
3573		 ($system (if (member (get-option '$terminal) '($screen $aquaterm $wxt $x11 $qt $windows))
3574			      (format nil "~a ~a"
3575				      $gnuplot_command
3576				      (format nil $gnuplot_view_args gfn))
3577			      (format nil "~a \"~a\""
3578				      $gnuplot_command
3579				      gfn))) ))))
3580
3581    ; the output is a simplified description of the scene(s)
3582    (reverse scenes-list)) )
3583
3584
3585;; This function transforms an integer number into
3586;; a string, adding zeros at the left side until the
3587;; length of the string equals 10. This function is
3588;; useful to name a sequence of frames.
3589(defun $add_zeroes (num)
3590   (format nil "~10,'0d" ($sconcat num)) )
3591
3592
3593;; copies current plot in window into a file
3594(defun $draw_file (&rest opts)
3595 (let (str)
3596   (dolist (x opts)
3597      (if (equal ($op x) "=")
3598         (update-gr-option ($lhs x) ($rhs x))
3599         (merror "draw: item ~M is not recognized as an option assignment" x)))
3600   (case (get-option '$terminal)
3601      ($canvas (setf str (format nil "set terminal canvas enhanced ~a size ~a, ~a~%set out '~a.html'"
3602				 (write-font-type)
3603				 (round (first (get-option '$dimensions)))
3604				 (round (second (get-option '$dimensions)))
3605				 (get-option '$file_name))))
3606      ($png (setf str (format nil "set terminal png enhanced truecolor ~a size ~a, ~a~%set out '~a.png'"
3607                           (write-font-type)
3608                           (round (first (get-option '$dimensions)))
3609                           (round (second (get-option '$dimensions)))
3610                           (get-option '$file_name) ) ))
3611      ($pngcairo (setf str (format nil "set terminal pngcairo dashed enhanced truecolor ~a size ~a, ~a~%set out '~a.png'"
3612                           (write-font-type)
3613                           (round (first (get-option '$dimensions)))
3614                           (round (second (get-option '$dimensions)))
3615                           (get-option '$file_name) ) ))
3616      ($eps (setf str (format nil "set terminal postscript dashed eps enhanced ~a size ~acm, ~acm~%set out '~a.eps'"
3617                           (write-font-type) ; other alternatives are Arial, Courier
3618                           (/ (first (get-option '$dimensions)) 100.0)
3619                           (/ (second (get-option '$dimensions)) 100.0)
3620                           (get-option '$file_name))))
3621      ($epslatex (format str "set terminal epslatex ~a color dashed size ~acm, ~acm~%set out '~a.tex'"
3622                           (write-font-type)
3623                           (/ (first (get-option '$dimensions)) 100.0)
3624                           (/ (second (get-option '$dimensions)) 100.0)
3625                           (get-option '$file_name)))
3626      ($epslatex_standalone (format str "set terminal epslatex dashed standalone ~a color size ~acm, ~acm~%set out '~a.tex'"
3627                           (write-font-type)
3628                           (/ (first (get-option '$dimensions)) 100.0)
3629                           (/ (second (get-option '$dimensions)) 100.0)
3630                           (get-option '$file_name)))
3631      ($eps_color (setf str (format nil "set terminal postscript dashed eps enhanced ~a color size ~acm, ~acm~%set out '~a.eps'"
3632                           (write-font-type)
3633                           (/ (first (get-option '$dimensions)) 100.0)
3634                           (/ (second (get-option '$dimensions)) 100.0)
3635                           (get-option '$file_name))))
3636      ($pdf (setf str (format nil "set terminal pdf dashed enhanced ~a color size ~acm, ~acm~%set out '~a.pdf'"
3637                           (write-font-type)
3638                           (/ (first (get-option '$dimensions)) 100.0)
3639                           (/ (second (get-option '$dimensions)) 100.0)
3640                           (get-option '$file_name))))
3641      ($pdfcairo (setf str (format nil "set terminal pdfcairo dashed enhanced ~a color size ~acm, ~acm~%set out '~a.pdf'"
3642                           (write-font-type)
3643                           (/ (first (get-option '$dimensions)) 100.0)
3644                           (/ (second (get-option '$dimensions)) 100.0)
3645                           (get-option '$file_name))))
3646      ($jpg (setf str (format nil "set terminal jpeg ~a size ~a, ~a~%set out '~a.jpg'"
3647                           (write-font-type)
3648                           (round (first (get-option '$dimensions)))
3649                           (round (second (get-option '$dimensions)))
3650                           (get-option '$file_name))))
3651      ($gif (setf str (format nil "set terminal gif ~a size ~a, ~a~%set out '~a.gif'"
3652                           (write-font-type)
3653                           (round (first (get-option '$dimensions)))
3654                           (round (second (get-option '$dimensions)))
3655                           (get-option '$file_name))))
3656      ($svg (setf str (format nil "set terminal svg dashed enhanced ~a size ~a, ~a~%set out '~a.svg'"
3657			   (write-font-type)
3658                           (round (first (get-option '$dimensions)))
3659                           (round (second (get-option '$dimensions)))
3660                           (get-option '$file_name))))
3661      (otherwise (merror "draw: not a file format")))
3662   (send-gnuplot-command (format nil "~a~%replot~%unset output~%" str)) ))
3663
3664
3665;; When working with multiple windows, for example
3666;; terminal = [wxt, 5], only the newest window is active.
3667;; This function activates any other previous window at will.
3668(defun $activate_window (term num)
3669   (when (or (not (member term '($screen $wxt $aquaterm)))
3670             (not (integerp num))
3671             (< num 0) )
3672      (merror "draw: Incorrect terminal or window number"))
3673   (let (str)
3674      (case term
3675         ($wxt      (setf str "wxt"))
3676         ($aquaterm (setf str "aquaterm"))
3677         ($qt       (setf str "qt"))
3678         (otherwise (setf str "x11")))
3679      (send-gnuplot-command (format nil "set terminal ~a ~a~%" str num))   ))
3680
3681
3682