3 ;;; Copyright (C) 2007-2016 Mario Rodriguez Riotorto
4 ;;; Time-stamp: "2022-03-25 12:13:47 villate"
6 ;;; This program is free software; you can redistribute
7 ;;; it and/or modify it under the terms of the
8 ;;; GNU General Public License as published by
9 ;;; the Free Software Foundation; either version 2
10 ;;; of the License, or (at your option) any later version.
12 ;;; This program is distributed in the hope that it
13 ;;; will be useful, but WITHOUT ANY WARRANTY;
14 ;;; without even the implied warranty of MERCHANTABILITY
15 ;;; or FITNESS FOR A PARTICULAR PURPOSE. See the
16 ;;; GNU General Public License for more details at
17 ;;; http://www.gnu.org/copyleft/gpl.html
19 ;;; This is a maxima-gnuplot interface.
22 ;;; http://tecnostats.net/Maxima/gnuplot
25 ;;; For questions, suggestions, bugs and the like, feel free
27 ;;; riotorto @@@ yahoo DOT com
30 ;; use $draw_version to save package version
31 ;; and to know whether the package was loaded
32 ($put
'$gnuplot
1 '$version
); to be removed in the future
33 (defvar $draw_version
2)
36 (defun write-font-type ()
37 (if (and (string= (get-option '$font
) "") (not (eql (get-option '$font_size
) 10)))
38 (mwarning "Cannot set the gnuplot font size without a font name."))
40 (if (or (eq (get-option '$font
) nil
) (string= (get-option '$font
) ""))
42 (format nil
"font '~a,~a'" (get-option '$font
) (get-option '$font_size
))))
45 ;; one-window multiplot: consecutive calls
46 ;; to draw allways plot on the same window
47 (defvar *multiplot-is-active
* nil
)
48 (defun $multiplot_mode
(term)
51 ($multiplot_mode
'$none
)
53 (format nil
"set terminal GNUTERM dashed ~a~%set multiplot~%" (write-font-type)))
54 (setf *multiplot-is-active
* t
))
56 ($multiplot_mode
'$none
)
58 (format nil
"set terminal wxt dashed ~a~%set multiplot~%" (write-font-type)))
59 (setf *multiplot-is-active
* t
))
61 ($multiplot_mode
'$none
)
63 (format nil
"set terminal qt dashed ~a~%set multiplot~%" (write-font-type)))
64 (setf *multiplot-is-active
* t
))
66 ($multiplot_mode
'$none
)
68 (format nil
"set terminal windows dashed ~a~%set multiplot~%" (write-font-type)))
69 (setf *multiplot-is-active
* t
))
72 (format nil
"unset multiplot~%unset output~%"))
73 (setf *multiplot-is-active
* nil
))
75 (merror "draw: ~M is not recognized as a multiplot mode" term
))))
79 ;; This function is called from the graphic objects constructors
80 ;; (points, rectangle, etc.). When a new object is created, and if
81 ;; the user hasn't especified an x or y range, ranges are computed
82 ;; automaticallly by calling this function. There is a trick so
83 ;; that object constructors know if they can modify global variables
84 ;; xrange and yrange; if these lists are of length 2, it means that
85 ;; it was a user selection and they can't be altered; if they are of
86 ;; length 3 (with a dummy 0), object constructors should make the necessary changes
87 ;; to fit the objects in the window; if they are nil, default
88 ;; value, constructors are also allowed to make changes.
89 (defmacro update-range
(axi vmin vmax
)
90 `(case (length (get-option ,axi
))
91 (0 (setf (gethash ,axi
*gr-options
*) (list ,vmin
,vmax
0)))
92 (3 (setf (gethash ,axi
*gr-options
*) (list (min ,vmin
(first (get-option ,axi
)))
93 (max ,vmax
(second (get-option ,axi
)))
96 (defun update-ranges-2d (xmin xmax ymin ymax
)
97 (if (get-option '$xaxis_secondary
)
98 (update-range '$xrange_secondary xmin xmax
)
99 (update-range '$xrange xmin xmax
))
100 (if (get-option '$yaxis_secondary
)
101 (update-range '$yrange_secondary ymin ymax
)
102 (update-range '$yrange ymin ymax
)) )
104 (defun update-ranges-3d (xmin xmax ymin ymax zmin zmax
)
105 (update-ranges-2d xmin xmax ymin ymax
)
106 (update-range '$zrange zmin zmax
))
108 (defmacro check-extremes-x
()
110 (when (< xx xmin
) (setf xmin xx
))
111 (when (> xx xmax
) (setf xmax xx
))))
113 (defmacro check-extremes-y
()
115 (when (< yy ymin
) (setf ymin yy
))
116 (when (> yy ymax
) (setf ymax yy
))))
118 (defmacro check-extremes-z
()
120 (when (< zz zmin
) (setf zmin zz
))
121 (when (> zz zmax
) (setf zmax zz
))))
123 ;; Controls whether the actual graphics object must
124 ;; be plotted against the primary or the secondary axes,
125 ;; both horizontal and vertical. Secondary axes in 3D
126 ;; are not yet supported.
127 (defun axes-to-plot ()
129 (if (get-option '$xaxis_secondary
)
132 (if (get-option '$yaxis_secondary
)
137 name command groups points
)
139 (defun make-obj-title (str)
140 (if (= (length str
) 0)
142 (if (> (length str
) 80)
143 (concatenate 'string
"t '" (subseq str
0 75) " ...'")
144 (concatenate 'string
"t '" str
"'"))))
152 ;; errors([[x1,y1,...], [x2,y2,...], [x3,y3,...],...])
163 (defun-checked errors
(arg)
164 (let ((etype (get-option '$error_type
))
165 (joined (get-option '$points_joined
))
167 pts pltcmd grouping xmin xmax ymin ymax with
)
168 (if (and ($listp arg
)
169 (every #'$listp
(rest arg
)))
170 (setf element-size
(length (cdadr arg
)))
171 (merror "draw (errors object): incorrect input format"))
172 (unless (every #'(lambda (z) (= element-size
($length z
))) (rest arg
))
173 (merror "draw (errors object): lists of different sizes"))
174 ; create plot command
175 (cond ((and (eql etype
'$x
)
176 (or (= element-size
3)
179 (setf with
"xerrorbars")
180 (setf with
"xerrorlines")) )
181 ((and (eql etype
'$y
)
182 (or (= element-size
3)
185 (setf with
"yerrorbars")
186 (setf with
"yerrorlines")) )
187 ((and (eql etype
'$xy
)
188 (or (= element-size
4)
191 (setf with
"xyerrorbars")
192 (setf with
"xyerrorlines")) )
193 ((and (eql etype
'$boxes
)
194 (or (= element-size
4)
196 (setf with
"boxxyerrorbars") )
198 (merror "draw (errors object): incompatibility with option error_type")))
200 (setf grouping
`((,element-size
0)))
203 " ~a w ~a ~a lw ~a lt ~a lc ~a axis ~a"
204 (make-obj-title (get-option '$key
))
206 (if (eql etype
'$boxes
) ; in case of boxes, should they be filled?
207 (format nil
"fs solid ~a"
208 (get-option '$fill_density
))
210 (get-option '$line_width
)
211 (get-option '$line_type
)
212 (hex-to-rgb (get-option '$color
))
214 (setf pts
(map 'list
#'rest
(rest ($float arg
))))
215 (let ((x (map 'list
#'first pts
))
216 (y (map 'list
#'second pts
)))
217 (setf xmin
($tree_reduce
'min
(cons '(mlist simp
) x
))
218 xmax
($tree_reduce
'max
(cons '(mlist simp
) x
))
219 ymin
($tree_reduce
'min
(cons '(mlist simp
) y
))
220 ymax
($tree_reduce
'max
(cons '(mlist simp
) y
))))
221 (update-ranges-2d xmin xmax ymin ymax
)
226 :points
(list (make-array (* element-size
(length pts
))
227 :element-type
'flonum
228 :initial-contents
(flatten pts
)))) ))
237 ;; points([[x1,y1], [x2,y2], [x3,y3],...])
238 ;; points([x1,x2,x3,...], [y1,y2,y3,...])
239 ;; points([y1,y2,y3,...]), abscissas are automatically chosen: 1,2,3,...
240 ;; points(matrix), one-column, one-row, two-column or two-row matrix
242 ;; points(array1d, array1d)
243 ;; points(array2d), two-column or two-row array
255 (defun points-command ()
256 (let ((pj (get-option '$points_joined
))
257 (ps (get-option '$point_size
))
258 (pt (get-option '$point_type
)) )
260 ((null pj
) ; draws isolated points
261 (format nil
" ~a w p ps ~a pt ~a lc ~a axis ~a"
262 (make-obj-title (get-option '$key
))
265 (hex-to-rgb (get-option '$color
))
267 ((and (eq pj t
) (or (= ps
0.0) (= pt
0)) ) ; draws joined points without symbols
268 (format nil
" ~a w l lw ~a lt ~a lc ~a axis ~a"
269 (make-obj-title (get-option '$key
))
270 (get-option '$line_width
)
271 (get-option '$line_type
)
272 (hex-to-rgb (get-option '$color
))
274 ((eq pj t
) ; draws joined points
275 (format nil
" ~a w lp ps ~a pt ~a lw ~a lt ~a lc ~a axis ~a"
276 (make-obj-title (get-option '$key
))
279 (get-option '$line_width
)
280 (get-option '$line_type
)
281 (hex-to-rgb (get-option '$color
))
284 (format nil
" ~a w i lw ~a lt ~a lc ~a axis ~a"
285 (make-obj-title (get-option '$key
))
286 (get-option '$line_width
)
288 (hex-to-rgb (get-option '$color
))
291 (defun points-array-2d (arg)
292 (let ((xmin most-positive-double-float
)
293 (xmax most-negative-double-float
)
294 (ymin most-positive-double-float
)
295 (ymax most-negative-double-float
)
297 (dim (array-dimensions arg
))
298 n xx yy pts twocolumns
)
300 ((and (= (length dim
) 2) ; two-column array
304 ((and (= (length dim
) 2) ; two-row array
307 (setf twocolumns nil
))
308 (t (merror "draw (points2d): bad 2d array input format")))
309 (setf pts
(make-array (* 2 n
) :element-type
'flonum
))
310 (loop for k below n do
312 (setf xx
($float
(aref arg k
0))
313 yy
($float
(aref arg k
1)))
314 (setf xx
($float
(aref arg
0 k
))
315 yy
($float
(aref arg
1 k
))))
319 (setf (aref pts
(incf pos
)) xx
)
320 (setf (aref pts
(incf pos
)) yy
))
321 (update-ranges-2d xmin xmax ymin ymax
)
324 :command
(points-command)
325 :groups
'((2 0)) ; numbers are sent to gnuplot in groups of 2
326 :points
(list pts
))))
328 (defun points-array-1d (arg1 &optional
(arg2 nil
))
329 (let ((xmin most-positive-double-float
)
330 (xmax most-negative-double-float
)
331 (ymin most-positive-double-float
)
332 (ymax most-negative-double-float
)
334 (dim (array-dimensions arg1
))
338 (= (length dim
) 1)) ; y format
340 (setf x
(make-array n
341 :element-type
'flonum
342 :initial-contents
(loop for k from
1 to n collect
($float k
)) ))
343 (setf y
(make-array n
344 :element-type
'flonum
345 :initial-contents
(loop for k below n collect
($float
(aref arg1 k
))))))
346 ((and (arrayp arg2
) ; xx yy format
348 (equal dim
(array-dimensions arg2
)))
352 (t (merror "draw (points2d): bad 1d array input format")))
353 (setf pts
(make-array (* 2 n
) :element-type
'flonum
))
354 (loop for k below n do
355 (setf xx
($float
(aref x k
))
356 yy
($float
(aref y k
)))
360 (setf (aref pts
(incf pos
)) xx
)
361 (setf (aref pts
(incf pos
)) yy
))
362 (update-ranges-2d xmin xmax ymin ymax
)
365 :command
(points-command)
366 :groups
'((2 0)) ; numbers are sent to gnuplot in groups of 2
367 :points
(list pts
))))
369 (defun points-list (arg1 &optional
(arg2 nil
))
370 (let (x y xmin xmax ymin ymax pts
)
374 (every #'$listp
(rest arg1
))) ; xy format
375 (let ((tmp (mapcar #'rest
(rest arg1
))))
376 (setf x
(map 'list
#'$float
(map 'list
#'first tmp
))
377 y
(map 'list
#'$float
(map 'list
#'second tmp
)))) )
378 ((and ($matrixp arg1
)
379 (= (length (cadr arg1
)) 3)
380 (null arg2
)) ; two-column matrix
381 (let ((tmp (mapcar #'rest
(rest arg1
))))
382 (setf x
(map 'list
#'$float
(map 'list
#'first tmp
))
383 y
(map 'list
#'$float
(map 'list
#'second tmp
)) ) ) )
386 (notany #'$listp
(rest arg1
))) ; y format
387 (setf x
(loop for xx from
1 to
(length (rest arg1
)) collect
($float xx
))
388 y
(map 'list
#'$float
(rest arg1
))))
389 ((and ($matrixp arg1
)
390 (= (length (cadr arg1
)) 2)
391 (null arg2
)) ; one-column matrix
392 (setf x
(loop for xx from
1 to
(length (rest arg1
)) collect
($float xx
))
393 y
(map 'list
#'$float
(map 'list
#'second
(rest arg1
)))))
394 ((and ($matrixp arg1
)
396 (null arg2
)) ; one-row matrix
397 (setf x
(loop for xx from
1 to
(length (cdadr arg1
)) collect
($float xx
))
398 y
(map 'list
#'$float
(cdadr arg1
))))
401 (= (length arg1
) (length arg2
))) ; xx yy format
402 (setf x
(map 'list
#'$float
(rest arg1
))
403 y
(map 'list
#'$float
(rest arg2
))))
404 ((and ($matrixp arg1
)
406 (null arg2
)) ; two-row matrix
407 (setf x
(map 'list
#'$float
(cdadr arg1
))
408 y
(map 'list
#'$float
(cdaddr arg1
))))
409 (t (merror "draw (points2d): incorrect input format")))
411 (setf xmin
($tree_reduce
'min
(cons '(mlist simp
) x
))
412 xmax
($tree_reduce
'max
(cons '(mlist simp
) x
))
413 ymin
($tree_reduce
'min
(cons '(mlist simp
) y
))
414 ymax
($tree_reduce
'max
(cons '(mlist simp
) y
)) )
415 (setf pts
(make-array (* 2 (length x
)) :element-type
'flonum
416 :initial-contents
(mapcan #'list x y
)))
417 ;; update x-y ranges if necessary
418 (update-ranges-2d xmin xmax ymin ymax
)
421 :command
(points-command)
422 :groups
'((2 0)) ; numbers are sent to gnuplot in groups of 2
423 :points
(list pts
) ) ))
425 (defun-checked points
(arg1 &optional
(arg2 nil
))
427 (if (= (length (array-dimensions arg1
)) 2)
428 (points-array-2d arg1
)
429 (points-array-1d arg1 arg2
))
430 (points-list arg1 arg2
)))
438 ;; Object: 'points3d'
440 ;; points([[x1,y1,z1], [x2,y2,z2], [x3,y3,z3],...])
441 ;; points([x1,x2,x3,...], [y1,y2,y3,...], [z1,z2,z3,...])
442 ;; points(matrix), three-column or three-row matrix
443 ;; points(array2d), three-column or three-row array
444 ;; points(array1d, array1d, array1d, array1d)
455 (defun points3d-command ()
456 (let ((pj (get-option '$points_joined
))
457 (ps (get-option '$point_size
))
458 (pt (get-option '$point_type
))
459 (pal (if (> *draw-enhanced3d-type
* 0)
461 (hex-to-rgb (get-option '$color
)) )))
463 ((null pj
) ; draws isolated points
464 (format nil
" ~a w p ps ~a pt ~a lc ~a"
465 (make-obj-title (get-option '$key
))
469 ((and (eq pj t
) (or (= ps
0.0) (= pt
0)) ) ; draws joined points without symbols
470 (format nil
" ~a w l lw ~a lt ~a lc ~a "
471 (make-obj-title (get-option '$key
))
472 (get-option '$line_width
)
473 (get-option '$line_type
)
474 (hex-to-rgb (get-option '$color
))))
475 ((eq pj t
) ; draws joined points
476 (format nil
" ~a w lp ps ~a pt ~a lw ~a lt ~a lc ~a"
477 (make-obj-title (get-option '$key
))
480 (get-option '$line_width
)
481 (get-option '$line_type
)
484 (format nil
" ~a w i lw ~a lt ~a lc ~a"
485 (make-obj-title (get-option '$key
))
486 (get-option '$line_width
)
487 (get-option '$line_type
)
490 (defun-checked points3d
(arg1 &optional
(arg2 nil
) (arg3 nil
))
491 (let (pts x y z xmin xmax ymin ymax zmin zmax ncols col
)
492 (check-enhanced3d-model "points" '(0 1 3))
493 (cond (($listp arg1
) ; list input
494 (cond ((and (every #'$listp
(rest arg1
)) ; xyz format
497 (let ((tmp (mapcar #'rest
(rest arg1
))))
498 (setf x
(map 'list
#'$float
(map 'list
#'first tmp
))
499 y
(map 'list
#'$float
(map 'list
#'second tmp
))
500 z
(map 'list
#'$float
(map 'list
#'third tmp
)) ) ) )
501 ((and ($listp arg2
) ; xx yy zz format
503 (= (length arg1
) (length arg2
) (length arg3
)))
504 (setf x
(map 'list
#'$float
(rest arg1
))
505 y
(map 'list
#'$float
(rest arg2
))
506 z
(map 'list
#'$float
(rest arg3
)) ))
507 (t (merror "draw (points3d): bad list input format"))))
508 (($matrixp arg1
) ; matrix input
509 (cond ((and (= (length (cadr arg1
)) 4) ; three-column matrix
512 (let ((tmp (mapcar #'rest
(rest arg1
))))
513 (setf x
(map 'list
#'$float
(map 'list
#'first tmp
))
514 y
(map 'list
#'$float
(map 'list
#'second tmp
))
515 z
(map 'list
#'$float
(map 'list
#'third tmp
)) ) ) )
516 ((and (= ($length arg1
) 3) ; three-row matrix
519 (setf x
(map 'list
#'$float
(cdadr arg1
))
520 y
(map 'list
#'$float
(cdaddr arg1
))
521 z
(map 'list
#'$float
(cdaddr (rest arg1
)) ) ) )
522 (t (merror "draw (points3d): bad matrix input format"))))
523 ((arrayp arg1
) ; array input
524 (let ((dim (array-dimensions arg1
)))
525 (cond ((and (= (length dim
) 2) ; three-row array
529 (setf x
(loop for k from
0 below
(second dim
)
530 collect
($float
(aref arg1
0 k
)))
531 y
(loop for k from
0 below
(second dim
)
532 collect
($float
(aref arg1
1 k
)))
533 z
(loop for k from
0 below
(second dim
)
534 collect
($float
(aref arg1
2 k
))) ))
535 ((and (= (length dim
) 2) ; three-column array
539 (setf x
(loop for k from
0 below
(first dim
)
540 collect
($float
(aref arg1 k
0)))
541 y
(loop for k from
0 below
(first dim
)
542 collect
($float
(aref arg1 k
1)))
543 z
(loop for k from
0 below
(first dim
)
544 collect
($float
(aref arg1 k
2))) ))
545 ((and (= (length dim
) 1) ; three 1d arrays
548 (equal dim
(array-dimensions arg2
))
549 (equal dim
(array-dimensions arg3
)))
550 (setf x
(map 'list
#'$float arg1
)
551 y
(map 'list
#'$float arg2
)
552 z
(map 'list
#'$float arg3
) ) )
553 (t (merror "draw (points3d): bad array input format")) ) ) )
554 (t (merror "draw (points3d): bad input format")))
557 (cond ((= *draw-enhanced3d-type
* 0)
559 (setf pts
(make-array (* ncols
(length x
))
560 :element-type
'flonum
561 :initial-contents
(mapcan #'list x y z
))))
562 ((= *draw-enhanced3d-type
* 1)
563 (setf col
(loop for k from
1 to
(length x
)
564 collect
(funcall *draw-enhanced3d-fun
* k
)))
566 (setf pts
(make-array (* ncols
(length x
))
567 :element-type
'flonum
568 :initial-contents
(mapcan #'list x y z col
))))
569 ((= *draw-enhanced3d-type
* 3)
570 (setf col
(mapcar #'(lambda (xx yy zz
) (funcall *draw-enhanced3d-fun
* xx yy zz
)) x y z
))
572 (setf pts
(make-array (* ncols
(length x
))
573 :element-type
'flonum
574 :initial-contents
(mapcan #'list x y z col
)))) )
575 (setf xmin
($tree_reduce
'min
(cons '(mlist simp
) x
))
576 xmax
($tree_reduce
'max
(cons '(mlist simp
) x
))
577 ymin
($tree_reduce
'min
(cons '(mlist simp
) y
))
578 ymax
($tree_reduce
'max
(cons '(mlist simp
) y
))
579 zmin
($tree_reduce
'min
(cons '(mlist simp
) z
))
580 zmax
($tree_reduce
'max
(cons '(mlist simp
) z
)) )
581 ;; update x-y-y ranges if necessary
582 (update-ranges-3d xmin xmax ymin ymax zmin zmax
)
585 :command
(points3d-command)
586 :groups
`((,ncols
0)) ; numbers are sent to gnuplot in groups of 4 or 3
587 ; (depending on colored 4th dimension or not), without blank lines
588 :points
(list pts
) ) ))
597 ;; polygon([[x1,y1], [x2,y2], [x3,y3],...])
598 ;; polygon([x1,x2,x3,...], [y1,y2,y3,...])
610 (defun-checked polygon
(arg1 &optional
(arg2 nil
))
611 (if (and (get-option '$transparent
)
612 (not (get-option '$border
)))
613 (merror "draw (polygon): transparent is true and border is false; this is not consistent"))
614 (let (pltcmd pts grps x y xmin xmax ymin ymax
)
615 (cond ((and ($listp arg1
)
616 (every #'$listp
(rest arg1
))
617 (null arg2
) ) ; xy format
618 (let ((tmp (mapcar #'rest
(rest arg1
))))
619 (setf x
(map 'list
#'(lambda (z) ($float
(first z
))) tmp
)
620 y
(map 'list
#'(lambda (z) ($float
(second z
))) tmp
) ) ) )
623 (= (length arg1
) (length arg2
))) ; xx yy format
624 (setf x
(map 'list
#'$float
(rest arg1
))
625 y
(map 'list
#'$float
(rest arg2
))) )
626 (t (merror "draw (polygon): bad input format")) )
628 (setf xmin
($tree_reduce
'min
(cons '(mlist simp
) x
))
629 xmax
($tree_reduce
'max
(cons '(mlist simp
) x
))
630 ymin
($tree_reduce
'min
(cons '(mlist simp
) y
))
631 ymax
($tree_reduce
'max
(cons '(mlist simp
) y
)) )
632 ;; update x-y ranges if necessary
633 (update-ranges-2d xmin xmax ymin ymax
)
635 ((get-option '$transparent
) ; if transparent, draw only the border
636 (setf pltcmd
(format nil
" ~a w l lw ~a lt ~a lc ~a axis ~a"
637 (make-obj-title (get-option '$key
))
638 (get-option '$line_width
)
639 (get-option '$line_type
)
640 (hex-to-rgb (get-option '$color
))
642 (setf grps
'((2 0))) ; numbers are sent to gnuplot in groups of 2
643 (setf pts
(list (make-array (+ (* 2 (length x
)) 2)
644 :element-type
'flonum
645 :initial-contents
(append (mapcan #'list x y
)
646 (list (first x
) (first y
))) )) ) )
647 ((not (get-option '$border
)) ; no transparent, no border
648 (setf pltcmd
(format nil
" ~a w filledcurves lc ~a axis ~a"
649 (make-obj-title (get-option '$key
))
650 (hex-to-rgb (get-option '$fill_color
))
652 (setf grps
'((2 0))) ; numbers are sent to gnuplot in groups of 2
653 (setf pts
(list (make-array (* 2 (length x
))
654 :element-type
'flonum
655 :initial-contents
(mapcan #'list x y
)) ) ))
656 (t ; no transparent with border
657 (setf pltcmd
(list (format nil
" ~a w filledcurves lc ~a axis ~a"
658 (make-obj-title (get-option '$key
))
659 (hex-to-rgb (get-option '$fill_color
))
661 (format nil
" t '' w l lw ~a lt ~a lc ~a axis ~a"
662 (get-option '$line_width
)
663 (get-option '$line_type
)
664 (hex-to-rgb (get-option '$color
))
666 (setf grps
'((2 0) (2 0))) ; both sets of vertices (interior and border)
667 ; are sent to gnuplot in groups of 2
668 (setf pts
(list (make-array (* 2 (length x
))
669 :element-type
'flonum
670 :initial-contents
(mapcan #'list x y
))
671 (make-array (+ (* 2 (length x
)) 2)
672 :element-type
'flonum
673 :initial-contents
(append (mapcan #'list x y
)
674 (list (first x
) (first y
))))))))
687 ;; Object: 'triangle'
689 ;; triangle([x1,y1], [x2,y2], [x3,y3])
701 (defun-checked triangle
(arg1 arg2 arg3
)
702 (if (or (not ($listp arg1
))
703 (not (= ($length arg1
) 2))
705 (not (= ($length arg2
) 2))
707 (not (= ($length arg3
) 2)))
708 (merror "draw2d (triangle): vertices are not correct"))
709 (let* ((x1 ($float
(cadr arg1
)))
710 (y1 ($float
(caddr arg1
)))
711 (x2 ($float
(cadr arg2
)))
712 (y2 ($float
(caddr arg2
)))
713 (x3 ($float
(cadr arg3
)))
714 (y3 ($float
(caddr arg3
)))
715 (grobj (polygon `((mlist simp
)
716 ((mlist simp
) ,x1
,y1
)
717 ((mlist simp
) ,x2
,y2
)
718 ((mlist simp
) ,x3
,y3
)
719 ((mlist simp
) ,x1
,y1
)))))
720 (setf (gr-object-name grobj
) 'triangle
)
728 ;; Object: 'quadrilateral'
730 ;; quadrilateral([x1,y1], [x2,y2], [x3,y3], [x4,y4])
742 (defun-checked quadrilateral
(arg1 arg2 arg3 arg4
)
743 (if (or (not ($listp arg1
))
744 (not (= ($length arg1
) 2))
746 (not (= ($length arg2
) 2))
748 (not (= ($length arg3
) 2))
750 (not (= ($length arg4
) 2)))
751 (merror "draw2d (quadrilateral): vertices are not correct"))
752 (let* ((x1 ($float
(cadr arg1
)))
753 (y1 ($float
(caddr arg1
)))
754 (x2 ($float
(cadr arg2
)))
755 (y2 ($float
(caddr arg2
)))
756 (x3 ($float
(cadr arg3
)))
757 (y3 ($float
(caddr arg3
)))
758 (x4 ($float
(cadr arg4
)))
759 (y4 ($float
(caddr arg4
)))
760 (grobj (polygon `((mlist simp
)
761 ((mlist simp
) ,x1
,y1
)
762 ((mlist simp
) ,x2
,y2
)
763 ((mlist simp
) ,x3
,y3
)
764 ((mlist simp
) ,x4
,y4
)
765 ((mlist simp
) ,x1
,y1
)))))
766 (setf (gr-object-name grobj
) 'quadrilateral
)
775 ;; Object: 'rectangle'
777 ;; rectangle([x1,y1], [x2,y2]), being [x1,y1] & [x2,y2] opposite vertices
789 (defun-checked rectangle
(arg1 arg2
)
790 (if (or (not ($listp arg1
))
791 (not (= ($length arg1
) 2))
793 (not (= ($length arg2
) 2)))
794 (merror "draw2d (rectangle): vertices are not correct"))
795 (let* ((x1 ($float
(cadr arg1
)))
796 (y1 ($float
(caddr arg1
)))
797 (x2 ($float
(cadr arg2
)))
798 (y2 ($float
(caddr arg2
)))
799 (grobj (polygon `((mlist simp
)
800 ((mlist simp
) ,x1
,y1
)
801 ((mlist simp
) ,x2
,y1
)
802 ((mlist simp
) ,x2
,y2
)
803 ((mlist simp
) ,x1
,y2
)
804 ((mlist simp
) ,x1
,y1
)))))
805 (setf (gr-object-name grobj
) 'rectangle
)
816 ;; ellipse(xc, yc, a, b, ang1 ang2)
829 (defun-checked ellipse
(xc yc a b ang1 ang2
)
830 (if (and (get-option '$transparent
)
831 (not (get-option '$border
)))
832 (merror "draw2d (ellipse): transparent is true and border is false; this is not consistent"))
833 (let ((fxc ($float xc
))
837 (fang1 ($float ang1
))
838 (fang2 ($float ang2
))
839 (nticks (get-option '$nticks
))
840 (xmin most-positive-double-float
)
841 (xmax most-negative-double-float
)
842 (ymin most-positive-double-float
)
843 (ymax most-negative-double-float
)
845 pts grps tmin tmax eps xx yy tt pltcmd
)
846 (when (or (notevery #'floatp
(list fxc fyc fa fb fang1 fang2
))
849 (merror "draw (ellipse): illegal argument(s)"))
851 (setf fang1
(* 0.017453292519943295 fang1
)
852 fang2
(* 0.017453292519943295 fang2
))
853 (setf tmin
(min fang1
(+ fang1 fang2
))
854 tmax
(max fang1
(+ fang1 fang2
))
855 eps
(/ (- tmax tmin
) (- nticks
1)))
858 (setf xx
(+ fxc
(* fa
(cos tt
))))
859 (setf yy
(+ fyc
(* fb
(sin tt
))))
863 (setf result
(append (list xx yy
) result
))
864 (if (>= tt tmax
) (return))
866 (if (>= tt tmax
) (setq tt tmax
)) )
867 (when (> *draw-transform-dimensions
* 0)
870 (setf fxc
(funcall *draw-transform-f1
* xold yold
)
871 fyc
(funcall *draw-transform-f2
* xold yold
))) )
872 ; update x-y ranges if necessary
873 (setf xmin
(min fxc xmin
)
877 (update-ranges-2d xmin xmax ymin ymax
)
879 ((get-option '$transparent
) ; if transparent, draw only the border
880 (setf pltcmd
(format nil
" ~a w l lw ~a lt ~a lc ~a axis ~a"
881 (make-obj-title (get-option '$key
))
882 (get-option '$line_width
)
883 (get-option '$line_type
)
884 (hex-to-rgb (get-option '$color
))
887 (setf pts
`( ,(make-array (length result
) :element-type
'flonum
888 :initial-contents result
))) )
889 ((not (get-option '$border
)) ; no transparent, no border
890 (setf pltcmd
(format nil
" ~a w filledcurves xy=~a,~a lc ~a axis ~a"
891 (make-obj-title (get-option '$key
))
893 (hex-to-rgb (get-option '$fill_color
))
896 (setf pts
`( ,(make-array (length result
) :element-type
'flonum
897 :initial-contents result
))) )
898 (t ; no transparent with border
899 (setf pltcmd
(list (format nil
" ~a w filledcurves xy=~a,~a lc ~a axis ~a"
900 (make-obj-title (get-option '$key
))
902 (hex-to-rgb (get-option '$fill_color
))
904 (format nil
" t '' w l lw ~a lt ~a lc ~a axis ~a"
905 (get-option '$line_width
)
906 (get-option '$line_type
)
907 (hex-to-rgb (get-option '$color
))
909 (setf grps
'((2 0) (2 0)))
910 (setf pts
(list (make-array (length result
) :element-type
'flonum
911 :initial-contents result
)
912 (make-array (length result
) :element-type
'flonum
913 :initial-contents result
))) ))
929 ;; label([string1,xx1,y1],[string2,xx2,y2],...)
931 ;; label([string1,x1,y1,z1],[string2,x2,y2,z2],...)
939 (defun replace-substring (string part replacement
)
940 (with-output-to-string (out)
941 (loop with part-length
= (length part
)
942 for old-pos
= 0 then
(+ pos part-length
)
943 for pos
= (search part string
946 do
(write-string string out
948 :end
(or pos
(length string
)))
949 when pos do
(write-string replacement out
)
952 (defun-checked label
(&rest lab
)
953 (let ((n (length lab
))
957 (merror "draw (label): no arguments in object labels"))
958 ((every #'$listp lab
)
959 (cond ((every #'(lambda (z) (= 3 ($length z
))) lab
) ; labels in 2d
961 ((every #'(lambda (z) (= 4 ($length z
))) lab
) ; labels in 3d
964 (merror "draw (label): arguments of not equal length")))
968 (setf xx
($float
($second k
))
969 yy
($float
($third k
))
970 ; backslashes are replaced by double backslashes to allow LaTeX code in labels.
971 text
(format nil
"\"~a\"" (replace-substring ($first k
) "\\" "\\\\")))
972 (if (or (not (floatp xx
))
974 (merror "draw (label): non real 2d coordinates"))
976 (update-ranges-2d xx xx yy yy
)
977 (setf result
(append (list xx yy text
) result
)))))
981 (setf xx
($float
($second k
))
982 yy
($float
($third k
))
983 zz
($float
($fourth k
))
984 text
(format nil
"\"~a\"" ($first k
)) )
985 (if (or (not (floatp xx
))
988 (merror "draw (label): non real 3d coordinates"))
990 (update-ranges-3d xx xx yy yy zz zz
)
991 (setf result
(append (list xx yy zz text
) result
)))))) )
992 (t (merror "draw (label): illegal arguments")))
995 :command
(format nil
" t '' w labels ~a ~a tc ~a ~a"
996 (case (get-option '$label_alignment
)
1000 (case (get-option '$label_orientation
)
1001 ($horizontal
"norotate")
1002 ($vertical
"rotate"))
1003 (hex-to-rgb (get-option '$color
))
1005 (format nil
"axis ~a" (axes-to-plot))
1007 :groups
(if is2d
'((3 0)) '((4 0)))
1008 :points
(list (make-array (length result
) :initial-contents result
))) ))
1017 ;; bars([x1,h1,w1],[x2,h2,w2],...), x, height and width
1025 (defun-checked bars
(&rest boxes
)
1026 (let ((n (length boxes
))
1028 (xmin most-positive-double-float
)
1029 (xmax most-negative-double-float
)
1030 (ymin most-positive-double-float
)
1031 (ymax most-negative-double-float
)
1034 (merror "draw2d (bars): no arguments in object bars"))
1035 (when (not (every #'(lambda (z) (and ($listp z
) (= 3 ($length z
)))) boxes
))
1036 (merror "draw2d (bars): arguments must be lists of length three"))
1037 (setf result
(make-array (* 3 n
) :element-type
'flonum
))
1039 (setf x
($float
($first k
))
1040 h
($float
($second k
))
1041 w
($float
($third k
)))
1043 (setf (aref result
(incf count
)) x
1044 (aref result
(incf count
)) h
1045 (aref result
(incf count
)) w
)
1046 (setf xmin
(min xmin
(- x w2
))
1047 xmax
(max xmax
(+ x w2
))
1049 ymax
(max ymax h
)) )
1050 (update-ranges-2d xmin xmax ymin ymax
)
1053 :command
(format nil
" ~a w boxes fs solid ~a lw ~a lc ~a axis ~a"
1054 (make-obj-title (get-option '$key
))
1055 (get-option '$fill_density
)
1056 (get-option '$line_width
)
1057 (hex-to-rgb (get-option '$fill_color
))
1059 :groups
'((3 0)) ; numbers are sent to gnuplot in groups of 3, without blank lines
1060 :points
(list (make-array (length result
) :initial-contents result
))) ))
1071 ;; vector([x,y], [dx,dy]), represents vector from [x,y] to [x+dx,y+dy]
1084 (defun-checked vect
(arg1 arg2
)
1085 (if (or (not ($listp arg1
))
1086 (not (= ($length arg1
) 2))
1088 (not (= ($length arg2
) 2)))
1089 (merror "draw (vector): coordinates are not correct"))
1090 (let ((xo ($float
(cadr arg1
)))
1091 (yo ($float
(caddr arg1
)))
1092 (dx ($float
(cadr arg2
)))
1093 (dy ($float
(caddr arg2
)))
1095 (when (and (get-option '$unit_vectors
)
1096 (or (/= dx
0) (/= dy
0)))
1097 (let ((module (sqrt (+ (* dx dx
) (* dy dy
)))))
1098 (setf dx
(/ dx module
)
1099 dy
(/ dy module
) )))
1100 (setf xdx
($float
(+ xo dx
))
1101 ydy
($float
(+ yo dy
)))
1102 ;; apply geometric transformation before plotting
1103 (setf x
(list xo xdx
)
1106 (update-ranges-2d (apply 'min x
) (apply 'max x
) (apply 'min y
) (apply 'max y
))
1109 :command
(format nil
" ~a w vect ~a size ~a, ~a ~a lw ~a lt ~a lc ~a axis ~a"
1110 (make-obj-title (get-option '$key
))
1111 (if (get-option '$head_both
) "heads" "head")
1112 (get-option '$head_length
)
1113 (get-option '$head_angle
)
1114 (case (get-option '$head_type
)
1117 ($nofilled
"nofilled"))
1118 (get-option '$line_width
)
1119 (get-option '$line_type
)
1120 (hex-to-rgb (get-option '$color
))
1123 :points
`(,(make-array 4 :element-type
'flonum
1124 :initial-contents
(list (car x
)
1126 (- (cadr x
) (car x
))
1127 (- (cadr y
) (car y
))))) ) ))
1135 ;; Object: 'vector3d'
1137 ;; vector([x,y,z], [dx,dy,dz]), represents vector from [x,y,z] to [x+dx,y+dy,z+dz]
1148 (defun-checked vect3d
(arg1 arg2
)
1149 (if (or (not ($listp arg1
))
1150 (not (= ($length arg1
) 3))
1152 (not (= ($length arg2
) 3)))
1153 (merror "draw (vector): coordinates are not correct"))
1154 (let ((xo ($float
(cadr arg1
)))
1155 (yo ($float
(caddr arg1
)))
1156 (zo ($float
(cadddr arg1
)))
1157 (dx ($float
(cadr arg2
)))
1158 (dy ($float
(caddr arg2
)))
1159 (dz ($float
(cadddr arg2
)))
1161 (when (and (get-option '$unit_vectors
)
1162 (or (/= dx
0) (/= dy
0) (/= dz
0)))
1163 (let ((module (sqrt (+ (* dx dx
) (* dy dy
) (* dz dz
)))))
1164 (setf dx
(/ dx module
)
1166 dz
(/ dz module
) )))
1167 (setf xdx
($float
(+ xo dx
))
1168 ydy
($float
(+ yo dy
))
1169 zdz
($float
(+ zo dz
)) )
1170 ;; apply geometric transformation before plotting
1171 (setf x
(list xo xdx
)
1175 (update-ranges-3d (apply 'min x
) (apply 'max x
) (apply 'min y
) (apply 'max y
) (apply 'min z
) (apply 'max z
))
1178 :command
(format nil
" ~a w vect ~a size ~a, ~a ~a lw ~a lt ~a lc ~a"
1179 (make-obj-title (get-option '$key
))
1180 (if (get-option '$head_both
) "heads" "head")
1181 (get-option '$head_length
)
1182 (get-option '$head_angle
)
1183 (case (get-option '$head_type
)
1186 ($nofilled
"nofilled"))
1187 (get-option '$line_width
)
1188 (get-option '$line_type
)
1189 (hex-to-rgb (get-option '$color
)) )
1191 :points
`(,(make-array 6 :element-type
'flonum
1192 :initial-contents
(list (car x
)
1195 (- (cadr x
) (car x
))
1196 (- (cadr y
) (car y
))
1197 (- (cadr z
) (car z
))))) ) ))
1206 ;; Object: 'explicit'
1208 ;; explicit(fcn,var,minval,maxval)
1220 (defun-checked explicit
(fcn var minval maxval
)
1221 (let* ((nticks (get-option '$nticks
))
1222 (depth (get-option '$adapt_depth
))
1224 (xmin ($float minval
))
1225 (xmax ($float maxval
))
1226 (x-step (/ (- xmax xmin
) ($float nticks
) 2))
1227 (ymin most-positive-double-float
)
1228 (ymax most-negative-double-float
)
1229 (*plot-realpart
* *plot-realpart
*)
1230 x-samples y-samples yy result pltcmd result-array
)
1232 (merror "draw2d (explicit): illegal range"))
1233 (setq *plot-realpart
* (get-option '$draw_realpart
))
1234 (setq fcn
(coerce-float-fun fcn
`((mlist) ,var
)))
1235 (when (get-option '$logx
)
1236 (setf xmin
(log xmin
))
1237 (setf xmax
(log xmax
))
1238 (setf x-step
(/ (- xmax xmin
) ($float nticks
) 2)))
1240 (let ((y (if (get-option '$logx
)
1241 (funcall fcn
(exp x
))
1243 (if (and (get-option '$logy
)
1247 (merror "draw2d (explicit): logarithm of negative number"))
1249 (dotimes (k (1+ (* 2 nticks
)))
1250 (let ((x (+ xmin
(* k x-step
))))
1252 (push (fun x
) y-samples
)))
1253 (setf x-samples
(nreverse x-samples
))
1254 (setf y-samples
(nreverse y-samples
))
1255 ;; For each region, adaptively plot it.
1256 (do ((x-start x-samples
(cddr x-start
))
1257 (x-mid (cdr x-samples
) (cddr x-mid
))
1258 (x-end (cddr x-samples
) (cddr x-end
))
1259 (y-start y-samples
(cddr y-start
))
1260 (y-mid (cdr y-samples
) (cddr y-mid
))
1261 (y-end (cddr y-samples
) (cddr y-end
)))
1263 ;; The region is x-start to x-end, with mid-point x-mid.
1264 (let ((sublst (adaptive-plot #'fun
(car x-start
) (car x-mid
) (car x-end
)
1265 (car y-start
) (car y-mid
) (car y-end
)
1267 (when (notevery #'(lambda (x) (or (numberp x
) (eq x t
) (eq x nil
))) sublst
)
1268 (let ((items sublst
) (item 'nil
))
1269 ;; Search for the item in sublist that is the undefined variable
1271 (when (not (or (numberp (car items
))
1273 (eq (car items
) nil
)))
1274 (setq item
(car items
)) )
1275 (setq items
(cdr items
)) )
1276 (merror "draw2d (explicit): non defined variable in term: ~M" item
) ) )
1278 (when (not (null result
))
1279 (setf sublst
(cddr sublst
)))
1280 (do ((lst sublst
(cddr lst
)))
1282 (setf result
(cons (if (and (get-option '$logy
) (numberp (second lst
)))
1286 (setf result
(cons (if (and (get-option '$logx
) (numberp (first lst
)))
1291 ; reset x extremes to original values
1292 (when (get-option '$logx
)
1293 (setf xmin
(exp xmin
))
1294 (setf xmax
(exp xmax
)))
1296 (cond ((null (get-option '$filled_func
))
1298 ((> *draw-transform-dimensions
* 0)
1299 ; With geometric transformation.
1300 ; When option filled_func in not nil,
1301 ; geometric transformation is ignored
1302 (setf result-array
(make-array (length result
)))
1303 (setf xmin most-positive-double-float
1304 xmax most-negative-double-float
)
1305 (let (xold yold x y
(count -
1))
1306 (do ((lis result
(cddr lis
)))
1308 (setf xold
(first lis
)
1310 (setf x
(funcall *draw-transform-f1
* xold yold
)
1311 y
(funcall *draw-transform-f2
* xold yold
))
1312 (if (> x xmax
) (setf xmax x
))
1313 (if (< x xmin
) (setf xmin x
))
1314 (if (> y ymax
) (setf ymax y
))
1315 (if (< y ymin
) (setf ymin y
))
1316 (setf (aref result-array
(incf count
)) x
)
1317 (setf (aref result-array
(incf count
)) y
) ) ) )
1319 ; No geometric transformation invoked.
1320 (do ((y (cdr result
) (cddr y
)))
1324 (setf result-array
(make-array (length result
)
1325 :initial-contents result
))))
1326 (update-ranges-2d xmin xmax ymin ymax
)
1327 (setf pltcmd
(format nil
" ~a w l lw ~a lt ~a lc ~a axis ~a"
1328 (make-obj-title (get-option '$key
))
1329 (get-option '$line_width
)
1330 (get-option '$line_type
)
1331 (hex-to-rgb (get-option '$color
))
1336 :groups
'((2 0)) ; numbers are sent to gnuplot in groups of 2
1337 :points
(list result-array
)) )
1338 ((equal (get-option '$filled_func
) t
)
1339 (do ((y (cdr result
) (cddr y
)))
1343 (update-ranges-2d xmin xmax ymin ymax
)
1344 (setf result-array
(make-array (length result
)
1345 :element-type
'flonum
1346 :initial-contents result
))
1347 (setf pltcmd
(format nil
" ~a w filledcurves x1 lc ~a axis ~a"
1348 (make-obj-title (get-option '$key
))
1349 (hex-to-rgb (get-option '$fill_color
))
1354 :groups
'((2 0)) ; numbers are sent to gnuplot in groups of 2
1355 :points
(list result-array
)))
1357 (let (fcn2 yy2
(count -
1))
1358 (setf result-array
(make-array (* (/ (length result
) 2) 3)
1359 :element-type
'flonum
))
1360 (setq fcn2
(coerce-float-fun (get-option '$filled_func
) `((mlist), var
)))
1361 (flet ((fun (x) (funcall fcn2 x
)))
1362 (do ((xx result
(cddr xx
)))
1364 (setf yy
(second xx
)
1365 yy2
(fun (first xx
)))
1366 (setf ymax
(max ymax yy yy2
)
1367 ymin
(min ymin yy yy2
))
1368 (setf (aref result-array
(incf count
)) (first xx
)
1369 (aref result-array
(incf count
)) yy
1370 (aref result-array
(incf count
)) yy2
) ) ))
1371 (update-ranges-2d xmin xmax ymin ymax
)
1372 (setf pltcmd
(format nil
" ~a w filledcurves lc ~a axis ~a"
1373 (make-obj-title (get-option '$key
))
1374 (hex-to-rgb (get-option '$fill_color
))
1379 :groups
'((3 0)) ; numbers are sent to gnuplot in groups of 3
1380 :points
(list result-array
)))) ))
1390 ;; region(ineq,x-var,x-minval,x-maxval,y-var,y-minval,y-maxval)
1396 (defmacro build-polygon
(coord)
1397 (let ((len (1- (length coord
))))
1398 `(push (make-array ,len
:element-type
'flonum
:initial-contents
,coord
) pts
)))
1400 (defun-checked region
(ineq x-var x-minval x-maxval y-var y-minval y-maxval
)
1401 (let* ((nx (get-option '$x_voxel
))
1402 (ny (get-option '$y_voxel
))
1403 (xmin ($float x-minval
))
1404 (xmax ($float x-maxval
))
1405 (ymin ($float y-minval
))
1406 (ymax ($float y-maxval
))
1407 (dx (/ (- xmax xmin
) nx
))
1408 (dy (/ (- ymax ymin
) ny
))
1409 (err (* 0.02 (min dx dy
)))
1410 (xarr (make-array (list (1+ nx
) (1+ ny
)) :element-type
'flonum
))
1411 (yarr (make-array (list (1+ nx
) (1+ ny
)) :element-type
'flonum
))
1412 (barr (make-array (list (1+ nx
) (1+ ny
)) :initial-element nil
:element-type
'boolean
))
1414 pltcmd grouping x y
)
1416 (when (not (subsetp (rest ($listofvars ineq
)) (list x-var y-var
) :test
#'like
))
1417 (merror "draw2d (region): non defined variable"))
1419 ; build 2d arrays: x, y and boolean
1420 (labels ((fun (xx yy
) ; evaluates boolean expression
1425 (list '(mequal) x-var xx
)
1426 (list '(mequal) y-var yy
))
1428 (bipart (xx1 yy1 xx2 yy2
) ; bipartition, (xx1, yy1) => T, (xx2, yy2) => NIL
1429 (let ((xm (* 0.5 (+ xx1 xx2
)))
1430 (ym (* 0.5 (+ yy1 yy2
))))
1432 ((< (+ (* (- xx2 xx1
) (- xx2 xx1
))
1433 (* (- yy2 yy1
) (- yy2 yy1
)))
1437 (bipart xm ym xx2 yy2
))
1439 (bipart xx1 yy1 xm ym
)) )) ))
1441 (loop for i to nx do
1442 (loop for j to ny do
1443 (setf x
(+ xmin
(* i dx
)))
1444 (setf y
(+ ymin
(* j dy
)))
1445 (setf (aref xarr i j
) x
)
1446 (setf (aref yarr i j
) y
)
1447 (setf (aref barr i j
) (fun x y
))))
1448 ; check vertices of rectangles and cuts
1449 (loop for i below nx do
1450 (loop for j below ny do
1451 (let ((x1 (aref xarr i j
)) ; SW point
1452 (y1 (aref yarr i j
))
1453 (b1 (aref barr i j
))
1454 (x2 (aref xarr
(1+ i
) j
)) ; SE point
1455 (y2 (aref yarr
(1+ i
) j
))
1456 (b2 (aref barr
(1+ i
) j
))
1457 (x3 (aref xarr
(1+ i
) (1+ j
))) ; NE point
1458 (y3 (aref yarr
(1+ i
) (1+ j
)))
1459 (b3 (aref barr
(1+ i
) (1+ j
)))
1460 (x4 (aref xarr i
(1+ j
))) ; NW point
1461 (y4 (aref yarr i
(1+ j
)))
1462 (b4 (aref barr i
(1+ j
)))
1463 pa pb pc
) ; pa and pb are frontier points
1465 (cond ((and b1 b2 b3 b4
)
1466 (build-polygon (list x1 y1 x2 y2 x3 y3 x4 y4
)))
1468 (setf pa
(bipart x3 y3 x4 y4
)
1469 pb
(bipart x1 y1 x4 y4
))
1470 (build-polygon (list x1 y1 x2 y2 x3 y3
(first pa
) (second pa
) (first pb
) (second pb
))))
1472 (setf pa
(bipart x2 y2 x3 y3
)
1473 pb
(bipart x4 y4 x3 y3
))
1474 (build-polygon (list x4 y4 x1 y1 x2 y2
(first pa
) (second pa
) (first pb
) (second pb
))))
1476 (setf pa
(bipart x1 y1 x2 y2
)
1477 pb
(bipart x3 y3 x2 y2
))
1478 (build-polygon (list x3 y3 x4 y4 x1 y1
(first pa
) (second pa
) (first pb
) (second pb
))))
1480 (setf pa
(bipart x4 y4 x1 y1
)
1481 pb
(bipart x2 y2 x1 y1
))
1482 (build-polygon (list x2 y2 x3 y3 x4 y4
(first pa
) (second pa
) (first pb
) (second pb
))))
1484 (setf pa
(bipart x3 y3 x4 y4
)
1485 pb
(bipart x2 y2 x1 y1
))
1486 (build-polygon (list x2 y2 x3 y3
(first pa
) (second pa
) (first pb
) (second pb
))))
1488 (setf pa
(bipart x1 y1 x2 y2
)
1489 pb
(bipart x4 y4 x3 y3
))
1490 (build-polygon (list x4 y4 x1 y1
(first pa
) (second pa
) (first pb
) (second pb
))))
1492 (setf pa
(bipart x4 y4 x1 y1
)
1493 pb
(bipart x3 y3 x2 y2
))
1494 (build-polygon (list x3 y3 x4 y4
(first pa
) (second pa
) (first pb
) (second pb
))))
1496 (setf pa
(bipart x2 y2 x3 y3
)
1497 pb
(bipart x1 y1 x4 y4
))
1498 (build-polygon (list x1 y1 x2 y2
(first pa
) (second pa
) (first pb
) (second pb
))))
1500 (setf pa
(bipart x1 y1 x2 y2
)
1501 pb
(bipart x1 y1 x3 y4
)
1502 pc
(bipart x1 y1 x4 y4
))
1503 (build-polygon (list x1 y1
(first pa
) (second pa
) (first pb
) (second pb
)(first pc
) (second pc
))))
1505 (setf pa
(bipart x2 y2 x3 y3
)
1506 pb
(bipart x2 y2 x4 y4
)
1507 pc
(bipart x2 y2 x1 y1
))
1508 (build-polygon (list x2 y2
(first pa
) (second pa
) (first pb
) (second pb
) (first pc
) (second pc
))))
1510 (setf pa
(bipart x3 y3 x4 y4
)
1511 pb
(bipart x3 y3 x1 y1
)
1512 pc
(bipart x3 y3 x2 y2
))
1513 (build-polygon (list x3 y3
(first pa
) (second pa
) (first pb
) (second pb
) (first pc
) (second pc
))))
1515 (setf pa
(bipart x4 y4 x1 y1
)
1516 pb
(bipart x4 y4 x2 y2
)
1517 pc
(bipart x4 y4 x3 y3
))
1518 (build-polygon (list x4 y4
(first pa
) (second pa
) (first pb
) (second pb
) (first pc
) (second pc
)))) )))))
1522 (cons (format nil
" ~a w filledcurves lc ~a axis ~a"
1523 (make-obj-title (get-option '$key
))
1524 (hex-to-rgb (get-option '$fill_color
))
1526 (make-list (- (length pts
) 1)
1527 :initial-element
(format nil
" t '' w filledcurves lc ~a axis ~a"
1528 (hex-to-rgb (get-option '$fill_color
))
1530 (update-ranges-2d xmin xmax ymin ymax
)
1532 (make-list (length pts
)
1533 :initial-element
'(2 0)))
1547 ;; Object: 'implicit'
1549 ;; implicit(fcn,x-var,x-minval,x-maxval,y-var,y-minval,y-maxval)
1559 ;; Note: taken from implicit_plot.lisp
1561 ;; returns elements at odd positions
1562 (defun x-elements (list)
1563 (if (endp list
) list
1564 (list* (first list
) (x-elements (rest (rest list
))))))
1566 ;; returns elements at even positions
1567 (defun y-elements (list)
1568 (x-elements (rest list
)))
1572 (defun contains-zeros (i j sample
)
1573 (not (and (> (* (aref sample i j
) (aref sample
(1+ i
) j
)) 0)
1574 (> (* (aref sample i j
) (aref sample i
(1+ j
) )) 0)
1575 (> (* (aref sample i j
) (aref sample
(1+ i
) (1+ j
) )) 0) )))
1577 (defun sample-data (expr xmin xmax ymin ymax sample grid
)
1578 (let* ((xdelta (/ (- xmax xmin
) ($first grid
)))
1579 (ydelta (/ (- ymax ymin
) ($second grid
)))
1580 (epsilon #+gcl
(float 1/1000000) #-gcl
1e-6))
1581 (do ((x-val xmin
(+ x-val xdelta
))
1583 ((> i
($first grid
)))
1584 (do ((y-val ymin
(+ y-val ydelta
))
1586 ((> j
($second grid
)))
1587 (let ((fun-val (funcall expr x-val y-val
)))
1588 (when (and (not (floatp fun-val
)) (not (eq fun-val t
)))
1589 (merror "draw2d (implicit): non defined variable in condition ~M=0" fun-val
))
1590 (if (or (eq fun-val t
) (>= fun-val epsilon
))
1591 (setf (aref sample i j
) 1)
1592 (setf (aref sample i j
) -
1)))))))
1594 (defun draw-print-segment (points xmin xdelta ymin ydelta
)
1595 (let* ((point1 (car points
)) (point2 (cadr points
))
1596 (x1 (coerce (+ xmin
(/ (* xdelta
(+ (car point1
) (caddr point1
))) 2)) 'flonum
) )
1597 (y1 (coerce (+ ymin
(/ (* ydelta
(+ (cadr point1
) (cadddr point1
))) 2)) 'flonum
) )
1598 (x2 (coerce (+ xmin
(/ (* xdelta
(+ (car point2
) (caddr point2
))) 2)) 'flonum
) )
1599 (y2 (coerce (+ ymin
(/ (* ydelta
(+ (cadr point2
) (cadddr point2
))) 2)) 'flonum
) ))
1600 (setq pts
(nconc (list x1 y1 x2 y2
) pts
))))
1602 (defun draw-print-square (xmin xmax ymin ymax sample grid
)
1603 (let* ((xdelta (/ (- xmax xmin
) ($first grid
)))
1604 (ydelta (/ (- ymax ymin
) ($second grid
))))
1606 ((= i
($first grid
)))
1608 ((= j
($second grid
)))
1609 (if (contains-zeros i j sample
)
1611 (if (< (* (aref sample i j
) (aref sample
(1+ i
) j
)) 0)
1612 (setq points
(cons `(,i
,j
,(1+ i
) ,j
) points
)))
1613 (if (< (* (aref sample
(1+ i
) j
) (aref sample
(1+ i
) (1+ j
))) 0)
1614 (setq points
(cons `(,(1+ i
) ,j
,(1+ i
) ,(1+ j
)) points
)))
1615 (if (< (* (aref sample i
(1+ j
)) (aref sample
(1+ i
) (1+ j
))) 0)
1616 (setq points
(cons `(,i
,(1+ j
) ,(1+ i
) ,(1+ j
)) points
)))
1617 (if (< (* (aref sample i j
) (aref sample i
(1+ j
))) 0)
1618 (setq points
(cons `(,i
,j
,i
,(1+ j
)) points
)))
1619 (draw-print-segment points xmin xdelta ymin ydelta
)) )))))
1621 (defun imp-pl-prepare-factor (expr)
1623 ((or ($numberp expr
) (atom expr
))
1625 ((eq (caar expr
) 'mexpt
)
1630 (defun imp-pl-prepare-expr (expr)
1631 (let ((expr1 ($factor
(m- ($rhs expr
) ($lhs expr
)))))
1632 (cond ((or ($numberp expr
) (atom expr1
)) expr1
)
1633 ((eq (caar expr1
) 'mtimes
)
1634 `((mtimes simp factored
1)
1635 ,@(mapcar #'imp-pl-prepare-factor
(cdr expr1
))))
1636 ((eq (caar expr
) 'mexpt
)
1637 (imp-pl-prepare-factor expr1
))
1641 (defun-checked implicit
(expr x xmin xmax y ymin ymax
)
1642 (let* (($numer t
) ($plot_options $plot_options
)
1644 (expr (m- ($rhs expr
) ($lhs expr
)))
1645 (ip-grid (get-option '$ip_grid
))
1646 (ip-grid-in (get-option '$ip_grid_in
))
1648 (xmin ($float xmin
))
1649 (xmax ($float xmax
))
1650 (ymin ($float ymin
))
1651 (ymax ($float ymax
))
1652 (xdelta (/ (- xmax xmin
) ($first ip-grid
)))
1653 (ydelta (/ (- ymax ymin
) ($second ip-grid
)))
1654 (sample (make-array `(,(1+ ($first ip-grid
))
1655 ,(1+ ($second ip-grid
)))))
1656 (ssample (make-array `(,(1+ ($first ip-grid-in
))
1657 ,(1+ ($second ip-grid-in
))))) )
1659 (setq e
(coerce-float-fun (imp-pl-prepare-expr expr
)
1662 (update-ranges-2d xmin xmax ymin ymax
)
1663 (sample-data e xmin xmax ymin ymax sample ip-grid
)
1665 ((= i
($first ip-grid
)))
1667 ((= j
($second ip-grid
)))
1668 (if (contains-zeros i j sample
)
1669 (let* ((xxmin (+ xmin
(* i xdelta
)))
1670 (xxmax (+ xxmin xdelta
))
1671 (yymin (+ ymin
(* j ydelta
)))
1672 (yymax (+ yymin ydelta
)))
1673 (sample-data e xxmin xxmax yymin yymax
1675 (draw-print-square xxmin xxmax yymin yymax
1676 ssample ip-grid-in
) )) ))
1678 ; geometric transformation
1679 (when (> *draw-transform-dimensions
* 0)
1680 (let ((x (x-elements pts
))
1681 (y (y-elements pts
))
1682 xmin xmax ymin ymax
)
1684 (setf xmin
($tree_reduce
'min
(cons '(mlist simp
) x
))
1685 xmax
($tree_reduce
'max
(cons '(mlist simp
) x
))
1686 ymin
($tree_reduce
'min
(cons '(mlist simp
) y
))
1687 ymax
($tree_reduce
'max
(cons '(mlist simp
) y
)) )
1688 (update-ranges-2d xmin xmax ymin ymax
)
1695 when
(null x
) do
(loop-finish) ))) )
1697 (setf pltcmd
(format nil
" ~a w l lw ~a lt ~a lc ~a axis ~a"
1698 (make-obj-title (get-option '$key
))
1699 (get-option '$line_width
)
1700 (get-option '$line_type
)
1701 (hex-to-rgb (get-option '$color
))
1707 :points
`(,(make-array (length pts
) :element-type
'flonum
1708 :initial-contents pts
)) ) ))
1715 ;; Object: 'implicit3d'
1717 ;; implicit(expr,x,xmin,xmax,y,ymin,ymax,z,zmin,zmax)
1728 ;; Some functions and macros are defined in grcommon.lisp
1729 (defun-checked implicit3d
(expr par1 xmin xmax par2 ymin ymax par3 zmin zmax
)
1730 (let ((xmin ($float xmin
))
1731 (xmax ($float xmax
))
1732 (ymin ($float ymin
))
1733 (ymax ($float ymax
))
1734 (zmin ($float zmin
))
1735 (zmax ($float zmax
))
1738 pltcmd ncols vertices
)
1739 (when (not (subsetp (rest ($listofvars expr
)) (list par1 par2 par3
) :test
#'like
))
1740 (merror "draw3d (implicit): non defined variable"))
1741 (check-enhanced3d-model "implicit" '(0 3 99))
1742 (when (= *draw-enhanced3d-type
* 99)
1743 (update-enhanced3d-expression (list '(mlist) par1 par2 par3
)))
1744 (setf ncols
(if (= *draw-enhanced3d-type
* 0) 3 4))
1746 (setf vertices
(find-triangles expr par1 xmin xmax par2 ymin ymax par3 zmin zmax
))
1747 (when (null vertices
)
1748 (merror "draw3d (implicit): no surface within these ranges"))
1749 (update-ranges-3d xmin xmax ymin ymax zmin zmax
)
1751 (cons (format nil
" ~a w ~a lw ~a lt ~a lc ~a"
1752 (make-obj-title (get-option '$key
))
1753 (if (equal (get-option '$enhanced3d
) '$none
) "l" "pm3d")
1754 (get-option '$line_width
)
1755 (get-option '$line_type
)
1756 (hex-to-rgb (get-option '$color
)))
1757 (make-list (- (/ (length vertices
) 3) 1)
1758 :initial-element
(format nil
" t '' w ~a lw ~a lt ~a lc ~a"
1759 (if (equal (get-option '$enhanced3d
) '$none
) "l" "pm3d")
1760 (get-option '$line_width
)
1761 (get-option '$line_type
)
1762 (hex-to-rgb (get-option '$color
)) ))))
1763 (do ((v vertices
(cdddr v
)))
1766 (3 (push (make-array 12 :element-type
'flonum
1767 :initial-contents
(flatten (list (first v
) (second v
) (first v
) (third v
))))
1770 color1 color2 color3
)
1774 (setf color1
(funcall *draw-enhanced3d-fun
* (car v1
) (cadr v1
) (caddr v1
))
1775 color2
(funcall *draw-enhanced3d-fun
* (car v2
) (cadr v2
) (caddr v2
))
1776 color3
(funcall *draw-enhanced3d-fun
* (car v3
) (cadr v3
) (caddr v3
)) )
1777 (push (make-array 16 :element-type
'flonum
1778 :initial-contents
(flatten (list v1 color1 v2 color2 v1 color1 v3 color3
)))
1794 ;; Object: 'explicit3d'
1796 ;; explicit(fcn,par1,minval1,maxval1,par2,minval2,maxval2)
1808 (defun-checked explicit3d
(fcn par1 minval1 maxval1 par2 minval2 maxval2
)
1809 (let* ((xu_grid (get-option '$xu_grid
))
1810 (yv_grid (get-option '$yv_grid
))
1811 (fminval1 ($float minval1
))
1812 (fminval2 ($float minval2
))
1813 (fmaxval1 ($float maxval1
))
1814 (fmaxval2 ($float maxval2
))
1815 (epsx (/ (- fmaxval1 fminval1
) xu_grid
))
1816 (epsy (/ (- fmaxval2 fminval2
) yv_grid
))
1820 (xmin most-positive-double-float
)
1821 (xmax most-negative-double-float
)
1822 (ymin most-positive-double-float
)
1823 (ymax most-negative-double-float
)
1824 (zmin most-positive-double-float
)
1825 (zmax most-negative-double-float
)
1826 (*plot-realpart
* *plot-realpart
*)
1832 (when (not (subsetp (rest ($listofvars fcn
)) (list par1 par2
) :test
#'like
))
1833 (let ((items (rest ($listofvars fcn
))) (item 'nil
))
1834 ;; Search for the item in sublist that is the undefined variable
1839 (subsetp (list (car items
)) (list par1 par2
) :test
#'like
)
1841 (setq item
(car items
))
1843 (setq items
(cdr items
))
1845 (merror "draw3d (explicit): non defined variable in term ~M" item
)
1848 (setq *plot-realpart
* (get-option '$draw_realpart
))
1849 (check-enhanced3d-model "explicit" '(0 2 3 99))
1850 (when (= *draw-enhanced3d-type
* 99)
1851 (update-enhanced3d-expression (list '(mlist) par1 par2
)))
1852 (setq fcn
(coerce-float-fun fcn
`((mlist) ,par1
,par2
)))
1853 (setf ncols
(if (= *draw-enhanced3d-type
* 0) 3 4))
1854 (setf result
(make-array (* ncols nx ny
)))
1855 (loop for j below ny
1856 initially
(setf vv fminval2
)
1857 do
(setf uu fminval1
)
1858 (loop for i below nx
1862 (setf zz
(funcall fcn xx yy
))
1864 (when (> *draw-transform-dimensions
* 0)
1868 (setf (aref result
(incf count
)) xx
1869 (aref result
(incf count
)) yy
1870 (aref result
(incf count
)) zz
)
1871 ; check texture model
1872 (case *draw-enhanced3d-type
*
1873 ((2 99) (setf (aref result
(incf count
)) (funcall *draw-enhanced3d-fun
* xx yy
)))
1874 (3 (setf (aref result
(incf count
)) (funcall *draw-enhanced3d-fun
* xx yy zz
))) )
1875 (setq uu
(+ uu epsx
)))
1876 (setq vv
(+ vv epsy
)))
1877 (when (> *draw-transform-dimensions
* 0)
1882 (update-ranges-3d fminval1 fmaxval1 fminval2 fmaxval2 zmin zmax
)
1885 :command
(format nil
" ~a w ~a lw ~a lt ~a lc ~a"
1886 (make-obj-title (get-option '$key
))
1887 (if (> *draw-enhanced3d-type
* 0) "pm3d" "l")
1888 (get-option '$line_width
)
1889 (get-option '$line_type
)
1890 (hex-to-rgb (get-option '$color
)))
1891 :groups
`((,ncols
,nx
))
1892 :points
(list result
))))
1901 ;; Object: 'elevation_grid'
1903 ;; elevation_grid(mat,x0,y0,width,height)
1912 (defun-checked elevation_grid
(mat x0 y0 width height
)
1913 (let ( (fx0 ($float x0
))
1915 (fwidth ($float width
))
1916 (fheight ($float height
))
1917 (xmin most-positive-double-float
)
1918 (xmax most-negative-double-float
)
1919 (ymin most-positive-double-float
)
1920 (ymax most-negative-double-float
)
1921 (zmin most-positive-double-float
)
1922 (zmax most-negative-double-float
)
1923 ncols-file result nrows ncols
)
1924 (check-enhanced3d-model "elevation_grid" '(0 2 3))
1925 (cond (($matrixp mat
)
1927 (yi (+ fy0 fheight
))
1933 (setf ncols
(length (cdadr mat
))
1934 nrows
(length (cdr mat
)))
1935 (setf dx
(/ fwidth
(1- ncols
))
1936 dy
(/ fheight
(1- nrows
)))
1937 (setf ncols-file
(if (= *draw-enhanced3d-type
* 0) 3 4))
1938 (setf result
(make-array (* ncols nrows ncols-file
) :element-type
'flonum
))
1939 (loop for row on
(cdr mat
) by
#'cdr do
1941 (loop for col on
(cdar row
) by
#'cdr do
1944 (setf zz
($float
(car col
)))
1946 (when (> *draw-transform-dimensions
* 0)
1950 (setf (aref result
(incf count
)) xx
1951 (aref result
(incf count
)) yy
1952 (aref result
(incf count
)) zz
)
1953 ; check texture model
1954 (case *draw-enhanced3d-type
*
1955 (2 (setf (aref result
(incf count
)) (funcall *draw-enhanced3d-fun
* xx yy
)))
1956 (3 (setf (aref result
(incf count
)) (funcall *draw-enhanced3d-fun
* xx yy zz
))) )
1957 (setf xi
(+ xi dx
)))
1958 (setf yi
(- yi dy
)))))
1960 (merror "draw3d (elevation_grid): Argument not recognized")))
1961 (when (= *draw-transform-dimensions
* 0)
1965 ymax
(+ fy0 fheight
)))
1966 (update-ranges-3d xmin xmax ymin ymax zmin zmax
)
1968 :name
'elevation_grid
1969 :command
(format nil
" ~a w ~a lw ~a lt ~a lc ~a"
1970 (make-obj-title (get-option '$key
))
1971 (if (> *draw-enhanced3d-type
* 0) "pm3d" "l")
1972 (get-option '$line_width
)
1973 (get-option '$line_type
)
1974 (hex-to-rgb (get-option '$color
)))
1975 :groups
`((,ncols-file
,ncols
))
1976 :points
(list result
)) ))
1987 ;; mesh([[x_11,y_11,z_11], ...,[x_1n,y_1n,z_1n]],
1988 ;; [[x_21,y_21,z_21], ...,[x_2n,y_2n,z_2n]],
1990 ;; [[x_m1,y_m1,z_m1], ...,[x_mn,y_mn,z_mn]])
1999 (defun-checked mesh
(&rest row
)
2000 (let (result xx yy zz
2001 (xmin most-positive-double-float
)
2002 (xmax most-negative-double-float
)
2003 (ymin most-positive-double-float
)
2004 (ymax most-negative-double-float
)
2005 (zmin most-positive-double-float
)
2006 (zmax most-negative-double-float
)
2007 m n ncols-file col-num row-num
2010 ; let's see if the user wants to use mesh in the old way,
2011 ; what we now call elevation_grid
2012 ((and (= (length row
) 5)
2013 ($matrixp
(first row
)))
2014 (print "Warning: Seems like you want to draw an elevation_grid object...")
2015 (print " Please, see documentation for object elevation_grid.")
2016 (apply #'elevation_grid row
))
2018 (check-enhanced3d-model "mesh" '(0 2 3))
2019 (when (or (< (length row
) 2)
2020 (not (every #'$listp row
)))
2021 (merror "draw3d (mesh): Arguments must be two or more lists"))
2022 (setf ncols-file
(if (= *draw-enhanced3d-type
* 0) 3 4))
2023 (setf m
(length row
)
2024 n
($length
(first row
)))
2025 (setf result
(make-array (* m n ncols-file
) :element-type
'flonum
))
2030 (dolist (c (rest r
))
2032 (setf xx
($float
($first c
))
2033 yy
($float
($second c
))
2034 zz
($float
($third c
)))
2039 (setf (aref result
(incf count
)) xx
2040 (aref result
(incf count
)) yy
2041 (aref result
(incf count
)) zz
)
2042 ; check texture model
2043 (case *draw-enhanced3d-type
*
2044 (2 (setf (aref result
(incf count
)) (funcall *draw-enhanced3d-fun
* row-num col-num
)))
2045 (3 (setf (aref result
(incf count
)) (funcall *draw-enhanced3d-fun
* xx yy zz
)))) ) )
2046 (update-ranges-3d xmin xmax ymin ymax zmin zmax
)
2049 :command
(format nil
" ~a w ~a lw ~a lt ~a lc ~a"
2050 (make-obj-title (get-option '$key
))
2051 (if (> *draw-enhanced3d-type
* 0) "pm3d" "l")
2052 (get-option '$line_width
)
2053 (get-option '$line_type
)
2054 (hex-to-rgb (get-option '$color
)))
2055 :groups
`((,ncols-file
,n
))
2056 :points
(list result
))))))
2064 ;; Object: 'triangle3d'
2066 ;; triangle([x1,y1,z1], [x2,y2,z2], [x3,y3,z3])
2074 (defun-checked triangle3d
(arg1 arg2 arg3
)
2075 (if (or (not ($listp arg1
))
2076 (not (= ($length arg1
) 3))
2078 (not (= ($length arg2
) 3))
2080 (not (= ($length arg3
) 3)))
2081 (merror "draw3d (triangle): vertices are not correct"))
2082 (let* ((x1 ($float
(cadr arg1
)))
2083 (y1 ($float
(caddr arg1
)))
2084 (z1 ($float
(cadddr arg1
)))
2085 (x2 ($float
(cadr arg2
)))
2086 (y2 ($float
(caddr arg2
)))
2087 (z2 ($float
(cadddr arg2
)))
2088 (x3 ($float
(cadr arg3
)))
2089 (y3 ($float
(caddr arg3
)))
2090 (z3 ($float
(cadddr arg3
)))
2091 (grobj (mesh `((mlist simp
)
2092 ((mlist simp
) ,x1
,y1
,z1
)
2093 ((mlist simp
) ,x1
,y1
,z1
) )
2096 ((mlist simp
) ,x2
,y2
,z2
)
2097 ((mlist simp
) ,x3
,y3
,z3
) ) )))
2098 (setf (gr-object-name grobj
) 'triangle
)
2107 ;; Object: 'quadrilateral3d'
2109 ;; quadrilateral([x1,y1,z1], [x2,y2,z2], [x3,y3,z3], [x4,y4,z4])
2117 (defun-checked quadrilateral3d
(arg1 arg2 arg3 arg4
)
2118 (if (or (not ($listp arg1
))
2119 (not (= ($length arg1
) 3))
2121 (not (= ($length arg2
) 3))
2123 (not (= ($length arg3
) 3))
2125 (not (= ($length arg4
) 3)))
2126 (merror "draw3d (quadrilateral): vertices are not correct"))
2127 (let* ((x1 ($float
(cadr arg1
)))
2128 (y1 ($float
(caddr arg1
)))
2129 (z1 ($float
(cadddr arg1
)))
2130 (x2 ($float
(cadr arg2
)))
2131 (y2 ($float
(caddr arg2
)))
2132 (z2 ($float
(cadddr arg2
)))
2133 (x3 ($float
(cadr arg3
)))
2134 (y3 ($float
(caddr arg3
)))
2135 (z3 ($float
(cadddr arg3
)))
2136 (x4 ($float
(cadr arg4
)))
2137 (y4 ($float
(caddr arg4
)))
2138 (z4 ($float
(cadddr arg4
)))
2139 (grobj (mesh `((mlist simp
)
2140 ((mlist simp
) ,x1
,y1
,z1
)
2141 ((mlist simp
) ,x2
,y2
,z2
))
2143 ((mlist simp
) ,x3
,y3
,z3
)
2144 ((mlist simp
) ,x4
,y4
,z4
)))))
2145 (setf (gr-object-name grobj
) 'quadrilateral
)
2154 ;; Object: 'parametric'
2156 ;; parametric(xfun,yfun,par,parmin,parmax)
2166 ;; Note: similar to draw2d-parametric in plot.lisp
2167 (defun-checked parametric
(xfun yfun par parmin parmax
)
2168 (let* ((nticks (get-option '$nticks
))
2170 (tmin ($float parmin
))
2171 (tmax ($float parmax
))
2172 (xmin most-positive-double-float
)
2173 (xmax most-negative-double-float
)
2174 (ymin most-positive-double-float
)
2175 (ymax most-negative-double-float
)
2176 (*plot-realpart
* *plot-realpart
*)
2177 (tt ($float parmin
))
2178 (eps (/ (- tmax tmin
) (- nticks
1)))
2181 (merror "draw2d (parametric): illegal range"))
2182 (when (not (subsetp (append (rest ($listofvars xfun
)) (rest ($listofvars yfun
))) (list par
) :test
#'like
))
2183 (merror "draw2d (parametric): non defined variable"))
2184 (setq *plot-realpart
* (get-option '$draw_realpart
))
2185 (setq f1
(coerce-float-fun xfun
`((mlist), par
)))
2186 (setq f2
(coerce-float-fun yfun
`((mlist), par
)))
2189 do
(setf xx
($float
(funcall f1 tt
)))
2190 (setf yy
($float
(funcall f2 tt
)))
2196 when
(>= tt tmax
) do
(loop-finish)
2197 do
(setq tt
(+ tt eps
))
2198 (if (>= tt tmax
) (setq tt tmax
)) ))
2199 ; update x-y ranges if necessary
2200 (update-ranges-2d xmin xmax ymin ymax
)
2203 :command
(format nil
" ~a w l lw ~a lt ~a lc ~a axis ~a"
2204 (make-obj-title (get-option '$key
))
2205 (get-option '$line_width
)
2206 (get-option '$line_type
)
2207 (hex-to-rgb (get-option '$color
))
2210 :points
`(,(make-array (length result
) :initial-contents result
))) ) )
2220 ;; polar(radius,ang,minang,maxang)
2229 ;; This object is constructed as a parametric function
2230 (defun-checked polar
(radius ang minang maxang
)
2231 (let ((grobj (parametric `((mtimes simp
) ,radius
((%cos simp
) ,ang
))
2232 `((mtimes simp
) ,radius
((%sin simp
) ,ang
))
2233 ang minang maxang
)))
2234 (setf (gr-object-name grobj
) 'polar
)
2243 ;; Object: 'spherical'
2245 ;; spherical(radius,az,minazi,maxazi,zen,minzen,maxzen)
2254 ;; This object is constructed as a parametric surface in 3d.
2255 ;; Functions are defined in format r=r(azimuth,zenith),
2256 ;; where, normally, azimuth is an angle in [0,2*%pi] and zenith in [0,%pi]
2257 (defun-checked spherical
(radius azi minazi maxazi zen minzen maxzen
)
2258 (let ((grobj (parametric_surface
2259 `((mtimes simp
) ,radius
((%sin simp
) ,zen
) ((%cos simp
) ,azi
))
2260 `((mtimes simp
) ,radius
((%sin simp
) ,zen
) ((%sin simp
) ,azi
))
2261 `((mtimes simp
) ,radius
((%cos simp
) ,zen
))
2263 zen minzen maxzen
)))
2264 (setf (gr-object-name grobj
) 'spherical
)
2274 ;; Object: 'cylindrical'
2276 ;; cylindrical(r,z,minz,maxz,azi,minazi,maxazi)
2285 ;; This object is constructed as a parametric surface in 3d.
2286 ;; Functions are defined in format z=z(radius,azimuth), where,
2287 ;; normally, azimuth is an angle in [0,2*%pi] and r any real
2288 (defun-checked cylindrical
(r z minz maxz azi minazi maxazi
)
2289 (let ((grobj (parametric_surface
2290 `((mtimes simp
) ,r
((%cos simp
) ,azi
))
2291 `((mtimes simp
) ,r
((%sin simp
) ,azi
))
2294 azi minazi maxazi
)))
2295 (setf (gr-object-name grobj
) 'cylindrical
)
2305 ;; Object: 'parametric3d'
2307 ;; parametric(xfun,yfun,zfun,par1,parmin,parmax)
2317 (defun-checked parametric3d
(xfun yfun zfun par1 parmin parmax
)
2318 (let* ((nticks (get-option '$nticks
))
2320 (tmin ($float parmin
))
2321 (tmax ($float parmax
))
2322 (xmin most-positive-double-float
)
2323 (xmax most-negative-double-float
)
2324 (ymin most-positive-double-float
)
2325 (ymax most-negative-double-float
)
2326 (zmin most-positive-double-float
)
2327 (zmax most-negative-double-float
)
2328 (*plot-realpart
* *plot-realpart
*)
2330 (eps (/ (- tmax tmin
) (- nticks
1)))
2332 ncols result f1 f2 f3 xx yy zz
)
2333 (when (not (subsetp (rest ($append
($listofvars xfun
) ($listofvars yfun
) ($listofvars zfun
))) (list par1
) :test
#'like
))
2334 (merror "draw3d (parametric): non defined variable"))
2335 (setq *plot-realpart
* (get-option '$draw_realpart
))
2336 (check-enhanced3d-model "parametric" '(0 1 3 99))
2337 (when (= *draw-enhanced3d-type
* 99)
2338 (update-enhanced3d-expression (list '(mlist) par1
)))
2340 (merror "draw3d (parametric): illegal range"))
2341 (setq f1
(coerce-float-fun xfun
`((mlist) ,par1
)))
2342 (setq f2
(coerce-float-fun yfun
`((mlist) ,par1
)))
2343 (setq f3
(coerce-float-fun zfun
`((mlist) ,par1
)))
2344 (setf ncols
(if (= *draw-enhanced3d-type
* 0) 3 4))
2345 (setf result
(make-array (* ncols nticks
)))
2347 (setf xx
(funcall f1 tt
))
2348 (setf yy
(funcall f2 tt
))
2349 (setf zz
(funcall f3 tt
))
2354 (setf (aref result
(incf count
)) xx
)
2355 (setf (aref result
(incf count
)) yy
)
2356 (setf (aref result
(incf count
)) zz
)
2357 ; check texture model
2358 (case *draw-enhanced3d-type
*
2359 ((1 99) (setf (aref result
(incf count
)) (funcall *draw-enhanced3d-fun
* tt
)))
2360 (3 (setf (aref result
(incf count
)) (funcall *draw-enhanced3d-fun
* xx yy zz
))))
2361 (setf tt
(+ tt eps
)) )
2362 ; update x-y ranges if necessary
2363 (update-ranges-3d xmin xmax ymin ymax zmin zmax
)
2366 :command
(format nil
" ~a w l lw ~a lt ~a lc ~a"
2367 (make-obj-title (get-option '$key
))
2368 (get-option '$line_width
)
2369 (get-option '$line_type
)
2370 (if (> *draw-enhanced3d-type
* 0)
2372 (hex-to-rgb (get-option '$color
))) )
2373 :groups
`((,ncols
0))
2374 :points
(list result
) )) )
2383 ;; Object: 'parametric_surface'
2385 ;; parametric_surface(xfun,yfun,zfun,par1,par1min,par1max,par2,par2min,par2max)
2397 (defun-checked parametric_surface
(xfun yfun zfun par1 par1min par1max par2 par2min par2max
)
2398 (let* ((ugrid (get-option '$xu_grid
))
2399 (vgrid (get-option '$yv_grid
))
2401 (umin ($float par1min
))
2402 (umax ($float par1max
))
2403 (vmin ($float par2min
))
2404 (vmax ($float par2max
))
2405 (xmin most-positive-double-float
)
2406 (xmax most-negative-double-float
)
2407 (ymin most-positive-double-float
)
2408 (ymax most-negative-double-float
)
2409 (zmin most-positive-double-float
)
2410 (zmax most-negative-double-float
)
2411 (*plot-realpart
* *plot-realpart
*)
2412 (ueps (/ (- umax umin
) (- ugrid
1)))
2413 (veps (/ (- vmax vmin
) (- vgrid
1)))
2417 ncols result f1 f2 f3 xx yy zz uu vv
)
2418 (when (not (subsetp (rest ($append
($listofvars xfun
) ($listofvars yfun
) ($listofvars zfun
))) (list par1 par2
) :test
#'like
))
2419 (merror "draw3d (parametric_surface): non defined variable"))
2420 (setq *plot-realpart
* (get-option '$draw_realpart
))
2421 (check-enhanced3d-model "parametric_surface" '(0 2 3 99))
2422 (when (= *draw-enhanced3d-type
* 99)
2423 (update-enhanced3d-expression (list '(mlist) par1 par2
)))
2424 (if (or (< umax umin
)
2426 (merror "draw3d (parametric_surface): illegal range"))
2427 (setq f1
(coerce-float-fun xfun
`((mlist) ,par1
,par2
)))
2428 (setq f2
(coerce-float-fun yfun
`((mlist) ,par1
,par2
)))
2429 (setq f3
(coerce-float-fun zfun
`((mlist) ,par1
,par2
)))
2430 (setf ncols
(if (= *draw-enhanced3d-type
* 0) 3 4))
2431 (setf result
(make-array (* ncols nu nv
)))
2432 (loop for j below nv
2433 initially
(setq vv vmin
)
2435 (loop for i below nu
2437 (setf xx
(funcall f1 uu vv
))
2438 (setf yy
(funcall f2 uu vv
))
2439 (setf zz
(funcall f3 uu vv
))
2444 (setf (aref result
(incf count
)) xx
)
2445 (setf (aref result
(incf count
)) yy
)
2446 (setf (aref result
(incf count
)) zz
)
2447 ; check texture model
2448 (case *draw-enhanced3d-type
*
2449 ((2 99) (setf (aref result
(incf count
)) (funcall *draw-enhanced3d-fun
* uu vv
)))
2450 (3 (setf (aref result
(incf count
)) (funcall *draw-enhanced3d-fun
* xx yy zz
))) )
2451 (setq uu
(+ uu ueps
))
2452 (if (> uu umax
) (setf uu umax
)))
2453 (setq vv
(+ vv veps
))
2454 (if (> vv vmax
) (setf vv vmax
)))
2455 ; update x-y-z ranges if necessary
2456 (update-ranges-3d xmin xmax ymin ymax zmin zmax
)
2458 :name
'parametric_surface
2459 :command
(format nil
" ~a w ~a lw ~a lt ~a lc ~a"
2460 (make-obj-title (get-option '$key
))
2461 (if (> *draw-enhanced3d-type
* 0) "pm3d" "l")
2462 (get-option '$line_width
)
2463 (get-option '$line_type
)
2464 (hex-to-rgb (get-option '$color
)))
2465 :groups
`((,ncols
,nu
)) ; ncols is 4 or 3, depending on colored 4th dimension or not
2466 :points
(list result
))))
2476 ;; tube(xfun,yfun,zfun,rad,par1,parmin,parmax)
2488 (defmacro check-tube-extreme
(ex cx cy cz circ
)
2489 `(when (equal (nth ,ex
(get-option '$capping
)) t
)
2493 (when (> *draw-transform-dimensions
* 0)
2494 (setf cxx
(funcall *draw-transform-f1
* ,cx
,cy
,cz
)
2495 cyy
(funcall *draw-transform-f2
* ,cx
,cy
,cz
)
2496 czz
(funcall *draw-transform-f3
* ,cx
,cy
,cz
)))
2497 (case *draw-enhanced3d-type
*
2498 (0 (setf ,circ
(list cxx cyy czz
)))
2499 ((1 99) (setf ,circ
(list cxx cyy czz
(funcall *draw-enhanced3d-fun
* tt
))))
2500 (3 (setf ,circ
(list cxx cyy czz
(funcall *draw-enhanced3d-fun
* cxx cyy czz
)))))
2502 (setf result
(append result
,circ
))))))
2504 (defun-checked tube
(xfun yfun zfun rad par1 parmin parmax
)
2505 (let* ((ugrid (get-option '$xu_grid
))
2506 (vgrid (get-option '$yv_grid
))
2508 (tmin ($float parmin
))
2509 (tmax ($float parmax
))
2510 (vmax 6.283185307179586) ; = float(2*%pi)
2511 (xmin most-positive-double-float
)
2512 (xmax most-negative-double-float
)
2513 (ymin most-positive-double-float
)
2514 (ymax most-negative-double-float
)
2515 (zmin most-positive-double-float
)
2516 (zmax most-negative-double-float
)
2517 (teps (/ (- tmax tmin
) (- ugrid
1)))
2518 (veps (/ vmax
(- vgrid
1)))
2524 xx yy zz module r vv rcos rsin
2526 uxold uyold uzold ttnext
)
2528 (merror "draw3d (tube): illegal range"))
2529 (when (not (subsetp (rest ($append
($listofvars xfun
) ($listofvars yfun
)
2530 ($listofvars zfun
) ($listofvars rad
)))
2531 (list par1
) :test
#'like
))
2532 (merror "draw3d (tube): non defined variable"))
2533 (check-enhanced3d-model "tube" '(0 1 3 99))
2534 (when (= *draw-enhanced3d-type
* 99)
2535 (update-enhanced3d-expression (list '(mlist) par1
)))
2536 (setq f1
(coerce-float-fun xfun
`((mlist) ,par1
)))
2537 (setq f2
(coerce-float-fun yfun
`((mlist) ,par1
)))
2538 (setq f3
(coerce-float-fun zfun
`((mlist) ,par1
)))
2539 (setf ncols
(if (= *draw-enhanced3d-type
* 0) 3 4))
2541 (coerce-float-fun rad
`((mlist) ,par1
)))
2543 ; calculate center and radius of circle
2545 ((= tt tmin
) ; 1st iteration
2546 (setf cx
(funcall f1 tt
)
2550 (check-tube-extreme 1 cx cy cz circ
)
2551 (setf nx
(- (funcall f1 ttnext
) cx
)
2552 ny
(- (funcall f2 ttnext
) cy
)
2553 nz
(- (funcall f3 ttnext
) cz
)))
2554 (t ; all next iterations along the parametric curve
2558 (setf cx
(funcall f1 tt
)
2561 (setf nx
(- cx cxold
)
2564 (setf r
(funcall radius tt
))
2565 ; calculate the unitary normal vector
2566 (setf module
(sqrt (+ (* nx nx
) (* ny ny
) (* nz nz
))))
2567 (setf nx
(/ nx module
)
2570 ; calculate unitary vector perpendicular to n=(nx,ny,nz)
2571 ; ux.nx+uy.ny+uz.nz=0 => ux=-t(ny+nz)/nx, uy=uz=t
2575 (setf ux
1.0 uy
0.0 uz
0.0))
2577 (setf ux
0.0 uy
1.0 uz
0.0))
2579 (setf ux
0.0 uy
0.0 uz
1.0))
2580 (t ; all other cases
2581 (setf ux
(- (/ (+ ny nz
) nx
))
2584 (setf module
(sqrt (+ (* ux ux
) (* uy uy
) (* uz uz
))))
2585 (setf ux
(/ ux module
)
2588 (when (and (> tt tmin
)
2599 ; vector v = n times u
2600 (setf vx
(- (* ny uz
) (* nz uy
))
2601 vy
(- (* nz ux
) (* nx uz
))
2602 vz
(- (* nx uy
) (* ny ux
)))
2603 ; parametric equation of the circumference of radius
2604 ; r and centered at c=(cx,cy,cz):
2605 ; x(t) = c + r(cos(t)u + sin(t)v),
2606 ; for t in (0, 2*%pi)
2609 (loop for i below vgrid do
2610 (setf rcos
(* r
(cos vv
))
2611 rsin
(* r
(sin vv
)))
2612 (setf xx
(+ cx
(* rcos ux
) (* rsin vx
))
2613 yy
(+ cy
(* rcos uy
) (* rsin vy
))
2614 zz
(+ cz
(* rcos uz
) (* rsin vz
)))
2619 ; check texture model
2620 (case *draw-enhanced3d-type
*
2621 (0 (setf circ
(cons (list xx yy zz
) circ
)))
2622 ((1 99) (setf circ
(cons (list xx yy zz
(funcall *draw-enhanced3d-fun
* tt
)) circ
)))
2623 (3 (setf circ
(cons (list xx yy zz
(funcall *draw-enhanced3d-fun
* xx yy zz
)) circ
))))
2624 (setf vv
(+ vv veps
))
2625 (when (> vv vmax
) (setf vv vmax
)) ) ; loop for
2626 (setf result
(append result
(apply #'append circ
)))
2627 when
(>= tt tmax
) do
(loop-finish)
2628 do
(setf tt
(+ tt teps
))
2629 (when (> tt tmax
) (setf tt tmax
)) ) ; loop do
2630 (check-tube-extreme 2 cx cy cz circ
)
2631 ; update x-y-z ranges
2632 (update-ranges-3d xmin xmax ymin ymax zmin zmax
)
2635 :command
(format nil
" ~a w ~a lw ~a lt ~a lc ~a"
2636 (make-obj-title (get-option '$key
))
2637 (if (> *draw-enhanced3d-type
* 0) "pm3d" "l")
2638 (get-option '$line_width
)
2639 (get-option '$line_type
)
2640 (hex-to-rgb (get-option '$color
)))
2641 :groups
`((,ncols
,vgrid
))
2642 :points
`(,(make-array (length result
) :element-type
'flonum
2643 :initial-contents result
)))))
2653 ;; image(matrix_of_numbers,x0,y0,width,height)
2654 ;; image(matrix_of_[r,g,b],x0,y0,width,height)
2655 ;; image(picture_object,x0,y0,width,height)
2659 (defun-checked image
(mat x0 y0 width height
)
2660 (let ( (fx0 ($float x0
))
2662 (fwidth ($float width
))
2663 (fheight ($float height
))
2664 result nrows ncols dx dy n
)
2665 (cond (($matrixp mat
)
2666 (setf nrows
(length (cdr mat
))
2667 ncols
(length (cdadr mat
)))
2668 (setf dx
(/ fwidth ncols
)
2669 dy
(/ fheight nrows
))
2670 (if (not ($listp
(cadadr mat
))) ; it's a matrix of reals
2671 (setf n
3) ; 3 numbers to be sent to gnuplot: x,y,value
2672 (setf n
5)) ; 5 numbers to be sent: x,y,r,g,b
2674 (3 (setf result
(make-array (* 3 nrows ncols
) :element-type
'flonum
))
2675 (let ((yi (+ fy0 height
(* dy -
0.5)))
2678 (loop for row on
(cdr mat
) by
#'cdr do
2679 (setf xi
(+ fx0
(* dx
0.5)))
2680 (loop for col on
(cdar row
) by
#'cdr do
2681 (setf (aref result
(incf counter
)) xi
2682 (aref result
(incf counter
)) yi
2683 (aref result
(incf counter
)) ($float
(car col
)))
2684 (setf xi
(+ xi dx
)))
2685 (setf yi
(- yi dy
)) )))
2686 (5 (setf result
(make-array (* 5 nrows ncols
) :element-type
'flonum
))
2687 (let ((yi (+ fy0 height
(* dy -
0.5)))
2690 (loop for row on
(cdr mat
) by
#'cdr do
2691 (setf xi
(+ fx0
(* dx
0.5)))
2692 (loop for col on
(cdar row
) by
#'cdr do
2693 (setf colors
(cdar col
))
2694 (setf (aref result
(incf counter
)) xi
2695 (aref result
(incf counter
)) yi
2696 (aref result
(incf counter
)) ($float
(car colors
))
2697 (aref result
(incf counter
)) ($float
(cadr colors
))
2698 (aref result
(incf counter
)) ($float
(caddr colors
)))
2699 (setf xi
(+ xi dx
)))
2700 (setf yi
(- yi dy
)) )))))
2702 (setf nrows
(nth 3 mat
) ; picture height
2703 ncols
(nth 2 mat
)) ; picture width
2704 (setf dx
(/ fwidth ncols
)
2705 dy
(/ fheight nrows
))
2706 (if (equal (nth 1 mat
) '$level
) ; gray level picture
2707 (setf n
3) ; 3 numbers to be sent to gnuplot: x,y,value
2708 (setf n
5)) ; 5 numbers to be sent: x,y,r,g,b
2709 (setf result
(make-array (* n nrows ncols
) :element-type
'flonum
))
2710 (let ((yi (+ fy0 height
(* dy -
0.5)))
2714 (loop for r from
0 below nrows do
2715 (setf xi
(+ fx0
(* dx
0.5)))
2716 (loop for c from
0 below ncols do
2717 (setf (aref result
(incf count1
)) xi
)
2718 (setf (aref result
(incf count1
)) yi
)
2719 (loop for q from
3 to n do
2720 (setf (aref result
(incf count1
))
2721 ($float
(aref (nth 4 mat
) (incf count2
)))))
2722 (setf xi
(+ xi dx
)))
2723 (setf yi
(- yi dy
)))))
2725 (merror "draw2d (image): Argument not recognized")))
2726 ; update x-y ranges if necessary
2727 (update-ranges-2d fx0
(+ fx0 fwidth
) fy0
(+ fy0 fheight
))
2731 (3 (format nil
" t '' w image"))
2732 (5 (format nil
" t '' w rgbimage")))
2734 (3 '((3 0))) ; numbers are sent to gnuplot in gropus of 3, no blank lines
2735 (5 '((5 0)) )) ; numbers in groups of 5, no blank lines
2736 :points
(list result
)) ) )
2743 (defmacro write-palette-code
()
2744 '(let ((pal (get-option '$palette
)))
2747 (format nil
"set palette gray~%"))
2748 ((equal pal
'$color
)
2749 (format nil
"set palette rgbformulae 7,5,15~%"))
2752 (every #'(lambda (x) (and (integerp x
) (<= (abs x
) 36))) pal
) )
2753 (format nil
"set palette rgbformulae ~a,~a,~a~%"
2754 (car pal
) (cadr pal
) (caddr pal
)))
2756 (every #'(lambda (x) (and (listp x
) (= (length x
) 3))) pal
) )
2759 (with-output-to-string (stream)
2760 (format stream
"set palette defined ( \\~%")
2762 (setf triplete
(nth k pal
))
2763 (format stream
" ~a ~a ~a ~a "
2764 k
(car triplete
) (cadr triplete
) (caddr triplete
))
2766 (format stream
")~%")
2767 (format stream
", \\~%") )))))
2769 (merror "draw: illegal palette description")))))
2773 (defvar *2d-graphic-objects
* (make-hash-table))
2775 ; table of basic 2d graphic objects
2776 (setf (gethash '$points
*2d-graphic-objects
*) 'points
2777 (gethash '$errors
*2d-graphic-objects
*) 'errors
2778 (gethash '$polygon
*2d-graphic-objects
*) 'polygon
2779 (gethash '$ellipse
*2d-graphic-objects
*) 'ellipse
2780 (gethash '$triangle
*2d-graphic-objects
*) 'triangle
2781 (gethash '$rectangle
*2d-graphic-objects
*) 'rectangle
2782 (gethash '$quadrilateral
*2d-graphic-objects
*) 'quadrilateral
2783 (gethash '$region
*2d-graphic-objects
*) 'region
2784 (gethash '$explicit
*2d-graphic-objects
*) 'explicit
2785 (gethash '$implicit
*2d-graphic-objects
*) 'implicit
2786 (gethash '$parametric
*2d-graphic-objects
*) 'parametric
2787 (gethash '$vector
*2d-graphic-objects
*) 'vect
2788 (gethash '$label
*2d-graphic-objects
*) 'label
2789 (gethash '$bars
*2d-graphic-objects
*) 'bars
2790 (gethash '$polar
*2d-graphic-objects
*) 'polar
2791 (gethash '$image
*2d-graphic-objects
*) 'image
2792 (gethash '%points
*2d-graphic-objects
*) 'points
2793 (gethash '%errors
*2d-graphic-objects
*) 'errors
2794 (gethash '%polygon
*2d-graphic-objects
*) 'polygon
2795 (gethash '%ellipse
*2d-graphic-objects
*) 'ellipse
2796 (gethash '%triangle
*2d-graphic-objects
*) 'triangle
2797 (gethash '%rectangle
*2d-graphic-objects
*) 'rectangle
2798 (gethash '%quadrilateral
*2d-graphic-objects
*) 'quadrilateral
2799 (gethash '%region
*2d-graphic-objects
*) 'region
2800 (gethash '%explicit
*2d-graphic-objects
*) 'explicit
2801 (gethash '%implicit
*2d-graphic-objects
*) 'implicit
2802 (gethash '%parametric
*2d-graphic-objects
*) 'parametric
2803 (gethash '%vector
*2d-graphic-objects
*) 'vect
2804 (gethash '%label
*2d-graphic-objects
*) 'label
2805 (gethash '%bars
*2d-graphic-objects
*) 'bars
2806 (gethash '%polar
*2d-graphic-objects
*) 'polar
2807 (gethash '%image
*2d-graphic-objects
*) 'image
)
2809 (defun make-scene-2d (args)
2813 (ini-local-option-variables)
2815 (setf largs
(listify-arguments args
))
2816 ; update option values and detect objects to be plotted
2818 (cond ((equal ($op x
) "=")
2819 (update-gr-option ($lhs x
) ($rhs x
)))
2820 ((not (null (gethash (setf aux
(caar x
)) *2d-graphic-objects
*)))
2824 (list (apply (gethash aux
*2d-graphic-objects
*) (rest x
))))))
2825 (t (merror "draw: 2D graphic object not recognized, ~M" aux
))))
2826 ; save in plotcmd the gnuplot preamble
2828 (concatenate 'string
2829 (unless (or *multiplot-is-active
*
2830 (member (get-option '$terminal
) '($eps $epslatex $epslatex_standalone
)))
2831 (format nil
"set obj 1 fc rgb '~a' fs solid 1.0 noborder ~%"
2832 (get-option '$background_color
)) )
2833 (if (equal (get-option '$proportional_axes
) '$none
)
2834 (format nil
"set size noratio~%")
2835 (format nil
"set size ratio -1~%") )
2836 ; this let statement is to prevent error messages from gnuplot when
2837 ; the amplitude of the ranges equals zero
2838 (let ((xi (first (get-option '$xrange
)))
2839 (xf (second (get-option '$xrange
)))
2840 (yi (first (get-option '$yrange
)))
2841 (yf (second (get-option '$yrange
)))
2842 (x2i (first (get-option '$xrange_secondary
)))
2843 (x2f (second (get-option '$xrange_secondary
)))
2844 (y2i (first (get-option '$yrange_secondary
)))
2845 (y2f (second (get-option '$yrange_secondary
))) )
2846 (when (and (get-option '$xrange
) (near-equal xi xf
))
2847 (setf xi
(- xi
0.01)
2849 (when (and (get-option '$xrange_secondary
) (near-equal x2i x2f
))
2850 (setf x2i
(- x2i
0.01)
2852 (when (and (get-option '$yrange
) (near-equal yi yf
))
2853 (setf yi
(- yi
0.01)
2855 (when (and (get-option '$yrange_secondary
) (near-equal y2i y2f
))
2856 (setf y2i
(- y2i
0.01)
2858 (format nil
"~a~a~a~a"
2859 (if (get-option '$xrange
)
2860 (format nil
"set xrange [~a:~a]~%" xi xf
)
2862 (if (get-option '$xrange_secondary
)
2863 (format nil
"set x2range [~a:~a]~%" x2i x2f
)
2865 (if (get-option '$yrange
)
2866 (format nil
"set yrange [~a:~a]~%" yi yf
)
2868 (if (get-option '$yrange_secondary
)
2869 (format nil
"set y2range [~a:~a]~%" y2i y2f
)
2871 (if (get-option '$cbrange
)
2872 (format nil
"set cbrange [~a:~a]~%"
2873 (first (get-option '$cbrange
))
2874 (second (get-option '$cbrange
)))
2875 (format nil
"set cbrange [*:*]~%") )
2876 (if (get-option '$logx
)
2877 (format nil
"set logscale x~%")
2878 (format nil
"unset logscale x~%"))
2879 (if (get-option '$logx_secondary
)
2880 (format nil
"set logscale x2~%")
2881 (format nil
"unset logscale x2~%"))
2882 (if (get-option '$logy
)
2883 (format nil
"set logscale y~%")
2884 (format nil
"unset logscale y~%"))
2885 (if (get-option '$logy_secondary
)
2886 (format nil
"set logscale y2~%")
2887 (format nil
"unset logscale y2~%"))
2888 (if (get-option '$logcb
)
2889 (format nil
"set logscale cb~%")
2890 (format nil
"unset logscale cb~%") )
2892 ( if
(equal (car (get-option '$grid
)) 0)
2893 (format nil
"unset grid~%")
2894 (format nil
"set grid xtics ytics mxtics mytics~%set mxtics ~d~%set mytics ~d~%"
2895 (car (get-option '$grid
))
2896 (cadr (get-option '$grid
))
2900 (format nil
"set title '~a'~%" (get-option '$title
))
2901 (format nil
"set xlabel '~a'~%" (get-option '$xlabel
))
2902 (format nil
"set x2label '~a'~%" (get-option '$xlabel_secondary
))
2903 (format nil
"set ylabel '~a'~%" (get-option '$ylabel
))
2904 (format nil
"set y2label '~a'~%" (get-option '$ylabel_secondary
))
2906 (if (get-option '$axis_bottom
) (setf suma
(+ suma
1)))
2907 (if (get-option '$axis_left
) (setf suma
(+ suma
2)))
2908 (if (get-option '$axis_top
) (setf suma
(+ suma
4)))
2909 (if (get-option '$axis_right
) (setf suma
(+ suma
8)))
2910 (format nil
"set border ~a~%" suma
) )
2911 (if (get-option '$key_pos
)
2912 (format nil
"set key ~a~%" (get-option '$key_pos
))
2913 (format nil
"set key top right~%") )
2914 (if (get-option '$xaxis
)
2915 (format nil
"set xzeroaxis lw ~a lt ~a lc ~a~%"
2916 (get-option '$xaxis_width
)
2917 (get-option '$xaxis_type
)
2918 (hex-to-rgb (get-option '$xaxis_color
)) )
2919 (format nil
"unset xzeroaxis~%"))
2920 (if (get-option '$yaxis
)
2921 (format nil
"set yzeroaxis lw ~a lt ~a lc ~a~%"
2922 (get-option '$yaxis_width
)
2923 (get-option '$yaxis_type
)
2924 (hex-to-rgb (get-option '$yaxis_color
)) )
2925 (format nil
"unset yzeroaxis~%"))
2926 (if (null (get-option '$xtics_secondary
))
2927 (format nil
"unset x2tics~%set xtics nomirror~%")
2928 (format nil
"set x2tics ~a ~a ~a~%"
2929 (if (get-option '$xtics_secondary_rotate
) "rotate" "norotate")
2930 (if (get-option '$xtics_secondary_axis
) "axis" "border")
2931 (get-option '$xtics_secondary
)))
2932 (if (null (get-option '$xtics
))
2933 (format nil
"unset xtics~%")
2934 (format nil
"set xtics ~a ~a ~a~%"
2935 (if (get-option '$xtics_rotate
) "rotate" "norotate")
2936 (if (get-option '$xtics_axis
) "axis" "border")
2937 (get-option '$xtics
)))
2938 (if (null (get-option '$ytics_secondary
))
2939 (format nil
"unset y2tics~%set ytics nomirror~%")
2940 (format nil
"set ytics nomirror~%set y2tics ~a ~a ~a~%"
2941 (if (get-option '$ytics_secondary_rotate
) "rotate" "norotate")
2942 (if (get-option '$ytics_secondary_axis
) "axis" "border")
2943 (get-option '$ytics_secondary
)))
2944 (if (null (get-option '$ytics
))
2945 (format nil
"unset ytics~%")
2946 (format nil
"set ytics ~a ~a ~a~%"
2947 (if (get-option '$ytics_rotate
) "rotate" "norotate")
2948 (if (get-option '$ytics_axis
) "axis" "border")
2949 (get-option '$ytics
)))
2950 (if (null (get-option '$cbtics
))
2951 (format nil
"unset cbtics~%")
2952 (format nil
"set cbtics ~a~%" (get-option '$cbtics
) ))
2953 (if (get-option '$colorbox
)
2954 (format nil
"set colorbox~%")
2955 (format nil
"unset colorbox~%"))
2956 (format nil
"set cblabel '~a'~%"
2957 (if (stringp (get-option '$colorbox
))
2958 (get-option '$colorbox
)
2960 (write-palette-code)
2961 (if (not (string= (get-option '$user_preamble
) ""))
2962 (format nil
"~a~%" (get-option '$user_preamble
))) ) )
2964 (setf *allocations
* (cons (get-option '$allocation
) *allocations
*))
2965 ; scene description: (dimensions, gnuplot preamble in string format, list of objects)
2968 plotcmd
; gnuplot preamble
2969 objects
; list of objects to be plotted
2977 (defvar *3d-graphic-objects
* (make-hash-table))
2979 ; table of basic 3d graphic objects
2980 (setf (gethash '$points
*3d-graphic-objects
*) 'points3d
2981 (gethash '$elevation_grid
*3d-graphic-objects
*) 'elevation_grid
2982 (gethash '$mesh
*3d-graphic-objects
*) 'mesh
2983 (gethash '$triangle
*3d-graphic-objects
*) 'triangle3d
2984 (gethash '$quadrilateral
*3d-graphic-objects
*) 'quadrilateral3d
2985 (gethash '$explicit
*3d-graphic-objects
*) 'explicit3d
2986 (gethash '$implicit
*3d-graphic-objects
*) 'implicit3d
2987 (gethash '$parametric
*3d-graphic-objects
*) 'parametric3d
2988 (gethash '$vector
*3d-graphic-objects
*) 'vect3d
2989 (gethash '$label
*3d-graphic-objects
*) 'label
2990 (gethash '$parametric_surface
*3d-graphic-objects
*) 'parametric_surface
2991 (gethash '$tube
*3d-graphic-objects
*) 'tube
2992 (gethash '$spherical
*3d-graphic-objects
*) 'spherical
2993 (gethash '$cylindrical
*3d-graphic-objects
*) 'cylindrical
2994 (gethash '%points
*3d-graphic-objects
*) 'points3d
2995 (gethash '%elevation_grid
*3d-graphic-objects
*) 'elevation_grid
2996 (gethash '%mesh
*3d-graphic-objects
*) 'mesh
2997 (gethash '%triangle
*3d-graphic-objects
*) 'triangle3d
2998 (gethash '%quadrilateral
*3d-graphic-objects
*) 'quadrilateral3d
2999 (gethash '%explicit
*3d-graphic-objects
*) 'explicit3d
3000 (gethash '%implicit
*3d-graphic-objects
*) 'implicit3d
3001 (gethash '%parametric
*3d-graphic-objects
*) 'parametric3d
3002 (gethash '%vector
*3d-graphic-objects
*) 'vect3d
3003 (gethash '%label
*3d-graphic-objects
*) 'label
3004 (gethash '%parametric_surface
*3d-graphic-objects
*) 'parametric_surface
3005 (gethash '%tube
*3d-graphic-objects
*) 'tube
3006 (gethash '%spherical
*3d-graphic-objects
*) 'spherical
3007 (gethash '%cylindrical
*3d-graphic-objects
*) 'cylindrical
)
3009 ;; This function builds a 3d scene by calling the
3010 ;; graphic objects constructors.
3011 (defun make-scene-3d (args)
3015 (ini-local-option-variables)
3017 (setf largs
(listify-arguments args
))
3018 ; update option values and detect objects to be plotted
3020 (cond ((equal ($op x
) "=")
3021 (update-gr-option ($lhs x
) ($rhs x
)))
3022 ((not (null (gethash (setf aux
(caar x
)) *3d-graphic-objects
*)))
3026 (list (apply (gethash aux
*3d-graphic-objects
*) (rest x
))))))
3027 (t (merror "draw: 3D graphic object not recognized, ~M" aux
) )))
3028 ; save in plotcmd the gnuplot preamble
3030 (concatenate 'string
3031 (format nil
"set style rectangle fillcolor rgb '~a' fs solid 1.0 noborder~%"
3032 (get-option '$background_color
)) ; background rectangle
3033 ; this let statement is to prevent error messages in gnuplot when
3034 ; the amplitude of the ranges equals zero
3035 (let ((xi (first (get-option '$xrange
)))
3036 (xf (second (get-option '$xrange
)))
3037 (yi (first (get-option '$yrange
)))
3038 (yf (second (get-option '$yrange
)))
3039 (zi (first (get-option '$zrange
)))
3040 (zf (second (get-option '$zrange
))))
3041 (when (near-equal xi xf
)
3042 (setf xi
(- xi
0.01)
3044 (when (near-equal yi yf
)
3045 (setf yi
(- yi
0.01)
3047 (when (near-equal zi zf
)
3048 (setf zi
(- zi
0.01)
3050 (format nil
"set xrange [~a:~a]~%set yrange [~a:~a]~%set zrange [~a:~a]~%"
3052 (if (get-option '$cbrange
)
3053 (format nil
"set cbrange [~a:~a]~%"
3054 (first (get-option '$cbrange
))
3055 (second (get-option '$cbrange
)) )
3056 (format nil
"set cbrange [*:*]~%") )
3057 (case (get-option '$contour
)
3058 ($surface
(format nil
"set contour surface~%set cntrparam levels ~a~%"
3059 (get-option '$contour_levels
) ))
3060 ($base
(format nil
"set contour base~%set cntrparam levels ~a~%"
3061 (get-option '$contour_levels
) ))
3062 ($both
(format nil
"set contour both~%set cntrparam levels ~a~%"
3063 (get-option '$contour_levels
) ))
3064 ($map
(format nil
"set contour base~%unset surface~%set cntrparam levels ~a~%"
3065 (get-option '$contour_levels
))) )
3066 (format nil
"set title '~a'~%" (get-option '$title
))
3067 (format nil
"set xlabel '~a'~%" (get-option '$xlabel
))
3068 (format nil
"set ylabel '~a'~%" (get-option '$ylabel
))
3069 (if (< (length (get-option '$zlabel
)) 5)
3070 (format nil
"set zlabel '~a'~%" (get-option '$zlabel
))
3071 (format nil
"set zlabel '~a' rotate~%" (get-option '$zlabel
)) )
3072 (format nil
"set datafile missing 'NIL'~%")
3073 (if (get-option '$logx
)
3074 (format nil
"set logscale x~%")
3075 (format nil
"unset logscale x~%"))
3076 (if (get-option '$logy
)
3077 (format nil
"set logscale y~%")
3078 (format nil
"unset logscale y~%"))
3079 (if (get-option '$logz
)
3080 (format nil
"set logscale z~%")
3081 (format nil
"unset logscale z~%"))
3082 (if (get-option '$key_pos
)
3083 (format nil
"set key ~a~%" (get-option '$key_pos
))
3084 (format nil
"set key top center~%") )
3085 (if (get-option '$logcb
)
3086 (format nil
"set logscale cb~%")
3087 (format nil
"unset logscale cb~%") )
3088 (if (equal (car (get-option '$grid
)) 0)
3089 (format nil
"unset grid~%")
3090 (format nil
"set grid xtics ytics ztics mxtics mytics mztics~%set mxtics ~d~%set mytics ~d~%"
3091 (car (get-option '$grid
))
3092 (cadr (get-option '$grid
))
3095 (if (get-option '$xaxis
)
3096 (format nil
"set xzeroaxis lw ~a lt ~a lc ~a~%"
3097 (get-option '$xaxis_width
)
3098 (get-option '$xaxis_type
)
3099 (hex-to-rgb (get-option '$xaxis_color
)) )
3100 (format nil
"unset xzeroaxis~%"))
3101 (if (get-option '$yaxis
)
3102 (format nil
"set yzeroaxis lw ~a lt ~a lc ~a~%"
3103 (get-option '$yaxis_width
)
3104 (get-option '$yaxis_type
)
3105 (hex-to-rgb (get-option '$yaxis_color
)) )
3106 (format nil
"unset yzeroaxis~%"))
3107 (if (get-option '$zaxis
)
3108 (format nil
"set zzeroaxis lw ~a lt ~a lc ~a~%"
3109 (get-option '$zaxis_width
)
3110 (get-option '$zaxis_type
)
3111 (hex-to-rgb (get-option '$zaxis_color
)))
3112 (format nil
"unset zzeroaxis~%"))
3113 (if (null (get-option '$xtics
))
3114 (format nil
"unset xtics~%")
3115 (format nil
"set xtics ~a ~a ~a~%"
3116 (if (get-option '$xtics_rotate
) "rotate" "norotate")
3117 (if (get-option '$xtics_axis
) "axis" "border")
3118 (get-option '$xtics
)))
3119 (if (null (get-option '$ytics
))
3120 (format nil
"unset ytics~%")
3121 (format nil
"set ytics ~a ~a ~a~%"
3122 (if (get-option '$ytics_rotate
) "rotate" "norotate")
3123 (if (get-option '$ytics_axis
) "axis" "border")
3124 (get-option '$ytics
)))
3125 (if (null (get-option '$ztics
))
3126 (format nil
"unset ztics~%")
3127 (format nil
"set ztics ~a ~a ~a~%"
3128 (if (get-option '$ztics_rotate
) "rotate" "norotate")
3129 (if (get-option '$ztics_axis
) "axis" "border")
3130 (get-option '$ztics
)))
3131 (if (null (get-option '$cbtics
))
3132 (format nil
"unset cbtics~%")
3133 (format nil
"set cbtics ~a~%"
3134 (get-option '$cbtics
)) )
3135 (if (or (eql (get-option '$contour
) '$map
)
3136 (eql (get-option '$view
) '$map
) )
3137 (format nil
"set view map~%~a~%"
3138 (if (equal (get-option '$proportional_axes
) '$none
)
3140 "set size ratio -1") )
3141 (format nil
"set view ~a, ~a, 1, 1~%~a~%"
3142 (first (get-option '$view
))
3143 (second (get-option '$view
))
3144 (case (get-option '$proportional_axes
)
3145 ($xy
"set view equal xy" )
3146 ($xyz
"set view equal xyz")
3148 (if (not (get-option '$axis_3d
))
3149 (format nil
"set border 0~%unset xtics~%unset ytics~%unset ztics~%"))
3150 (when (not (null (get-option '$enhanced3d
)))
3151 (if (null (get-option '$wired_surface
))
3152 (format nil
"set pm3d at s ~a explicit~%" (get-option '$interpolate_color
))
3153 (format nil
"set style line 1 lt 1 lw 1 lc rgb '#000000'~%set pm3d at s depthorder explicit hidden3d 1~%") ))
3154 (if (get-option '$surface_hide
)
3155 (format nil
"set hidden3d nooffset~%"))
3156 (if (get-option '$xyplane
)
3157 (format nil
"set xyplane at ~a~%" (get-option '$xyplane
)))
3158 (if (get-option '$colorbox
)
3159 (format nil
"set colorbox~%")
3160 (format nil
"unset colorbox~%"))
3161 (format nil
"set cblabel '~a'~%"
3162 (if (stringp (get-option '$colorbox
))
3163 (get-option '$colorbox
)
3165 (write-palette-code)
3166 (if (not (string= (get-option '$user_preamble
) ""))
3167 (format nil
"~a~%" (get-option '$user_preamble
))) ))
3169 (setf *allocations
* (cons (get-option '$allocation
) *allocations
*))
3170 ; scene description: (dimensions, gnuplot preamble in string format, list of objects)
3173 plotcmd
; gnuplot preamble
3174 objects
; list of objects to be plotted
3183 (defmacro write-subarray
(arr str
)
3187 #'concatenate
'string
3190 #'(lambda (z) (format nil
"~a " z
))
3195 (defun draw_gnuplot (&rest args
)
3196 (ini-global-options)
3198 (setf *allocations
* nil
)
3200 (scenes-list '((mlist simp
))) ; these two variables will be used
3201 gfn
; gnuplot_file_name
3202 dfn
; data_file_name
3203 scene-short-description
; to build the text output
3205 cmdstorage
; file maxout.gnuplot
3206 datastorage
; file data.gnuplot
3207 datapath
; path to data.gnuplot
3209 nrows width height
; multiplot parameters
3210 isanimatedgif ismultipage is1stobj biglist grouplist largs
)
3212 (setf largs
(listify-arguments args
))
3214 (cond ((equal ($op x
) "=")
3216 ($terminal
(update-gr-option '$terminal
($rhs x
)))
3217 ($columns
(update-gr-option '$columns
($rhs x
)))
3218 ($dimensions
(update-gr-option '$dimensions
($rhs x
)))
3219 ($file_name
(update-gr-option '$file_name
($rhs x
)))
3220 ($gnuplot_file_name
(update-gr-option '$gnuplot_file_name
($rhs x
)))
3221 ($data_file_name
(update-gr-option '$data_file_name
($rhs x
)))
3222 ($delay
(update-gr-option '$delay
($rhs x
)))
3224 ; deprecated global options
3225 ($file_bgcolor
(update-gr-option '$file_bgcolor
($rhs x
)))
3226 ($pic_width
(update-gr-option '$pic_width
($rhs x
)))
3227 ($pic_height
(update-gr-option '$pic_height
($rhs x
)))
3228 ($eps_width
(update-gr-option '$eps_width
($rhs x
)))
3229 ($eps_height
(update-gr-option '$eps_height
($rhs x
)))
3230 ($pdf_width
(update-gr-option '$pdf_width
($rhs x
)))
3231 ($pdf_height
(update-gr-option '$pdf_height
($rhs x
)))
3233 (otherwise (merror "draw: unknown global option ~M " ($lhs x
)))))
3234 ((equal (caar x
) '$gr3d
)
3235 (setf scenes
(append scenes
(list (funcall #'make-scene-3d
(rest x
))))))
3236 ((equal (caar x
) '$gr2d
)
3237 (setf scenes
(append scenes
(list (funcall #'make-scene-2d
(rest x
))))))
3239 (merror "draw: item ~M is not recognized" x
))) )
3241 (equal (get-option '$terminal
) '$animated_gif
))
3243 (member (get-option '$terminal
)
3244 '($multipage_pdf $multipage_pdfcairo $multipage_eps $multipage_eps_color
)))
3247 gfn
(plot-temp-file (get-option '$gnuplot_file_name
) t
)
3248 dfn
(plot-temp-file (get-option '$data_file_name
) t
))
3250 ;; we now create two files: maxout.gnuplot and data.gnuplot
3253 #+sbcl
(sb-ext:native-namestring gfn
)
3255 :direction
:output
:if-exists
:supersede
))
3256 (if (eql cmdstorage nil
)
3257 (merror "draw: Cannot create file '~a'. Probably maxima_tempdir doesn't point to a writable directory." gfn
))
3260 #+sbcl
(sb-ext:native-namestring dfn
)
3262 :direction
:output
:if-exists
:supersede
))
3263 (if (eql datastorage nil
)
3264 (merror "draw: Cannot create file '~a'. Probably maxima_tempdir doesn't point to a writable directory." dfn
))
3266 (setf datapath
(format nil
"'~a'" dfn
))
3267 ; when one multiplot window is active, change of terminal is not allowed
3268 (if (not *multiplot-is-active
*)
3269 (case (get-option '$terminal
)
3270 ($dumb
(format cmdstorage
"set terminal dumb size ~a, ~a"
3271 (round (/ (first (get-option '$dimensions
)) 10))
3272 (round (/ (second (get-option '$dimensions
)) 10))))
3273 ($dumb_file
(format cmdstorage
"set terminal dumb size ~a, ~a~%set out '~a.dumb'"
3274 (round (/ (first (get-option '$dimensions
)) 10))
3275 (round (/ (second (get-option '$dimensions
)) 10))
3276 (get-option '$file_name
)))
3277 ($canvas
(format cmdstorage
"set terminal canvas enhanced ~a size ~a, ~a~%set out '~a.html'"
3279 (round (first (get-option '$dimensions
)))
3280 (round (second (get-option '$dimensions
)))
3281 (get-option '$file_name
)))
3282 ($png
(format cmdstorage
"set terminal png enhanced truecolor ~a size ~a, ~a~%set out '~a.png'"
3284 (round (first (get-option '$dimensions
)))
3285 (round (second (get-option '$dimensions
)))
3286 (get-option '$file_name
) ) )
3287 ($pngcairo
(format cmdstorage
"set terminal pngcairo dashed enhanced truecolor ~a size ~a, ~a~%set out '~a.png'"
3289 (round (first (get-option '$dimensions
)))
3290 (round (second (get-option '$dimensions
)))
3291 (get-option '$file_name
) ) )
3292 (($eps $multipage_eps
) (format cmdstorage
"set terminal postscript dashed eps enhanced ~a size ~acm, ~acm~%set out '~a.eps'"
3294 (/ (first (get-option '$dimensions
)) 100.0)
3295 (/ (second (get-option '$dimensions
)) 100.0)
3296 (get-option '$file_name
)))
3297 (($eps_color $multipage_eps_color
) (format cmdstorage
"set terminal postscript dashed eps enhanced ~a color size ~acm, ~acm~%set out '~a.eps'"
3299 (/ (first (get-option '$dimensions
)) 100.0)
3300 (/ (second (get-option '$dimensions
)) 100.0)
3301 (get-option '$file_name
)))
3302 ($epslatex
(format cmdstorage
"set terminal epslatex ~a color size ~acm, ~acm~%set out '~a.tex'"
3304 (/ (first (get-option '$dimensions
)) 100.0)
3305 (/ (second (get-option '$dimensions
)) 100.0)
3306 (get-option '$file_name
)))
3307 ($epslatex_standalone
(format cmdstorage
"set terminal epslatex dashed standalone ~a color size ~acm, ~acm~%set out '~a.tex'"
3309 (/ (first (get-option '$dimensions
)) 100.0)
3310 (/ (second (get-option '$dimensions
)) 100.0)
3311 (get-option '$file_name
)))
3312 (($pdf $multipage_pdf
) (format cmdstorage
"set terminal pdf dashed enhanced ~a color size ~acm, ~acm~%set out '~a.pdf'"
3314 (/ (first (get-option '$dimensions
)) 100.0)
3315 (/ (second (get-option '$dimensions
)) 100.0)
3316 (get-option '$file_name
)))
3317 (($pdfcairo $multipage_pdfcairo
) (format cmdstorage
"set terminal pdfcairo dashed enhanced ~a color size ~acm, ~acm~%set out '~a.pdf'"
3319 (/ (first (get-option '$dimensions
)) 100.0)
3320 (/ (second (get-option '$dimensions
)) 100.0)
3321 (get-option '$file_name
)))
3322 ($jpg
(format cmdstorage
"set terminal jpeg enhanced ~a size ~a, ~a~%set out '~a.jpg'"
3324 (round (first (get-option '$dimensions
)))
3325 (round (second (get-option '$dimensions
)))
3326 (get-option '$file_name
)))
3327 ($gif
(format cmdstorage
"set terminal gif enhanced ~a size ~a, ~a~%set out '~a.gif'"
3329 (round (first (get-option '$dimensions
)))
3330 (round (second (get-option '$dimensions
)))
3331 (get-option '$file_name
)))
3332 ($svg
(format cmdstorage
"set terminal svg dashed enhanced ~a size ~a, ~a~%set out '~a.svg'"
3334 (round (first (get-option '$dimensions
)))
3335 (round (second (get-option '$dimensions
)))
3336 (get-option '$file_name
)))
3337 ($animated_gif
(format cmdstorage
"set terminal gif enhanced animate ~a size ~a, ~a delay ~a~%set out '~a.gif'"
3339 (round (first (get-option '$dimensions
)))
3340 (round (second (get-option '$dimensions
)))
3341 (get-option '$delay
)
3342 (get-option '$file_name
)))
3343 ($aquaterm
(format cmdstorage
"set terminal aqua enhanced ~a ~a size ~a ~a~%"
3344 *draw-terminal-number
*
3346 (round (first (get-option '$dimensions
)))
3347 (round (second (get-option '$dimensions
)))))
3348 ($wxt
(format cmdstorage
"set terminal wxt dashed enhanced ~a ~a size ~a, ~a~%"
3349 *draw-terminal-number
*
3351 (round (first (get-option '$dimensions
)))
3352 (round (second (get-option '$dimensions
)))))
3353 ($qt
(format cmdstorage
"set terminal qt dashed enhanced ~a ~a size ~a, ~a~%"
3354 *draw-terminal-number
*
3356 (round (first (get-option '$dimensions
)))
3357 (round (second (get-option '$dimensions
)))))
3358 ($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}~%"
3359 *draw-terminal-number
*
3361 (round (first (get-option '$dimensions
)))
3362 (round (second (get-option '$dimensions
)))
3363 *draw-terminal-number
*
3365 (round (first (get-option '$dimensions
)))
3366 (round (second (get-option '$dimensions
)))))
3367 ($windows
(format cmdstorage
"set terminal windows enhanced ~a ~a size ~a, ~a~%"
3368 *draw-terminal-number
*
3370 (round (first (get-option '$dimensions
)))
3371 (round (second (get-option '$dimensions
)))))
3374 ;; If we arrive here, (get-option '$terminal) returned something
3375 ;; unrecognized; at present (commit ccd8074, 2020-12-07) the following
3376 ;; are accepted by UPDATE-TERMINAL, but not handled here: $obj $ply
3377 ;; $pnm $screen $stl $tiff $vrml
3378 (unless (eq (get-option '$terminal
) '$screen
)
3379 (mtell "draw: warning: I don't know about terminal '~m'; I'll try to restore the default.~%" (get-option '$terminal
))
3380 (mtell "draw: try this: set_draw_defaults(terminal = <something>);~%"))
3382 (format cmdstorage
"set terminal GNUTERM ~a ~a size ~a, ~a~%"
3383 *draw-terminal-number
*
3385 (round (first (get-option '$dimensions
)))
3386 (round (second (get-option '$dimensions
)))))))
3388 ; compute some parameters for multiplot
3389 (when (and (not isanimatedgif
) (not ismultipage
))
3390 (setf ncols
(get-option '$columns
))
3391 (setf nrows
(ceiling (/ (length scenes
) ncols
)))
3392 (if (> (length scenes
) 1)
3393 (format cmdstorage
"~%set size 1.0, 1.0~%set origin 0.0, 0.0~%set multiplot~%")) )
3395 ; Make gnuplot versions newer than 5.0 understand that linetype means
3396 ; we try to set the dash type
3397 (format cmdstorage
"~%if(GPVAL_VERSION >= 5.0){set for [i=1:8] linetype i dashtype i; set format '%h'}")
3399 ;; By default gnuplot assumes everything below 1e-8 to be a rounding error
3400 ;; and rounds it down to 0. This is handy for standalone gnuplot as it allows
3401 ;; to suppress pixels with imaginary part while allowing for small calculation
3402 ;; errors. As plot and draw handle the imaginary part without gnuplot's help
3403 ;; this isn't needed here and is turned off as it often surprises users.
3404 (format cmdstorage
"~%set zero 0.0")
3406 ; We use whitespace as a separator, so override any datafile separator
3407 ; the user has set. The user could have set the separator to a comma
3408 ; for reading CSV files, for example.
3409 (format cmdstorage
"~%set datafile separator whitespace")
3411 ; write descriptions of 2d and 3d scenes
3413 (alloc (reverse *allocations
*))
3415 thisalloc origin1 origin2 size1 size2
)
3417 ; recalculate nrows for automatic scene allocations
3418 (setf nrows
(ceiling (/ (count nil alloc
) ncols
)))
3421 (setf width
(/ 1.0 ncols
)
3422 height
(/ 1.0 nrows
)))
3423 (dolist (scn scenes
)
3424 ; write size and origin if necessary
3425 (cond ((or isanimatedgif ismultipage
)
3426 (format cmdstorage
"~%set size 1.0, 1.0~%")
3427 (format cmdstorage
"set obj 1 rectangle behind from screen 0.0,0.0 to screen 1.0,1.0~%") )
3428 (t ; it's not an animated gif
3429 (setf thisalloc
(car alloc
))
3430 (setf alloc
(cdr alloc
))
3432 (thisalloc ; user defined scene allocation
3433 (setf origin1
(first thisalloc
)
3434 origin2
(second thisalloc
)
3435 size1
(third thisalloc
)
3436 size2
(fourth thisalloc
)))
3437 (t ; automatic scene allocation
3438 (setf origin1
(* width
(mod nilcounter ncols
))
3439 origin2
(* height
(- nrows
1.0 (floor (/ nilcounter ncols
))))
3443 (format cmdstorage
"~%set size ~a, ~a~%" size1 size2
)
3444 (format cmdstorage
"set origin ~a, ~a~%" origin1 origin2
)
3445 (unless (or *multiplot-is-active
*
3446 (member (get-option '$terminal
) '($epslatex $epslatex_standalone
)))
3447 (format cmdstorage
"set obj 1 rectangle behind from screen ~a,~a to screen ~a,~a~%"
3448 origin1 origin2
(+ origin1 size1
) (+ origin2 size2
))) ))
3452 (format cmdstorage
"~a" (second scn
))
3453 (cond ((= (first scn
) 2) ; it's a 2d scene
3454 (setf scene-short-description
'(($gr2d simp
)))
3455 (format cmdstorage
"plot "))
3456 ((= (first scn
) 3) ; it's a 3d scene
3457 (setf scene-short-description
'(($gr3d simp
)))
3458 (format cmdstorage
"splot ")))
3459 (dolist (obj (third scn
))
3460 (setf scene-short-description
3461 (cons (gr-object-name obj
) scene-short-description
))
3464 (format cmdstorage
", \\~%") )
3465 (let ((pcom (gr-object-command obj
)))
3469 (format cmdstorage
"~a~a~a~a"
3471 (format nil
" index ~a" (incf i
))
3476 (t (format cmdstorage
"~a~a~a"
3478 (format nil
" index ~a" (incf i
))
3480 (setf grouplist
(append grouplist
(gr-object-groups obj
)))
3481 (setf biglist
(append biglist
(gr-object-points obj
))) )
3483 ; let's write data in data.gnuplot
3484 (do ( (blis biglist
(cdr blis
))
3485 (glis grouplist
(cdr glis
) ))
3487 (let* ((vect (car blis
))
3492 (non-numeric-region nil
)
3495 ((= m
0) ; no blank lines
3496 (do ((cont 0 (+ cont ncol
)))
3498 (setf coordinates
(subseq vect cont
(+ cont ncol
)))
3499 ; control of non numeric y values,
3500 ; code related to draw_realpart
3503 (when (numberp (aref coordinates
1))
3504 (setf non-numeric-region nil
)
3505 (write-subarray coordinates datastorage
) ))
3508 ((numberp (aref coordinates
1))
3509 (write-subarray coordinates datastorage
))
3511 (setf non-numeric-region t
)
3512 (format datastorage
"~%")))))) )
3514 (t ; blank lines every m lines
3515 (do ((cont 0 (+ cont ncol
)))
3518 (format datastorage
"~%")
3520 (write-subarray (subseq vect cont
(+ cont ncol
)) datastorage
)
3522 (format datastorage
"~%~%") )
3524 (setf scenes-list
(cons (reverse scene-short-description
) scenes-list
)) )) ; end let-dolist scenes
3527 (cond ((or isanimatedgif ismultipage
) ; this is an animated gif or multipage plot file
3529 (format cmdstorage
"~%unset output~%quit~%~%")
3530 (format cmdstorage
"~%set term dumb~%~%") )
3532 #+(or (and sbcl win32
) (and sbcl win64
) (and ccl windows
))
3533 ($system $gnuplot_command gfn
)
3534 #-
(or (and sbcl win32
) (and sbcl win64
) (and ccl windows
))
3535 ($system
(format nil
"~a \"~a\""
3538 (t ; non animated gif
3539 ; command file maxout.gnuplot is now ready
3540 (format cmdstorage
"~%")
3541 (cond ((> (length scenes
) 1)
3542 (format cmdstorage
"unset multiplot~%unset output ~%"))
3543 ; if we want to save the coordinates in a file,
3544 ; print them when hitting the x key after clicking the mouse button
3545 ((not (string= (get-option '$xy_file
) ""))
3547 "set print \"~a\" append~%bind x \"print MOUSE_X,MOUSE_Y\"~%"
3548 (get-option '$xy_file
))) )
3550 ; in svg and pdfcairo terminals it is necessary to unset output to force
3551 ; Gnuplot to write the last few bytes ("</svg>" in the svg case)
3552 ; at the end of the file. On windows in all other terminals that write
3553 ; to files if the output isn't unset the file isn't closed and therefore
3554 ; cannot be moved or removed after a plot is finished.
3556 ; If the plot isn't written to a file the variable "output" is empty and
3557 ; unused and unsetting it a second time doesn't change anything
3558 ; => It is always save to unset the output at the end of a scene.
3559 (when (not *multiplot-is-active
*) ; not in a one window multiplot
3560 (format cmdstorage
"unset output~%"))
3564 ; connect to gnuplot via pipes
3565 ((and (member (get-option '$terminal
) '($screen $aquaterm $wxt $x11 $qt $windows
))
3566 (equal $draw_renderer
'$gnuplot_pipes
))
3567 (check-gnuplot-process)
3568 (when (not *multiplot-is-active
*) ; not in a one window multiplot
3569 (send-gnuplot-command "unset output"))
3570 (send-gnuplot-command "reset")
3571 (send-gnuplot-command
3572 (format nil
"load '~a'" gfn
)))
3573 ; call gnuplot via system command
3576 #+(or (and sbcl win32
) (and sbcl win64
) (and ccl windows
))
3577 (if (member (get-option '$terminal
) '($screen $aquaterm $wxt $x11 $qt $windows
))
3578 ($system $gnuplot_command
"-persist" gfn
)
3579 ($system $gnuplot_command gfn
))
3580 #-
(or (and sbcl win32
) (and sbcl win64
) (and ccl windows
))
3581 ($system
(if (member (get-option '$terminal
) '($screen $aquaterm $wxt $x11 $qt $windows
))
3584 (format nil $gnuplot_view_args gfn
))
3585 (format nil
"~a \"~a\""
3589 ; the output is a simplified description of the scene(s)
3590 (reverse scenes-list
)) )
3593 ;; This function transforms an integer number into
3594 ;; a string, adding zeros at the left side until the
3595 ;; length of the string equals 10. This function is
3596 ;; useful to name a sequence of frames.
3597 (defun $add_zeroes
(num)
3598 (format nil
"~10,'0d" ($sconcat num
)) )
3601 ;; copies current plot in window into a file
3602 (defun $draw_file
(&rest opts
)
3605 (if (equal ($op x
) "=")
3606 (update-gr-option ($lhs x
) ($rhs x
))
3607 (merror "draw: item ~M is not recognized as an option assignment" x
)))
3608 (case (get-option '$terminal
)
3609 ($canvas
(setf str
(format nil
"set terminal canvas enhanced ~a size ~a, ~a~%set out '~a.html'"
3611 (round (first (get-option '$dimensions
)))
3612 (round (second (get-option '$dimensions
)))
3613 (get-option '$file_name
))))
3614 ($png
(setf str
(format nil
"set terminal png enhanced truecolor ~a size ~a, ~a~%set out '~a.png'"
3616 (round (first (get-option '$dimensions
)))
3617 (round (second (get-option '$dimensions
)))
3618 (get-option '$file_name
) ) ))
3619 ($pngcairo
(setf str
(format nil
"set terminal pngcairo dashed enhanced truecolor ~a size ~a, ~a~%set out '~a.png'"
3621 (round (first (get-option '$dimensions
)))
3622 (round (second (get-option '$dimensions
)))
3623 (get-option '$file_name
) ) ))
3624 ($eps
(setf str
(format nil
"set terminal postscript dashed eps enhanced ~a size ~acm, ~acm~%set out '~a.eps'"
3625 (write-font-type) ; other alternatives are Arial, Courier
3626 (/ (first (get-option '$dimensions
)) 100.0)
3627 (/ (second (get-option '$dimensions
)) 100.0)
3628 (get-option '$file_name
))))
3629 ($epslatex
(format str
"set terminal epslatex ~a color dashed size ~acm, ~acm~%set out '~a.tex'"
3631 (/ (first (get-option '$dimensions
)) 100.0)
3632 (/ (second (get-option '$dimensions
)) 100.0)
3633 (get-option '$file_name
)))
3634 ($epslatex_standalone
(format str
"set terminal epslatex dashed standalone ~a color size ~acm, ~acm~%set out '~a.tex'"
3636 (/ (first (get-option '$dimensions
)) 100.0)
3637 (/ (second (get-option '$dimensions
)) 100.0)
3638 (get-option '$file_name
)))
3639 ($eps_color
(setf str
(format nil
"set terminal postscript dashed eps enhanced ~a color size ~acm, ~acm~%set out '~a.eps'"
3641 (/ (first (get-option '$dimensions
)) 100.0)
3642 (/ (second (get-option '$dimensions
)) 100.0)
3643 (get-option '$file_name
))))
3644 ($pdf
(setf str
(format nil
"set terminal pdf dashed enhanced ~a color size ~acm, ~acm~%set out '~a.pdf'"
3646 (/ (first (get-option '$dimensions
)) 100.0)
3647 (/ (second (get-option '$dimensions
)) 100.0)
3648 (get-option '$file_name
))))
3649 ($pdfcairo
(setf str
(format nil
"set terminal pdfcairo dashed enhanced ~a color size ~acm, ~acm~%set out '~a.pdf'"
3651 (/ (first (get-option '$dimensions
)) 100.0)
3652 (/ (second (get-option '$dimensions
)) 100.0)
3653 (get-option '$file_name
))))
3654 ($jpg
(setf str
(format nil
"set terminal jpeg ~a size ~a, ~a~%set out '~a.jpg'"
3656 (round (first (get-option '$dimensions
)))
3657 (round (second (get-option '$dimensions
)))
3658 (get-option '$file_name
))))
3659 ($gif
(setf str
(format nil
"set terminal gif ~a size ~a, ~a~%set out '~a.gif'"
3661 (round (first (get-option '$dimensions
)))
3662 (round (second (get-option '$dimensions
)))
3663 (get-option '$file_name
))))
3664 ($svg
(setf str
(format nil
"set terminal svg dashed enhanced ~a size ~a, ~a~%set out '~a.svg'"
3666 (round (first (get-option '$dimensions
)))
3667 (round (second (get-option '$dimensions
)))
3668 (get-option '$file_name
))))
3669 (otherwise (merror "draw: not a file format")))
3670 (send-gnuplot-command (format nil
"~a~%replot~%unset output~%" str
)) ))
3673 ;; When working with multiple windows, for example
3674 ;; terminal = [wxt, 5], only the newest window is active.
3675 ;; This function activates any other previous window at will.
3676 (defun $activate_window
(term num
)
3677 (when (or (not (member term
'($screen $wxt $aquaterm
)))
3678 (not (integerp num
))
3680 (merror "draw: Incorrect terminal or window number"))
3683 ($wxt
(setf str
"wxt"))
3684 ($aquaterm
(setf str
"aquaterm"))
3685 ($qt
(setf str
"qt"))
3686 (otherwise (setf str
"GNUTERM")))
3687 (send-gnuplot-command (format nil
"set terminal ~a ~a~%" str num
)) ))
