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)
35 (defun extrema-over-finite-floats-list (x)
36 (let ((xmax most-negative-double-float
) (xmin most-positive-double-float
))
38 do
(when (and (realp x1
) (not (float-inf-p x1
)) (not (float-nan-p x1
)))
39 (when (< x1 xmin
) (setq xmin x1
))
40 (when (> x1 xmax
) (setq xmax x1
))))
44 (defun finite-real-p (x)
45 (and (realp x
) (not (float-nan-p x
)) (not (float-inf-p x
))))
48 (defun write-font-type ()
49 (if (and (string= (get-option '$font
) "") (not (eql (get-option '$font_size
) 10)))
50 (mwarning "Cannot set the gnuplot font size without a font name."))
52 (if (or (eq (get-option '$font
) nil
) (string= (get-option '$font
) ""))
54 (format nil
"font '~a,~a'" (get-option '$font
) (get-option '$font_size
))))
57 ;; one-window multiplot: consecutive calls
58 ;; to draw always plot on the same window
59 (defvar *multiplot-is-active
* nil
)
60 (defun $multiplot_mode
(term)
63 ($multiplot_mode
'$none
)
65 (format nil
"set terminal GNUTERM dashed ~a~%set multiplot~%" (write-font-type)))
66 (setf *multiplot-is-active
* t
))
68 ($multiplot_mode
'$none
)
70 (format nil
"set terminal wxt dashed ~a~%set multiplot~%" (write-font-type)))
71 (setf *multiplot-is-active
* t
))
73 ($multiplot_mode
'$none
)
75 (format nil
"set terminal qt dashed ~a~%set multiplot~%" (write-font-type)))
76 (setf *multiplot-is-active
* t
))
78 ($multiplot_mode
'$none
)
80 (format nil
"set terminal windows dashed ~a~%set multiplot~%" (write-font-type)))
81 (setf *multiplot-is-active
* t
))
84 (format nil
"unset multiplot~%unset output~%"))
85 (setf *multiplot-is-active
* nil
))
87 (merror "draw: ~M is not recognized as a multiplot mode" term
))))
91 ;; This function is called from the graphic objects constructors
92 ;; (points, rectangle, etc.). When a new object is created, and if
93 ;; the user hasn't especified an x or y range, ranges are computed
94 ;; automatically by calling this function. There is a trick so
95 ;; that object constructors know if they can modify global variables
96 ;; xrange and yrange; if these lists are of length 2, it means that
97 ;; it was a user selection and they can't be altered; if they are of
98 ;; length 3 (with a dummy 0), object constructors should make the necessary changes
99 ;; to fit the objects in the window; if they are nil, default
100 ;; value, constructors are also allowed to make changes.
101 (defmacro update-range
(axi vmin vmax
)
102 `(case (length (get-option ,axi
))
103 (0 (setf (gethash ,axi
*gr-options
*) (list ,vmin
,vmax
0)))
104 (3 (setf (gethash ,axi
*gr-options
*) (list (min ,vmin
(first (get-option ,axi
)))
105 (max ,vmax
(second (get-option ,axi
)))
108 (defun update-ranges-2d (xmin xmax ymin ymax
)
109 (if (get-option '$xaxis_secondary
)
110 (update-range '$xrange_secondary xmin xmax
)
111 (update-range '$xrange xmin xmax
))
112 (if (get-option '$yaxis_secondary
)
113 (update-range '$yrange_secondary ymin ymax
)
114 (update-range '$yrange ymin ymax
)) )
116 (defun update-ranges-3d (xmin xmax ymin ymax zmin zmax
)
117 (update-ranges-2d xmin xmax ymin ymax
)
118 (update-range '$zrange zmin zmax
))
120 (defmacro check-extremes-x
()
121 '(when (finite-real-p xx
)
122 (when (< xx xmin
) (setf xmin xx
))
123 (when (> xx xmax
) (setf xmax xx
))))
125 (defmacro check-extremes-y
()
126 '(when (finite-real-p yy
)
127 (when (< yy ymin
) (setf ymin yy
))
128 (when (> yy ymax
) (setf ymax yy
))))
130 (defmacro check-extremes-z
()
131 '(when (finite-real-p zz
)
132 (when (< zz zmin
) (setf zmin zz
))
133 (when (> zz zmax
) (setf zmax zz
))))
135 ;; Controls whether the actual graphics object must
136 ;; be plotted against the primary or the secondary axes,
137 ;; both horizontal and vertical. Secondary axes in 3D
138 ;; are not yet supported.
139 (defun axes-to-plot ()
141 (if (get-option '$xaxis_secondary
)
144 (if (get-option '$yaxis_secondary
)
149 name command groups points
)
151 (defun make-obj-title (str)
152 (if (= (length str
) 0)
154 (if (> (length str
) 80)
155 (concatenate 'string
"t '" (subseq str
0 75) " ...'")
156 (concatenate 'string
"t '" str
"'"))))
164 ;; errors([[x1,y1,...], [x2,y2,...], [x3,y3,...],...])
175 (defun-checked errors
(arg)
176 (let ((etype (get-option '$error_type
))
177 (joined (get-option '$points_joined
))
179 pts pltcmd grouping xmin xmax ymin ymax with
)
180 (if (and ($listp arg
)
181 (every #'$listp
(rest arg
)))
182 (setf element-size
(length (cdadr arg
)))
183 (merror "draw (errors object): incorrect input format"))
184 (unless (every #'(lambda (z) (= element-size
($length z
))) (rest arg
))
185 (merror "draw (errors object): lists of different sizes"))
186 ; create plot command
187 (cond ((and (eql etype
'$x
)
188 (or (= element-size
3)
191 (setf with
"xerrorbars")
192 (setf with
"xerrorlines")) )
193 ((and (eql etype
'$y
)
194 (or (= element-size
3)
197 (setf with
"yerrorbars")
198 (setf with
"yerrorlines")) )
199 ((and (eql etype
'$xy
)
200 (or (= element-size
4)
203 (setf with
"xyerrorbars")
204 (setf with
"xyerrorlines")) )
205 ((and (eql etype
'$boxes
)
206 (or (= element-size
4)
208 (setf with
"boxxyerrorbars") )
210 (merror "draw (errors object): incompatibility with option error_type")))
212 (setf grouping
`((,element-size
0)))
215 " ~a w ~a ~a lw ~a lt ~a lc ~a axis ~a"
216 (make-obj-title (get-option '$key
))
218 (if (eql etype
'$boxes
) ; in case of boxes, should they be filled? Default is "not filled".
219 (format nil
"fs solid ~a" (or (get-option '$fill_density
) 0))
221 (get-option '$line_width
)
222 (get-option '$line_type
)
223 (hex-to-rgb (get-option '$color
))
225 (setf pts
(map 'list
#'rest
(rest ($float arg
))))
226 (let ((x (map 'list
#'first pts
))
227 (y (map 'list
#'second pts
)))
228 (setf xmin
($tree_reduce
'min
(cons '(mlist simp
) x
))
229 xmax
($tree_reduce
'max
(cons '(mlist simp
) x
))
230 ymin
($tree_reduce
'min
(cons '(mlist simp
) y
))
231 ymax
($tree_reduce
'max
(cons '(mlist simp
) y
))))
232 (update-ranges-2d xmin xmax ymin ymax
)
237 :points
(list (make-array (* element-size
(length pts
))
238 :element-type
'flonum
239 :initial-contents
(flatten pts
)))) ))
248 ;; points([[x1,y1], [x2,y2], [x3,y3],...])
249 ;; points([x1,x2,x3,...], [y1,y2,y3,...])
250 ;; points([y1,y2,y3,...]), abscissas are automatically chosen: 1,2,3,...
251 ;; points(matrix), one-column, one-row, two-column or two-row matrix
253 ;; points(array1d, array1d)
254 ;; points(array2d), two-column or two-row array
266 (defun points-command ()
267 (let ((pj (get-option '$points_joined
))
268 (ps (get-option '$point_size
))
269 (pt (get-option '$point_type
)) )
271 ((null pj
) ; draws isolated points
272 (format nil
" ~a w p ps ~a pt ~a lc ~a axis ~a"
273 (make-obj-title (get-option '$key
))
276 (hex-to-rgb (get-option '$color
))
278 ((and (eq pj t
) (or (= ps
0.0) (= pt
0)) ) ; draws joined points without symbols
279 (format nil
" ~a w l lw ~a lt ~a lc ~a axis ~a"
280 (make-obj-title (get-option '$key
))
281 (get-option '$line_width
)
282 (get-option '$line_type
)
283 (hex-to-rgb (get-option '$color
))
285 ((eq pj t
) ; draws joined points
286 (format nil
" ~a w lp ps ~a pt ~a lw ~a lt ~a lc ~a axis ~a"
287 (make-obj-title (get-option '$key
))
290 (get-option '$line_width
)
291 (get-option '$line_type
)
292 (hex-to-rgb (get-option '$color
))
295 (format nil
" ~a w i lw ~a lt ~a lc ~a axis ~a"
296 (make-obj-title (get-option '$key
))
297 (get-option '$line_width
)
299 (hex-to-rgb (get-option '$color
))
302 (defun points-array-2d (arg)
303 (let ((xmin most-positive-double-float
)
304 (xmax most-negative-double-float
)
305 (ymin most-positive-double-float
)
306 (ymax most-negative-double-float
)
308 (dim (array-dimensions arg
))
309 n xx yy pts twocolumns
)
311 ((and (= (length dim
) 2) ; two-column array
315 ((and (= (length dim
) 2) ; two-row array
318 (setf twocolumns nil
))
319 (t (merror "draw (points2d): bad 2d array input format")))
320 (setf pts
(make-array (* 2 n
) :element-type t
))
321 (loop for k below n do
323 (setf xx
($float
(aref arg k
0))
324 yy
($float
(aref arg k
1)))
325 (setf xx
($float
(aref arg
0 k
))
326 yy
($float
(aref arg
1 k
))))
330 (setf (aref pts
(incf pos
)) xx
)
331 (setf (aref pts
(incf pos
)) yy
))
332 (update-ranges-2d xmin xmax ymin ymax
)
335 :command
(points-command)
336 :groups
'((2 0)) ; numbers are sent to gnuplot in groups of 2
337 :points
(list pts
))))
339 (defun points-array-1d (arg1 &optional
(arg2 nil
))
340 (let ((xmin most-positive-double-float
)
341 (xmax most-negative-double-float
)
342 (ymin most-positive-double-float
)
343 (ymax most-negative-double-float
)
345 (dim (array-dimensions arg1
))
349 (= (length dim
) 1)) ; y format
351 (setf x
(make-array n
353 :initial-contents
(loop for k from
1 to n collect
($float k
)) ))
354 (setf y
(make-array n
356 :initial-contents
(loop for k below n collect
($float
(aref arg1 k
))))))
357 ((and (arrayp arg2
) ; xx yy format
359 (equal dim
(array-dimensions arg2
)))
363 (t (merror "draw (points2d): bad 1d array input format")))
364 (setf pts
(make-array (* 2 n
) :element-type t
))
365 (loop for k below n do
366 (setf xx
($float
(aref x k
))
367 yy
($float
(aref y k
)))
371 (setf (aref pts
(incf pos
)) xx
)
372 (setf (aref pts
(incf pos
)) yy
))
373 (update-ranges-2d xmin xmax ymin ymax
)
376 :command
(points-command)
377 :groups
'((2 0)) ; numbers are sent to gnuplot in groups of 2
378 :points
(list pts
))))
380 (defun points-list (arg1 &optional
(arg2 nil
))
381 (let (x y xmin xmax ymin ymax pts
)
385 (every #'$listp
(rest arg1
))) ; xy format
386 (let ((tmp (mapcar #'rest
(rest arg1
))))
387 (setf x
(map 'list
#'$float
(map 'list
#'first tmp
))
388 y
(map 'list
#'$float
(map 'list
#'second tmp
)))) )
389 ((and ($matrixp arg1
)
390 (= (length (cadr arg1
)) 3)
391 (null arg2
)) ; two-column matrix
392 (let ((tmp (mapcar #'rest
(rest arg1
))))
393 (setf x
(map 'list
#'$float
(map 'list
#'first tmp
))
394 y
(map 'list
#'$float
(map 'list
#'second tmp
)) ) ) )
397 (notany #'$listp
(rest arg1
))) ; y format
398 (setf x
(loop for xx from
1 to
(length (rest arg1
)) collect
($float xx
))
399 y
(map 'list
#'$float
(rest arg1
))))
400 ((and ($matrixp arg1
)
401 (= (length (cadr arg1
)) 2)
402 (null arg2
)) ; one-column matrix
403 (setf x
(loop for xx from
1 to
(length (rest arg1
)) collect
($float xx
))
404 y
(map 'list
#'$float
(map 'list
#'second
(rest arg1
)))))
405 ((and ($matrixp arg1
)
407 (null arg2
)) ; one-row matrix
408 (setf x
(loop for xx from
1 to
(length (cdadr arg1
)) collect
($float xx
))
409 y
(map 'list
#'$float
(cdadr arg1
))))
412 (= (length arg1
) (length arg2
))) ; xx yy format
413 (setf x
(map 'list
#'$float
(rest arg1
))
414 y
(map 'list
#'$float
(rest arg2
))))
415 ((and ($matrixp arg1
)
417 (null arg2
)) ; two-row matrix
418 (setf x
(map 'list
#'$float
(cdadr arg1
))
419 y
(map 'list
#'$float
(cdaddr arg1
))))
420 (t (merror "draw (points2d): incorrect input format")))
422 (multiple-value-setq (xmin xmax
) (extrema-over-finite-floats-list x
))
423 (multiple-value-setq (ymin ymax
) (extrema-over-finite-floats-list y
))
424 (setf pts
(make-array (* 2 (length x
)) :initial-contents
(mapcan #'list x y
)))
425 ;; update x-y ranges if necessary
426 (update-ranges-2d xmin xmax ymin ymax
)
429 :command
(points-command)
430 :groups
'((2 0)) ; numbers are sent to gnuplot in groups of 2
431 :points
(list pts
) ) ))
433 (defun-checked points
(arg1 &optional
(arg2 nil
))
435 (if (= (length (array-dimensions arg1
)) 2)
436 (points-array-2d arg1
)
437 (points-array-1d arg1 arg2
))
438 (points-list arg1 arg2
)))
446 ;; Object: 'points3d'
448 ;; points([[x1,y1,z1], [x2,y2,z2], [x3,y3,z3],...])
449 ;; points([x1,x2,x3,...], [y1,y2,y3,...], [z1,z2,z3,...])
450 ;; points(matrix), three-column or three-row matrix
451 ;; points(array2d), three-column or three-row array
452 ;; points(array1d, array1d, array1d, array1d)
463 (defun points3d-command ()
464 (let ((pj (get-option '$points_joined
))
465 (ps (get-option '$point_size
))
466 (pt (get-option '$point_type
))
467 (pal (if (> *draw-enhanced3d-type
* 0)
469 (hex-to-rgb (get-option '$color
)) )))
471 ((null pj
) ; draws isolated points
472 (format nil
" ~a w p ps ~a pt ~a lc ~a"
473 (make-obj-title (get-option '$key
))
477 ((and (eq pj t
) (or (= ps
0.0) (= pt
0)) ) ; draws joined points without symbols
478 (format nil
" ~a w l lw ~a lt ~a lc ~a "
479 (make-obj-title (get-option '$key
))
480 (get-option '$line_width
)
481 (get-option '$line_type
)
482 (hex-to-rgb (get-option '$color
))))
483 ((eq pj t
) ; draws joined points
484 (format nil
" ~a w lp ps ~a pt ~a lw ~a lt ~a lc ~a"
485 (make-obj-title (get-option '$key
))
488 (get-option '$line_width
)
489 (get-option '$line_type
)
492 (format nil
" ~a w i lw ~a lt ~a lc ~a"
493 (make-obj-title (get-option '$key
))
494 (get-option '$line_width
)
495 (get-option '$line_type
)
498 (defun-checked points3d
(arg1 &optional
(arg2 nil
) (arg3 nil
))
499 (let (pts x y z xmin xmax ymin ymax zmin zmax ncols col
)
500 (check-enhanced3d-model "points" '(0 1 3))
501 (cond (($listp arg1
) ; list input
502 (cond ((and (every #'$listp
(rest arg1
)) ; xyz format
505 (let ((tmp (mapcar #'rest
(rest arg1
))))
506 (setf x
(map 'list
#'$float
(map 'list
#'first tmp
))
507 y
(map 'list
#'$float
(map 'list
#'second tmp
))
508 z
(map 'list
#'$float
(map 'list
#'third tmp
)) ) ) )
509 ((and ($listp arg2
) ; xx yy zz format
511 (= (length arg1
) (length arg2
) (length arg3
)))
512 (setf x
(map 'list
#'$float
(rest arg1
))
513 y
(map 'list
#'$float
(rest arg2
))
514 z
(map 'list
#'$float
(rest arg3
)) ))
515 (t (merror "draw (points3d): bad list input format"))))
516 (($matrixp arg1
) ; matrix input
517 (cond ((and (= (length (cadr arg1
)) 4) ; three-column matrix
520 (let ((tmp (mapcar #'rest
(rest arg1
))))
521 (setf x
(map 'list
#'$float
(map 'list
#'first tmp
))
522 y
(map 'list
#'$float
(map 'list
#'second tmp
))
523 z
(map 'list
#'$float
(map 'list
#'third tmp
)) ) ) )
524 ((and (= ($length arg1
) 3) ; three-row matrix
527 (setf x
(map 'list
#'$float
(cdadr arg1
))
528 y
(map 'list
#'$float
(cdaddr arg1
))
529 z
(map 'list
#'$float
(cdaddr (rest arg1
)) ) ) )
530 (t (merror "draw (points3d): bad matrix input format"))))
531 ((arrayp arg1
) ; array input
532 (let ((dim (array-dimensions arg1
)))
533 (cond ((and (= (length dim
) 2) ; three-row array
537 (setf x
(loop for k from
0 below
(second dim
)
538 collect
($float
(aref arg1
0 k
)))
539 y
(loop for k from
0 below
(second dim
)
540 collect
($float
(aref arg1
1 k
)))
541 z
(loop for k from
0 below
(second dim
)
542 collect
($float
(aref arg1
2 k
))) ))
543 ((and (= (length dim
) 2) ; three-column array
547 (setf x
(loop for k from
0 below
(first dim
)
548 collect
($float
(aref arg1 k
0)))
549 y
(loop for k from
0 below
(first dim
)
550 collect
($float
(aref arg1 k
1)))
551 z
(loop for k from
0 below
(first dim
)
552 collect
($float
(aref arg1 k
2))) ))
553 ((and (= (length dim
) 1) ; three 1d arrays
556 (equal dim
(array-dimensions arg2
))
557 (equal dim
(array-dimensions arg3
)))
558 (setf x
(map 'list
#'$float arg1
)
559 y
(map 'list
#'$float arg2
)
560 z
(map 'list
#'$float arg3
) ) )
561 (t (merror "draw (points3d): bad array input format")) ) ) )
562 (t (merror "draw (points3d): bad input format")))
565 (cond ((= *draw-enhanced3d-type
* 0)
567 (setf pts
(make-array (* ncols
(length x
))
568 :element-type
'flonum
569 :initial-contents
(mapcan #'list x y z
))))
570 ((= *draw-enhanced3d-type
* 1)
571 (setf col
(loop for k from
1 to
(length x
)
572 collect
(funcall *draw-enhanced3d-fun
* k
)))
574 (setf pts
(make-array (* ncols
(length x
))
575 :element-type
'flonum
576 :initial-contents
(mapcan #'list x y z col
))))
577 ((= *draw-enhanced3d-type
* 3)
578 (setf col
(mapcar #'(lambda (xx yy zz
) (funcall *draw-enhanced3d-fun
* xx yy zz
)) x y z
))
580 (setf pts
(make-array (* ncols
(length x
))
581 :element-type
'flonum
582 :initial-contents
(mapcan #'list x y z col
)))) )
583 (setf xmin
($tree_reduce
'min
(cons '(mlist simp
) x
))
584 xmax
($tree_reduce
'max
(cons '(mlist simp
) x
))
585 ymin
($tree_reduce
'min
(cons '(mlist simp
) y
))
586 ymax
($tree_reduce
'max
(cons '(mlist simp
) y
))
587 zmin
($tree_reduce
'min
(cons '(mlist simp
) z
))
588 zmax
($tree_reduce
'max
(cons '(mlist simp
) z
)) )
589 ;; update x-y-y ranges if necessary
590 (update-ranges-3d xmin xmax ymin ymax zmin zmax
)
593 :command
(points3d-command)
594 :groups
`((,ncols
0)) ; numbers are sent to gnuplot in groups of 4 or 3
595 ; (depending on colored 4th dimension or not), without blank lines
596 :points
(list pts
) ) ))
605 ;; polygon([[x1,y1], [x2,y2], [x3,y3],...])
606 ;; polygon([x1,x2,x3,...], [y1,y2,y3,...])
619 (defun-checked polygon
(arg1 &optional
(arg2 nil
))
620 (if (and (get-option '$transparent
)
621 (not (get-option '$border
)))
622 (merror "draw (polygon): transparent is true and border is false; this is not consistent"))
623 (let (pltcmd pts grps x y xmin xmax ymin ymax
)
624 (cond ((and ($listp arg1
)
625 (every #'$listp
(rest arg1
))
626 (null arg2
) ) ; xy format
627 (let ((tmp (mapcar #'rest
(rest arg1
))))
628 (setf x
(map 'list
#'(lambda (z) ($float
(first z
))) tmp
)
629 y
(map 'list
#'(lambda (z) ($float
(second z
))) tmp
) ) ) )
632 (= (length arg1
) (length arg2
))) ; xx yy format
633 (setf x
(map 'list
#'$float
(rest arg1
))
634 y
(map 'list
#'$float
(rest arg2
))) )
635 (t (merror "draw (polygon): bad input format")) )
637 (setf xmin
($tree_reduce
'min
(cons '(mlist simp
) x
))
638 xmax
($tree_reduce
'max
(cons '(mlist simp
) x
))
639 ymin
($tree_reduce
'min
(cons '(mlist simp
) y
))
640 ymax
($tree_reduce
'max
(cons '(mlist simp
) y
)) )
641 ;; update x-y ranges if necessary
642 (update-ranges-2d xmin xmax ymin ymax
)
644 ((get-option '$transparent
) ; if transparent, draw only the border
645 (setf pltcmd
(format nil
" ~a w l lw ~a lt ~a lc ~a axis ~a"
646 (make-obj-title (get-option '$key
))
647 (get-option '$line_width
)
648 (get-option '$line_type
)
649 (hex-to-rgb (get-option '$color
))
651 (setf grps
'((2 0))) ; numbers are sent to gnuplot in groups of 2
652 (setf pts
(list (make-array (+ (* 2 (length x
)) 2)
653 :element-type
'flonum
654 :initial-contents
(append (mapcan #'list x y
)
655 (list (first x
) (first y
))) )) ) )
656 ((not (get-option '$border
)) ; no transparent, no border
657 (setf pltcmd
(format nil
" ~a w filledcurves~a lc ~a axis ~a"
658 (make-obj-title (get-option '$key
))
659 (format nil
"~@[ fillstyle solid ~a~]" (get-option '$fill_density
))
660 (hex-to-rgb (get-option '$fill_color
))
662 (setf grps
'((2 0))) ; numbers are sent to gnuplot in groups of 2
663 (setf pts
(list (make-array (* 2 (length x
))
664 :element-type
'flonum
665 :initial-contents
(mapcan #'list x y
)) ) ))
666 (t ; no transparent with border
667 (setf pltcmd
(list (format nil
" ~a w filledcurves~a lc ~a axis ~a"
668 (make-obj-title (get-option '$key
))
669 (format nil
"~@[ fillstyle solid ~a~]" (get-option '$fill_density
))
670 (hex-to-rgb (get-option '$fill_color
))
672 (format nil
" t '' w l lw ~a lt ~a lc ~a axis ~a"
673 (get-option '$line_width
)
674 (get-option '$line_type
)
675 (hex-to-rgb (get-option '$color
))
677 (setf grps
'((2 0) (2 0))) ; both sets of vertices (interior and border)
678 ; are sent to gnuplot in groups of 2
679 (setf pts
(list (make-array (* 2 (length x
))
680 :element-type
'flonum
681 :initial-contents
(mapcan #'list x y
))
682 (make-array (+ (* 2 (length x
)) 2)
683 :element-type
'flonum
684 :initial-contents
(append (mapcan #'list x y
)
685 (list (first x
) (first y
))))))))
698 ;; Object: 'triangle'
700 ;; triangle([x1,y1], [x2,y2], [x3,y3])
712 (defun-checked triangle
(arg1 arg2 arg3
)
713 (if (or (not ($listp arg1
))
714 (not (= ($length arg1
) 2))
716 (not (= ($length arg2
) 2))
718 (not (= ($length arg3
) 2)))
719 (merror "draw2d (triangle): vertices are not correct"))
720 (let* ((x1 ($float
(cadr arg1
)))
721 (y1 ($float
(caddr arg1
)))
722 (x2 ($float
(cadr arg2
)))
723 (y2 ($float
(caddr arg2
)))
724 (x3 ($float
(cadr arg3
)))
725 (y3 ($float
(caddr arg3
)))
726 (grobj (polygon `((mlist simp
)
727 ((mlist simp
) ,x1
,y1
)
728 ((mlist simp
) ,x2
,y2
)
729 ((mlist simp
) ,x3
,y3
)
730 ((mlist simp
) ,x1
,y1
)))))
731 (setf (gr-object-name grobj
) 'triangle
)
739 ;; Object: 'quadrilateral'
741 ;; quadrilateral([x1,y1], [x2,y2], [x3,y3], [x4,y4])
753 (defun-checked quadrilateral
(arg1 arg2 arg3 arg4
)
754 (if (or (not ($listp arg1
))
755 (not (= ($length arg1
) 2))
757 (not (= ($length arg2
) 2))
759 (not (= ($length arg3
) 2))
761 (not (= ($length arg4
) 2)))
762 (merror "draw2d (quadrilateral): vertices are not correct"))
763 (let* ((x1 ($float
(cadr arg1
)))
764 (y1 ($float
(caddr arg1
)))
765 (x2 ($float
(cadr arg2
)))
766 (y2 ($float
(caddr arg2
)))
767 (x3 ($float
(cadr arg3
)))
768 (y3 ($float
(caddr arg3
)))
769 (x4 ($float
(cadr arg4
)))
770 (y4 ($float
(caddr arg4
)))
771 (grobj (polygon `((mlist simp
)
772 ((mlist simp
) ,x1
,y1
)
773 ((mlist simp
) ,x2
,y2
)
774 ((mlist simp
) ,x3
,y3
)
775 ((mlist simp
) ,x4
,y4
)
776 ((mlist simp
) ,x1
,y1
)))))
777 (setf (gr-object-name grobj
) 'quadrilateral
)
786 ;; Object: 'rectangle'
788 ;; rectangle([x1,y1], [x2,y2]), being [x1,y1] & [x2,y2] opposite vertices
800 (defun-checked rectangle
(arg1 arg2
)
801 (if (or (not ($listp arg1
))
802 (not (= ($length arg1
) 2))
804 (not (= ($length arg2
) 2)))
805 (merror "draw2d (rectangle): vertices are not correct"))
806 (let* ((x1 ($float
(cadr arg1
)))
807 (y1 ($float
(caddr arg1
)))
808 (x2 ($float
(cadr arg2
)))
809 (y2 ($float
(caddr arg2
)))
810 (grobj (polygon `((mlist simp
)
811 ((mlist simp
) ,x1
,y1
)
812 ((mlist simp
) ,x2
,y1
)
813 ((mlist simp
) ,x2
,y2
)
814 ((mlist simp
) ,x1
,y2
)
815 ((mlist simp
) ,x1
,y1
)))))
816 (setf (gr-object-name grobj
) 'rectangle
)
827 ;; ellipse(xc, yc, a, b, ang1 ang2)
841 (defun-checked ellipse
(xc yc a b ang1 ang2
)
842 (if (and (get-option '$transparent
)
843 (not (get-option '$border
)))
844 (merror "draw2d (ellipse): transparent is true and border is false; this is not consistent"))
845 (let ((fxc ($float xc
))
849 (fang1 ($float ang1
))
850 (fang2 ($float ang2
))
851 (nticks (get-option '$nticks
))
852 (xmin most-positive-double-float
)
853 (xmax most-negative-double-float
)
854 (ymin most-positive-double-float
)
855 (ymax most-negative-double-float
)
857 pts grps tmin tmax eps xx yy tt pltcmd
)
858 (when (or (notevery #'floatp
(list fxc fyc fa fb fang1 fang2
))
861 (merror "draw (ellipse): illegal argument(s)"))
863 (setf fang1
(* 0.017453292519943295 fang1
)
864 fang2
(* 0.017453292519943295 fang2
))
865 (setf tmin
(min fang1
(+ fang1 fang2
))
866 tmax
(max fang1
(+ fang1 fang2
))
867 eps
(/ (- tmax tmin
) (- nticks
1)))
870 (setf xx
(+ fxc
(* fa
(cos tt
))))
871 (setf yy
(+ fyc
(* fb
(sin tt
))))
875 (setf result
(append (list xx yy
) result
))
876 (if (>= tt tmax
) (return))
878 (if (>= tt tmax
) (setq tt tmax
)) )
879 (when (> *draw-transform-dimensions
* 0)
882 (setf fxc
(funcall *draw-transform-f1
* xold yold
)
883 fyc
(funcall *draw-transform-f2
* xold yold
))) )
884 ; update x-y ranges if necessary
885 (setf xmin
(min fxc xmin
)
889 (update-ranges-2d xmin xmax ymin ymax
)
891 ((get-option '$transparent
) ; if transparent, draw only the border
892 (setf pltcmd
(format nil
" ~a w l lw ~a lt ~a lc ~a axis ~a"
893 (make-obj-title (get-option '$key
))
894 (get-option '$line_width
)
895 (get-option '$line_type
)
896 (hex-to-rgb (get-option '$color
))
899 (setf pts
`( ,(make-array (length result
) :element-type
'flonum
900 :initial-contents result
))) )
901 ((not (get-option '$border
)) ; no transparent, no border
902 (setf pltcmd
(format nil
" ~a w filledcurves~a xy=~a,~a lc ~a axis ~a"
903 (make-obj-title (get-option '$key
))
904 (format nil
"~@[ fillstyle solid ~a~]" (get-option '$fill_density
))
906 (hex-to-rgb (get-option '$fill_color
))
909 (setf pts
`( ,(make-array (length result
) :element-type
'flonum
910 :initial-contents result
))) )
911 (t ; no transparent with border
912 (setf pltcmd
(list (format nil
" ~a w filledcurves~a xy=~a,~a lc ~a axis ~a"
913 (make-obj-title (get-option '$key
))
914 (format nil
"~@[ fillstyle solid ~a~]" (get-option '$fill_density
))
916 (hex-to-rgb (get-option '$fill_color
))
918 (format nil
" t '' w l lw ~a lt ~a lc ~a axis ~a"
919 (get-option '$line_width
)
920 (get-option '$line_type
)
921 (hex-to-rgb (get-option '$color
))
923 (setf grps
'((2 0) (2 0)))
924 (setf pts
(list (make-array (length result
) :element-type
'flonum
925 :initial-contents result
)
926 (make-array (length result
) :element-type
'flonum
927 :initial-contents result
))) ))
943 ;; label([string1,xx1,y1],[string2,xx2,y2],...)
945 ;; label([string1,x1,y1,z1],[string2,x2,y2,z2],...)
953 (defun replace-substring (string part replacement
)
954 (with-output-to-string (out)
955 (loop with part-length
= (length part
)
956 for old-pos
= 0 then
(+ pos part-length
)
957 for pos
= (search part string
960 do
(write-string string out
962 :end
(or pos
(length string
)))
963 when pos do
(write-string replacement out
)
966 (defun-checked label
(&rest lab
)
967 (let ((n (length lab
))
971 (merror "draw (label): no arguments in object labels"))
972 ((every #'$listp lab
)
973 (cond ((every #'(lambda (z) (= 3 ($length z
))) lab
) ; labels in 2d
975 ((every #'(lambda (z) (= 4 ($length z
))) lab
) ; labels in 3d
978 (merror "draw (label): arguments of not equal length")))
982 (setf xx
($float
($second k
))
983 yy
($float
($third k
))
984 ; backslashes are replaced by double backslashes to allow LaTeX code in labels.
985 text
(format nil
"\"~a\"" (replace-substring ($first k
) "\\" "\\\\")))
986 (if (or (not (floatp xx
))
988 (merror "draw (label): non real 2d coordinates"))
990 (update-ranges-2d xx xx yy yy
)
991 (setf result
(append (list xx yy text
) result
)))))
995 (setf xx
($float
($second k
))
996 yy
($float
($third k
))
997 zz
($float
($fourth k
))
998 text
(format nil
"\"~a\"" ($first k
)) )
999 (if (or (not (floatp xx
))
1002 (merror "draw (label): non real 3d coordinates"))
1004 (update-ranges-3d xx xx yy yy zz zz
)
1005 (setf result
(append (list xx yy zz text
) result
)))))) )
1006 (t (merror "draw (label): illegal arguments")))
1009 :command
(format nil
" t '' w labels ~a ~a tc ~a ~a"
1010 (case (get-option '$label_alignment
)
1014 (case (get-option '$label_orientation
)
1015 ($horizontal
"norotate")
1016 ($vertical
"rotate"))
1017 (hex-to-rgb (get-option '$color
))
1019 (format nil
"axis ~a" (axes-to-plot))
1021 :groups
(if is2d
'((3 0)) '((4 0)))
1022 :points
(list (make-array (length result
) :initial-contents result
))) ))
1031 ;; bars([x1,h1,w1],[x2,h2,w2],...), x, height and width
1039 (defun-checked bars
(&rest boxes
)
1040 (let ((n (length boxes
))
1042 (xmin most-positive-double-float
)
1043 (xmax most-negative-double-float
)
1044 (ymin most-positive-double-float
)
1045 (ymax most-negative-double-float
)
1048 (merror "draw2d (bars): no arguments in object bars"))
1049 (when (not (every #'(lambda (z) (and ($listp z
) (= 3 ($length z
)))) boxes
))
1050 (merror "draw2d (bars): arguments must be lists of length three"))
1051 (setf result
(make-array (* 3 n
) :element-type
'flonum
))
1053 (setf x
($float
($first k
))
1054 h
($float
($second k
))
1055 w
($float
($third k
)))
1057 (setf (aref result
(incf count
)) x
1058 (aref result
(incf count
)) h
1059 (aref result
(incf count
)) w
)
1060 (setf xmin
(min xmin
(- x w2
))
1061 xmax
(max xmax
(+ x w2
))
1063 ymax
(max ymax h
)) )
1064 (update-ranges-2d xmin xmax ymin ymax
)
1067 :command
(format nil
" ~a w boxes fs solid ~a lw ~a lc ~a axis ~a"
1068 (make-obj-title (get-option '$key
))
1069 (or (get-option '$fill_density
) 0) ;; Default is "not filled".
1070 (get-option '$line_width
)
1071 (hex-to-rgb (get-option '$fill_color
))
1073 :groups
'((3 0)) ; numbers are sent to gnuplot in groups of 3, without blank lines
1074 :points
(list (make-array (length result
) :initial-contents result
))) ))
1085 ;; vector([x,y], [dx,dy]), represents vector from [x,y] to [x+dx,y+dy]
1098 (defun-checked vect
(arg1 arg2
)
1099 (if (or (not ($listp arg1
))
1100 (not (= ($length arg1
) 2))
1102 (not (= ($length arg2
) 2)))
1103 (merror "draw (vector): coordinates are not correct"))
1104 (let ((xo ($float
(cadr arg1
)))
1105 (yo ($float
(caddr arg1
)))
1106 (dx ($float
(cadr arg2
)))
1107 (dy ($float
(caddr arg2
)))
1109 (when (and (get-option '$unit_vectors
)
1110 (or (/= dx
0) (/= dy
0)))
1111 (let ((module (sqrt (+ (* dx dx
) (* dy dy
)))))
1112 (setf dx
(/ dx module
)
1113 dy
(/ dy module
) )))
1114 (setf xdx
($float
(+ xo dx
))
1115 ydy
($float
(+ yo dy
)))
1116 ;; apply geometric transformation before plotting
1117 (setf x
(list xo xdx
)
1120 (update-ranges-2d (apply 'min x
) (apply 'max x
) (apply 'min y
) (apply 'max y
))
1123 :command
(format nil
" ~a w vect ~a size ~a, ~a ~a lw ~a lt ~a lc ~a axis ~a"
1124 (make-obj-title (get-option '$key
))
1125 (if (get-option '$head_both
) "heads" "head")
1126 (get-option '$head_length
)
1127 (get-option '$head_angle
)
1128 (case (get-option '$head_type
)
1131 ($nofilled
"nofilled"))
1132 (get-option '$line_width
)
1133 (get-option '$line_type
)
1134 (hex-to-rgb (get-option '$color
))
1137 :points
`(,(make-array 4 :element-type
'flonum
1138 :initial-contents
(list (car x
)
1140 (- (cadr x
) (car x
))
1141 (- (cadr y
) (car y
))))) ) ))
1149 ;; Object: 'vector3d'
1151 ;; vector([x,y,z], [dx,dy,dz]), represents vector from [x,y,z] to [x+dx,y+dy,z+dz]
1162 (defun-checked vect3d
(arg1 arg2
)
1163 (if (or (not ($listp arg1
))
1164 (not (= ($length arg1
) 3))
1166 (not (= ($length arg2
) 3)))
1167 (merror "draw (vector): coordinates are not correct"))
1168 (let ((xo ($float
(cadr arg1
)))
1169 (yo ($float
(caddr arg1
)))
1170 (zo ($float
(cadddr arg1
)))
1171 (dx ($float
(cadr arg2
)))
1172 (dy ($float
(caddr arg2
)))
1173 (dz ($float
(cadddr arg2
)))
1175 (when (and (get-option '$unit_vectors
)
1176 (or (/= dx
0) (/= dy
0) (/= dz
0)))
1177 (let ((module (sqrt (+ (* dx dx
) (* dy dy
) (* dz dz
)))))
1178 (setf dx
(/ dx module
)
1180 dz
(/ dz module
) )))
1181 (setf xdx
($float
(+ xo dx
))
1182 ydy
($float
(+ yo dy
))
1183 zdz
($float
(+ zo dz
)) )
1184 ;; apply geometric transformation before plotting
1185 (setf x
(list xo xdx
)
1189 (update-ranges-3d (apply 'min x
) (apply 'max x
) (apply 'min y
) (apply 'max y
) (apply 'min z
) (apply 'max z
))
1192 :command
(format nil
" ~a w vect ~a size ~a, ~a ~a lw ~a lt ~a lc ~a"
1193 (make-obj-title (get-option '$key
))
1194 (if (get-option '$head_both
) "heads" "head")
1195 (get-option '$head_length
)
1196 (get-option '$head_angle
)
1197 (case (get-option '$head_type
)
1200 ($nofilled
"nofilled"))
1201 (get-option '$line_width
)
1202 (get-option '$line_type
)
1203 (hex-to-rgb (get-option '$color
)) )
1205 :points
`(,(make-array 6 :element-type
'flonum
1206 :initial-contents
(list (car x
)
1209 (- (cadr x
) (car x
))
1210 (- (cadr y
) (car y
))
1211 (- (cadr z
) (car z
))))) ) ))
1220 ;; Object: 'explicit'
1222 ;; explicit(fcn,var,minval,maxval)
1235 (defun-checked explicit
(fcn var minval maxval
)
1236 (let* ((nticks (get-option '$nticks
))
1237 (depth (get-option '$adapt_depth
))
1239 (xmin ($float minval
))
1240 (xmax ($float maxval
))
1241 (x-step (/ (- xmax xmin
) ($float nticks
) 2))
1242 (ymin most-positive-double-float
)
1243 (ymax most-negative-double-float
)
1244 (*plot-realpart
* *plot-realpart
*)
1245 x-samples y-samples yy result pltcmd result-array
)
1247 (merror "draw2d (explicit): illegal range"))
1248 (setq *plot-realpart
* (get-option '$draw_realpart
))
1249 (setq fcn
(coerce-float-fun fcn
`((mlist) ,var
)))
1250 (when (get-option '$logx
)
1251 (setf xmin
(log xmin
))
1252 (setf xmax
(log xmax
))
1253 (setf x-step
(/ (- xmax xmin
) ($float nticks
) 2)))
1255 (let ((y (if (get-option '$logx
)
1256 (funcall fcn
(exp x
))
1258 (if (and (get-option '$logy
)
1262 (merror "draw2d (explicit): logarithm of negative number"))
1264 (dotimes (k (1+ (* 2 nticks
)))
1265 (let ((x (+ xmin
(* k x-step
))))
1267 (push (fun x
) y-samples
)))
1268 (setf x-samples
(nreverse x-samples
))
1269 (setf y-samples
(nreverse y-samples
))
1270 ;; For each region, adaptively plot it.
1271 (do ((x-start x-samples
(cddr x-start
))
1272 (x-mid (cdr x-samples
) (cddr x-mid
))
1273 (x-end (cddr x-samples
) (cddr x-end
))
1274 (y-start y-samples
(cddr y-start
))
1275 (y-mid (cdr y-samples
) (cddr y-mid
))
1276 (y-end (cddr y-samples
) (cddr y-end
)))
1278 ;; The region is x-start to x-end, with mid-point x-mid.
1279 (let ((sublst (adaptive-plot #'fun
(car x-start
) (car x-mid
) (car x-end
)
1280 (car y-start
) (car y-mid
) (car y-end
)
1282 (when (notevery #'(lambda (x) (or (numberp x
) (eq x t
) (eq x nil
))) sublst
)
1283 (let ((items sublst
) (item 'nil
))
1284 ;; Search for the item in sublist that is the undefined variable
1286 (when (not (or (numberp (car items
))
1288 (eq (car items
) nil
)))
1289 (setq item
(car items
)) )
1290 (setq items
(cdr items
)) )
1291 (merror "draw2d (explicit): non defined variable in term: ~M" item
) ) )
1293 (when (not (null result
))
1294 (setf sublst
(cddr sublst
)))
1295 (do ((lst sublst
(cddr lst
)))
1297 (setf result
(cons (if (and (get-option '$logy
) (numberp (second lst
)))
1301 (setf result
(cons (if (and (get-option '$logx
) (numberp (first lst
)))
1306 ; reset x extremes to original values
1307 (when (get-option '$logx
)
1308 (setf xmin
(exp xmin
))
1309 (setf xmax
(exp xmax
)))
1311 (cond ((null (get-option '$filled_func
))
1313 ((> *draw-transform-dimensions
* 0)
1314 ; With geometric transformation.
1315 ; When option filled_func in not nil,
1316 ; geometric transformation is ignored
1317 (setf result-array
(make-array (length result
)))
1318 (setf xmin most-positive-double-float
1319 xmax most-negative-double-float
)
1320 (let (xold yold x y
(count -
1))
1321 (do ((lis result
(cddr lis
)))
1323 (setf xold
(first lis
)
1325 (setf x
(funcall *draw-transform-f1
* xold yold
)
1326 y
(funcall *draw-transform-f2
* xold yold
))
1327 (if (> x xmax
) (setf xmax x
))
1328 (if (< x xmin
) (setf xmin x
))
1329 (if (> y ymax
) (setf ymax y
))
1330 (if (< y ymin
) (setf ymin y
))
1331 (setf (aref result-array
(incf count
)) x
)
1332 (setf (aref result-array
(incf count
)) y
) ) ) )
1334 ; No geometric transformation invoked.
1335 (do ((y (cdr result
) (cddr y
)))
1339 (setf result-array
(make-array (length result
)
1340 :initial-contents result
))))
1341 (update-ranges-2d xmin xmax ymin ymax
)
1342 (setf pltcmd
(format nil
" ~a w l lw ~a lt ~a lc ~a axis ~a"
1343 (make-obj-title (get-option '$key
))
1344 (get-option '$line_width
)
1345 (get-option '$line_type
)
1346 (hex-to-rgb (get-option '$color
))
1351 :groups
'((2 0)) ; numbers are sent to gnuplot in groups of 2
1352 :points
(list result-array
)) )
1353 ((equal (get-option '$filled_func
) t
)
1354 (do ((y (cdr result
) (cddr y
)))
1358 (update-ranges-2d xmin xmax ymin ymax
)
1359 (setf result-array
(make-array (length result
)
1360 :element-type
'flonum
1361 :initial-contents result
))
1362 (setf pltcmd
(format nil
" ~a w filledcurves~a x1 lc ~a axis ~a"
1363 (make-obj-title (get-option '$key
))
1364 (format nil
"~@[ fillstyle solid ~a~]" (get-option '$fill_density
))
1365 (hex-to-rgb (get-option '$fill_color
))
1370 :groups
'((2 0)) ; numbers are sent to gnuplot in groups of 2
1371 :points
(list result-array
)))
1373 (let (fcn2 yy2
(count -
1))
1374 (setf result-array
(make-array (* (/ (length result
) 2) 3)
1375 :element-type
'flonum
))
1376 (setq fcn2
(coerce-float-fun (get-option '$filled_func
) `((mlist), var
)))
1377 (flet ((fun (x) (funcall fcn2 x
)))
1378 (do ((xx result
(cddr xx
)))
1380 (setf yy
(second xx
)
1381 yy2
(fun (first xx
)))
1382 (setf ymax
(max ymax yy yy2
)
1383 ymin
(min ymin yy yy2
))
1384 (setf (aref result-array
(incf count
)) (first xx
)
1385 (aref result-array
(incf count
)) yy
1386 (aref result-array
(incf count
)) yy2
) ) ))
1387 (update-ranges-2d xmin xmax ymin ymax
)
1388 (setf pltcmd
(format nil
" ~a w filledcurves~a lc ~a axis ~a"
1389 (make-obj-title (get-option '$key
))
1390 (format nil
"~@[ fillstyle solid ~a~]" (get-option '$fill_density
))
1391 (hex-to-rgb (get-option '$fill_color
))
1396 :groups
'((3 0)) ; numbers are sent to gnuplot in groups of 3
1397 :points
(list result-array
)))) ))
1407 ;; region(ineq,x-var,x-minval,x-maxval,y-var,y-minval,y-maxval)
1414 (defmacro build-polygon
(coord)
1415 (let ((len (1- (length coord
))))
1416 `(push (make-array ,len
:element-type
'flonum
:initial-contents
,coord
) pts
)))
1418 (defun-checked region
(ineq x-var x-minval x-maxval y-var y-minval y-maxval
)
1419 (let* ((nx (get-option '$x_voxel
))
1420 (ny (get-option '$y_voxel
))
1421 (xmin ($float x-minval
))
1422 (xmax ($float x-maxval
))
1423 (ymin ($float y-minval
))
1424 (ymax ($float y-maxval
))
1425 (dx (/ (- xmax xmin
) nx
))
1426 (dy (/ (- ymax ymin
) ny
))
1427 (err (* 0.02 (min dx dy
)))
1428 (xarr (make-array (list (1+ nx
) (1+ ny
)) :element-type
'flonum
))
1429 (yarr (make-array (list (1+ nx
) (1+ ny
)) :element-type
'flonum
))
1430 (barr (make-array (list (1+ nx
) (1+ ny
)) :initial-element nil
:element-type
'boolean
))
1432 pltcmd grouping x y
)
1434 (when (not (subsetp (rest ($listofvars ineq
)) (list x-var y-var
) :test
#'like
))
1435 (merror "draw2d (region): non defined variable"))
1437 ; build 2d arrays: x, y and boolean
1438 (labels ((fun (xx yy
) ; evaluates boolean expression
1439 (let (($prederror t
))
1444 (list '(mequal) x-var xx
)
1445 (list '(mequal) y-var yy
))
1447 (bipart (xx1 yy1 xx2 yy2
) ; bipartition, (xx1, yy1) => T, (xx2, yy2) => NIL
1448 (let ((xm (* 0.5 (+ xx1 xx2
)))
1449 (ym (* 0.5 (+ yy1 yy2
))))
1451 ((< (+ (* (- xx2 xx1
) (- xx2 xx1
))
1452 (* (- yy2 yy1
) (- yy2 yy1
)))
1456 (bipart xm ym xx2 yy2
))
1458 (bipart xx1 yy1 xm ym
)) )) ))
1460 (loop for i to nx do
1461 (loop for j to ny do
1462 (setf x
(+ xmin
(* i dx
)))
1463 (setf y
(+ ymin
(* j dy
)))
1464 (setf (aref xarr i j
) x
)
1465 (setf (aref yarr i j
) y
)
1466 (setf (aref barr i j
) (fun x y
))))
1467 ; check vertices of rectangles and cuts
1468 (loop for i below nx do
1469 (loop for j below ny do
1470 (let ((x1 (aref xarr i j
)) ; SW point
1471 (y1 (aref yarr i j
))
1472 (b1 (aref barr i j
))
1473 (x2 (aref xarr
(1+ i
) j
)) ; SE point
1474 (y2 (aref yarr
(1+ i
) j
))
1475 (b2 (aref barr
(1+ i
) j
))
1476 (x3 (aref xarr
(1+ i
) (1+ j
))) ; NE point
1477 (y3 (aref yarr
(1+ i
) (1+ j
)))
1478 (b3 (aref barr
(1+ i
) (1+ j
)))
1479 (x4 (aref xarr i
(1+ j
))) ; NW point
1480 (y4 (aref yarr i
(1+ j
)))
1481 (b4 (aref barr i
(1+ j
)))
1482 pa pb pc
) ; pa and pb are frontier points
1484 (cond ((and b1 b2 b3 b4
)
1485 (build-polygon (list x1 y1 x2 y2 x3 y3 x4 y4
)))
1487 (setf pa
(bipart x3 y3 x4 y4
)
1488 pb
(bipart x1 y1 x4 y4
))
1489 (build-polygon (list x1 y1 x2 y2 x3 y3
(first pa
) (second pa
) (first pb
) (second pb
))))
1491 (setf pa
(bipart x2 y2 x3 y3
)
1492 pb
(bipart x4 y4 x3 y3
))
1493 (build-polygon (list x4 y4 x1 y1 x2 y2
(first pa
) (second pa
) (first pb
) (second pb
))))
1495 (setf pa
(bipart x1 y1 x2 y2
)
1496 pb
(bipart x3 y3 x2 y2
))
1497 (build-polygon (list x3 y3 x4 y4 x1 y1
(first pa
) (second pa
) (first pb
) (second pb
))))
1499 (setf pa
(bipart x4 y4 x1 y1
)
1500 pb
(bipart x2 y2 x1 y1
))
1501 (build-polygon (list x2 y2 x3 y3 x4 y4
(first pa
) (second pa
) (first pb
) (second pb
))))
1503 (setf pa
(bipart x3 y3 x4 y4
)
1504 pb
(bipart x2 y2 x1 y1
))
1505 (build-polygon (list x2 y2 x3 y3
(first pa
) (second pa
) (first pb
) (second pb
))))
1507 (setf pa
(bipart x1 y1 x2 y2
)
1508 pb
(bipart x4 y4 x3 y3
))
1509 (build-polygon (list x4 y4 x1 y1
(first pa
) (second pa
) (first pb
) (second pb
))))
1511 (setf pa
(bipart x4 y4 x1 y1
)
1512 pb
(bipart x3 y3 x2 y2
))
1513 (build-polygon (list x3 y3 x4 y4
(first pa
) (second pa
) (first pb
) (second pb
))))
1515 (setf pa
(bipart x2 y2 x3 y3
)
1516 pb
(bipart x1 y1 x4 y4
))
1517 (build-polygon (list x1 y1 x2 y2
(first pa
) (second pa
) (first pb
) (second pb
))))
1519 (setf pa
(bipart x1 y1 x2 y2
)
1520 pb
(bipart x1 y1 x3 y4
)
1521 pc
(bipart x1 y1 x4 y4
))
1522 (build-polygon (list x1 y1
(first pa
) (second pa
) (first pb
) (second pb
)(first pc
) (second pc
))))
1524 (setf pa
(bipart x2 y2 x3 y3
)
1525 pb
(bipart x2 y2 x4 y4
)
1526 pc
(bipart x2 y2 x1 y1
))
1527 (build-polygon (list x2 y2
(first pa
) (second pa
) (first pb
) (second pb
) (first pc
) (second pc
))))
1529 (setf pa
(bipart x3 y3 x4 y4
)
1530 pb
(bipart x3 y3 x1 y1
)
1531 pc
(bipart x3 y3 x2 y2
))
1532 (build-polygon (list x3 y3
(first pa
) (second pa
) (first pb
) (second pb
) (first pc
) (second pc
))))
1534 (setf pa
(bipart x4 y4 x1 y1
)
1535 pb
(bipart x4 y4 x2 y2
)
1536 pc
(bipart x4 y4 x3 y3
))
1537 (build-polygon (list x4 y4
(first pa
) (second pa
) (first pb
) (second pb
) (first pc
) (second pc
)))) )))))
1541 (cons (format nil
" ~a w filledcurves~a lc ~a axis ~a"
1542 (make-obj-title (get-option '$key
))
1543 (format nil
"~@[ fillstyle solid ~a~]" (get-option '$fill_density
))
1544 (hex-to-rgb (get-option '$fill_color
))
1546 (make-list (- (length pts
) 1)
1547 :initial-element
(format nil
" t '' w filledcurves~a lc ~a axis ~a"
1548 (format nil
"~@[ fillstyle solid ~a~]" (get-option '$fill_density
))
1549 (hex-to-rgb (get-option '$fill_color
))
1551 (update-ranges-2d xmin xmax ymin ymax
)
1553 (make-list (length pts
)
1554 :initial-element
'(2 0)))
1568 ;; Object: 'implicit'
1570 ;; implicit(fcn,x-var,x-minval,x-maxval,y-var,y-minval,y-maxval)
1580 ;; Note: taken from implicit_plot.lisp
1582 ;; returns elements at odd positions
1583 (defun x-elements (list)
1584 (if (endp list
) list
1585 (list* (first list
) (x-elements (rest (rest list
))))))
1587 ;; returns elements at even positions
1588 (defun y-elements (list)
1589 (x-elements (rest list
)))
1593 (defun contains-zeros (i j sample
)
1594 (not (and (> (* (aref sample i j
) (aref sample
(1+ i
) j
)) 0)
1595 (> (* (aref sample i j
) (aref sample i
(1+ j
) )) 0)
1596 (> (* (aref sample i j
) (aref sample
(1+ i
) (1+ j
) )) 0) )))
1598 (defun sample-data (expr xmin xmax ymin ymax sample grid
)
1599 (let* ((xdelta (/ (- xmax xmin
) ($first grid
)))
1600 (ydelta (/ (- ymax ymin
) ($second grid
)))
1602 (do ((x-val xmin
(+ x-val xdelta
))
1604 ((> i
($first grid
)))
1605 (do ((y-val ymin
(+ y-val ydelta
))
1607 ((> j
($second grid
)))
1608 (let ((fun-val (funcall expr x-val y-val
)))
1609 (when (and (not (floatp fun-val
)) (not (eq fun-val t
)))
1610 (merror "draw2d (implicit): non defined variable in condition ~M=0" fun-val
))
1611 (if (or (eq fun-val t
) (>= fun-val epsilon
))
1612 (setf (aref sample i j
) 1)
1613 (setf (aref sample i j
) -
1)))))))
1615 (defun draw-print-segment (points xmin xdelta ymin ydelta
)
1616 (let* ((point1 (car points
)) (point2 (cadr points
))
1617 (x1 (coerce (+ xmin
(/ (* xdelta
(+ (car point1
) (caddr point1
))) 2)) 'flonum
) )
1618 (y1 (coerce (+ ymin
(/ (* ydelta
(+ (cadr point1
) (cadddr point1
))) 2)) 'flonum
) )
1619 (x2 (coerce (+ xmin
(/ (* xdelta
(+ (car point2
) (caddr point2
))) 2)) 'flonum
) )
1620 (y2 (coerce (+ ymin
(/ (* ydelta
(+ (cadr point2
) (cadddr point2
))) 2)) 'flonum
) ))
1621 (setq pts
(nconc (list x1 y1 x2 y2
) pts
))))
1623 (defun draw-print-square (xmin xmax ymin ymax sample grid
)
1624 (let* ((xdelta (/ (- xmax xmin
) ($first grid
)))
1625 (ydelta (/ (- ymax ymin
) ($second grid
))))
1627 ((= i
($first grid
)))
1629 ((= j
($second grid
)))
1630 (if (contains-zeros i j sample
)
1632 (if (< (* (aref sample i j
) (aref sample
(1+ i
) j
)) 0)
1633 (setq points
(cons `(,i
,j
,(1+ i
) ,j
) points
)))
1634 (if (< (* (aref sample
(1+ i
) j
) (aref sample
(1+ i
) (1+ j
))) 0)
1635 (setq points
(cons `(,(1+ i
) ,j
,(1+ i
) ,(1+ j
)) points
)))
1636 (if (< (* (aref sample i
(1+ j
)) (aref sample
(1+ i
) (1+ j
))) 0)
1637 (setq points
(cons `(,i
,(1+ j
) ,(1+ i
) ,(1+ j
)) points
)))
1638 (if (< (* (aref sample i j
) (aref sample i
(1+ j
))) 0)
1639 (setq points
(cons `(,i
,j
,i
,(1+ j
)) points
)))
1640 (draw-print-segment points xmin xdelta ymin ydelta
)) )))))
1642 (defun imp-pl-prepare-factor (expr)
1644 ((or ($numberp expr
) (atom expr
))
1646 ((eq (caar expr
) 'mexpt
)
1651 (defun imp-pl-prepare-expr (expr)
1652 (let ((expr1 ($factor
(m- ($rhs expr
) ($lhs expr
)))))
1653 (cond ((or ($numberp expr
) (atom expr1
)) expr1
)
1654 ((eq (caar expr1
) 'mtimes
)
1655 `((mtimes simp factored
1)
1656 ,@(mapcar #'imp-pl-prepare-factor
(cdr expr1
))))
1657 ((eq (caar expr
) 'mexpt
)
1658 (imp-pl-prepare-factor expr1
))
1662 (defun-checked implicit
(expr x xmin xmax y ymin ymax
)
1663 (let* (($numer t
) ($plot_options $plot_options
)
1665 (expr (m- ($rhs expr
) ($lhs expr
)))
1666 (ip-grid (get-option '$ip_grid
))
1667 (ip-grid-in (get-option '$ip_grid_in
))
1669 (xmin ($float xmin
))
1670 (xmax ($float xmax
))
1671 (ymin ($float ymin
))
1672 (ymax ($float ymax
))
1673 (xdelta (/ (- xmax xmin
) ($first ip-grid
)))
1674 (ydelta (/ (- ymax ymin
) ($second ip-grid
)))
1675 (sample (make-array `(,(1+ ($first ip-grid
))
1676 ,(1+ ($second ip-grid
)))))
1677 (ssample (make-array `(,(1+ ($first ip-grid-in
))
1678 ,(1+ ($second ip-grid-in
))))) )
1680 (setq e
(coerce-float-fun (imp-pl-prepare-expr expr
)
1683 (update-ranges-2d xmin xmax ymin ymax
)
1684 (sample-data e xmin xmax ymin ymax sample ip-grid
)
1686 ((= i
($first ip-grid
)))
1688 ((= j
($second ip-grid
)))
1689 (if (contains-zeros i j sample
)
1690 (let* ((xxmin (+ xmin
(* i xdelta
)))
1691 (xxmax (+ xxmin xdelta
))
1692 (yymin (+ ymin
(* j ydelta
)))
1693 (yymax (+ yymin ydelta
)))
1694 (sample-data e xxmin xxmax yymin yymax
1696 (draw-print-square xxmin xxmax yymin yymax
1697 ssample ip-grid-in
) )) ))
1699 ; geometric transformation
1700 (when (> *draw-transform-dimensions
* 0)
1701 (let ((x (x-elements pts
))
1702 (y (y-elements pts
))
1703 xmin xmax ymin ymax
)
1705 (setf xmin
($tree_reduce
'min
(cons '(mlist simp
) x
))
1706 xmax
($tree_reduce
'max
(cons '(mlist simp
) x
))
1707 ymin
($tree_reduce
'min
(cons '(mlist simp
) y
))
1708 ymax
($tree_reduce
'max
(cons '(mlist simp
) y
)) )
1709 (update-ranges-2d xmin xmax ymin ymax
)
1716 when
(null x
) do
(loop-finish) ))) )
1718 (setf pltcmd
(format nil
" ~a w l lw ~a lt ~a lc ~a axis ~a"
1719 (make-obj-title (get-option '$key
))
1720 (get-option '$line_width
)
1721 (get-option '$line_type
)
1722 (hex-to-rgb (get-option '$color
))
1728 :points
`(,(make-array (length pts
) :element-type
'flonum
1729 :initial-contents pts
)) ) ))
1736 ;; Object: 'implicit3d'
1738 ;; implicit(expr,x,xmin,xmax,y,ymin,ymax,z,zmin,zmax)
1749 ;; Some functions and macros are defined in grcommon.lisp
1750 (defun-checked implicit3d
(expr par1 xmin xmax par2 ymin ymax par3 zmin zmax
)
1751 (let ((xmin ($float xmin
))
1752 (xmax ($float xmax
))
1753 (ymin ($float ymin
))
1754 (ymax ($float ymax
))
1755 (zmin ($float zmin
))
1756 (zmax ($float zmax
))
1759 pltcmd ncols vertices
)
1760 (when (not (subsetp (rest ($listofvars expr
)) (list par1 par2 par3
) :test
#'like
))
1761 (merror "draw3d (implicit): non defined variable"))
1762 (check-enhanced3d-model "implicit" '(0 3 99))
1763 (when (= *draw-enhanced3d-type
* 99)
1764 (update-enhanced3d-expression (list '(mlist) par1 par2 par3
)))
1765 (setf ncols
(if (= *draw-enhanced3d-type
* 0) 3 4))
1767 (setf vertices
(find-triangles expr par1 xmin xmax par2 ymin ymax par3 zmin zmax
))
1768 (when (null vertices
)
1769 (merror "draw3d (implicit): no surface within these ranges"))
1770 (update-ranges-3d xmin xmax ymin ymax zmin zmax
)
1772 (cons (format nil
" ~a w ~a lw ~a lt ~a lc ~a"
1773 (make-obj-title (get-option '$key
))
1774 (if (equal (get-option '$enhanced3d
) '$none
) "l" "pm3d")
1775 (get-option '$line_width
)
1776 (get-option '$line_type
)
1777 (hex-to-rgb (get-option '$color
)))
1778 (make-list (- (/ (length vertices
) 3) 1)
1779 :initial-element
(format nil
" t '' w ~a lw ~a lt ~a lc ~a"
1780 (if (equal (get-option '$enhanced3d
) '$none
) "l" "pm3d")
1781 (get-option '$line_width
)
1782 (get-option '$line_type
)
1783 (hex-to-rgb (get-option '$color
)) ))))
1784 (do ((v vertices
(cdddr v
)))
1787 (3 (push (make-array 12 :element-type
'flonum
1788 :initial-contents
(flatten (list (first v
) (second v
) (first v
) (third v
))))
1791 color1 color2 color3
)
1795 (setf color1
(funcall *draw-enhanced3d-fun
* (car v1
) (cadr v1
) (caddr v1
))
1796 color2
(funcall *draw-enhanced3d-fun
* (car v2
) (cadr v2
) (caddr v2
))
1797 color3
(funcall *draw-enhanced3d-fun
* (car v3
) (cadr v3
) (caddr v3
)) )
1798 (push (make-array 16 :element-type
'flonum
1799 :initial-contents
(flatten (list v1 color1 v2 color2 v1 color1 v3 color3
)))
1815 ;; Object: 'explicit3d'
1817 ;; explicit(fcn,par1,minval1,maxval1,par2,minval2,maxval2)
1829 (defun-checked explicit3d
(fcn par1 minval1 maxval1 par2 minval2 maxval2
)
1830 (let* ((xu_grid (get-option '$xu_grid
))
1831 (yv_grid (get-option '$yv_grid
))
1832 (fminval1 ($float minval1
))
1833 (fminval2 ($float minval2
))
1834 (fmaxval1 ($float maxval1
))
1835 (fmaxval2 ($float maxval2
))
1836 (epsx (/ (- fmaxval1 fminval1
) xu_grid
))
1837 (epsy (/ (- fmaxval2 fminval2
) yv_grid
))
1841 (xmin most-positive-double-float
)
1842 (xmax most-negative-double-float
)
1843 (ymin most-positive-double-float
)
1844 (ymax most-negative-double-float
)
1845 (zmin most-positive-double-float
)
1846 (zmax most-negative-double-float
)
1847 (*plot-realpart
* *plot-realpart
*)
1853 (when (not (subsetp (rest ($listofvars fcn
)) (list par1 par2
) :test
#'like
))
1854 (let ((items (rest ($listofvars fcn
))) (item 'nil
))
1855 ;; Search for the item in sublist that is the undefined variable
1860 (subsetp (list (car items
)) (list par1 par2
) :test
#'like
)
1862 (setq item
(car items
))
1864 (setq items
(cdr items
))
1866 (merror "draw3d (explicit): non defined variable in term ~M" item
)
1869 (setq *plot-realpart
* (get-option '$draw_realpart
))
1870 (check-enhanced3d-model "explicit" '(0 2 3 99))
1871 (when (= *draw-enhanced3d-type
* 99)
1872 (update-enhanced3d-expression (list '(mlist) par1 par2
)))
1873 (setq fcn
(coerce-float-fun fcn
`((mlist) ,par1
,par2
)))
1874 (setf ncols
(if (= *draw-enhanced3d-type
* 0) 3 4))
1875 (setf result
(make-array (* ncols nx ny
)))
1876 (loop for j below ny
1877 initially
(setf vv fminval2
)
1878 do
(setf uu fminval1
)
1879 (loop for i below nx
1883 (setf zz
(funcall fcn xx yy
))
1885 (when (> *draw-transform-dimensions
* 0)
1889 (setf (aref result
(incf count
)) xx
1890 (aref result
(incf count
)) yy
1891 (aref result
(incf count
)) zz
)
1892 ; check texture model
1893 (case *draw-enhanced3d-type
*
1894 ((2 99) (setf (aref result
(incf count
)) (funcall *draw-enhanced3d-fun
* xx yy
)))
1895 (3 (setf (aref result
(incf count
)) (funcall *draw-enhanced3d-fun
* xx yy zz
))) )
1896 (setq uu
(+ uu epsx
)))
1897 (setq vv
(+ vv epsy
)))
1898 (when (> *draw-transform-dimensions
* 0)
1903 (update-ranges-3d fminval1 fmaxval1 fminval2 fmaxval2 zmin zmax
)
1906 :command
(format nil
" ~a w ~a lw ~a lt ~a lc ~a"
1907 (make-obj-title (get-option '$key
))
1908 (if (> *draw-enhanced3d-type
* 0) "pm3d" "l")
1909 (get-option '$line_width
)
1910 (get-option '$line_type
)
1911 (hex-to-rgb (get-option '$color
)))
1912 :groups
`((,ncols
,nx
))
1913 :points
(list result
))))
1922 ;; Object: 'elevation_grid'
1924 ;; elevation_grid(mat,x0,y0,width,height)
1933 (defun-checked elevation_grid
(mat x0 y0 width height
)
1934 (let ( (fx0 ($float x0
))
1936 (fwidth ($float width
))
1937 (fheight ($float height
))
1938 (xmin most-positive-double-float
)
1939 (xmax most-negative-double-float
)
1940 (ymin most-positive-double-float
)
1941 (ymax most-negative-double-float
)
1942 (zmin most-positive-double-float
)
1943 (zmax most-negative-double-float
)
1944 ncols-file result nrows ncols
)
1945 (check-enhanced3d-model "elevation_grid" '(0 2 3))
1946 (cond (($matrixp mat
)
1948 (yi (+ fy0 fheight
))
1954 (setf ncols
(length (cdadr mat
))
1955 nrows
(length (cdr mat
)))
1956 (setf dx
(/ fwidth
(1- ncols
))
1957 dy
(/ fheight
(1- nrows
)))
1958 (setf ncols-file
(if (= *draw-enhanced3d-type
* 0) 3 4))
1959 (setf result
(make-array (* ncols nrows ncols-file
) :element-type
'flonum
))
1960 (loop for row on
(cdr mat
) by
#'cdr do
1962 (loop for col on
(cdar row
) by
#'cdr do
1965 (setf zz
($float
(car col
)))
1967 (when (> *draw-transform-dimensions
* 0)
1971 (setf (aref result
(incf count
)) xx
1972 (aref result
(incf count
)) yy
1973 (aref result
(incf count
)) zz
)
1974 ; check texture model
1975 (case *draw-enhanced3d-type
*
1976 (2 (setf (aref result
(incf count
)) (funcall *draw-enhanced3d-fun
* xx yy
)))
1977 (3 (setf (aref result
(incf count
)) (funcall *draw-enhanced3d-fun
* xx yy zz
))) )
1978 (setf xi
(+ xi dx
)))
1979 (setf yi
(- yi dy
)))))
1981 (merror "draw3d (elevation_grid): Argument not recognized")))
1982 (when (= *draw-transform-dimensions
* 0)
1986 ymax
(+ fy0 fheight
)))
1987 (update-ranges-3d xmin xmax ymin ymax zmin zmax
)
1989 :name
'elevation_grid
1990 :command
(format nil
" ~a w ~a lw ~a lt ~a lc ~a"
1991 (make-obj-title (get-option '$key
))
1992 (if (> *draw-enhanced3d-type
* 0) "pm3d" "l")
1993 (get-option '$line_width
)
1994 (get-option '$line_type
)
1995 (hex-to-rgb (get-option '$color
)))
1996 :groups
`((,ncols-file
,ncols
))
1997 :points
(list result
)) ))
2008 ;; mesh([[x_11,y_11,z_11], ...,[x_1n,y_1n,z_1n]],
2009 ;; [[x_21,y_21,z_21], ...,[x_2n,y_2n,z_2n]],
2011 ;; [[x_m1,y_m1,z_m1], ...,[x_mn,y_mn,z_mn]])
2020 (defun-checked mesh
(&rest row
)
2021 (let (result xx yy zz
2022 (xmin most-positive-double-float
)
2023 (xmax most-negative-double-float
)
2024 (ymin most-positive-double-float
)
2025 (ymax most-negative-double-float
)
2026 (zmin most-positive-double-float
)
2027 (zmax most-negative-double-float
)
2028 m n ncols-file col-num row-num
2031 ; let's see if the user wants to use mesh in the old way,
2032 ; what we now call elevation_grid
2033 ((and (= (length row
) 5)
2034 ($matrixp
(first row
)))
2035 (print "Warning: Seems like you want to draw an elevation_grid object...")
2036 (print " Please, see documentation for object elevation_grid.")
2037 (apply #'elevation_grid row
))
2039 (check-enhanced3d-model "mesh" '(0 2 3))
2040 (when (or (< (length row
) 2)
2041 (not (every #'$listp row
)))
2042 (merror "draw3d (mesh): Arguments must be two or more lists"))
2043 (setf ncols-file
(if (= *draw-enhanced3d-type
* 0) 3 4))
2044 (setf m
(length row
)
2045 n
($length
(first row
)))
2046 (setf result
(make-array (* m n ncols-file
) :element-type
'flonum
))
2051 (dolist (c (rest r
))
2053 (setf xx
($float
($first c
))
2054 yy
($float
($second c
))
2055 zz
($float
($third c
)))
2060 (setf (aref result
(incf count
)) xx
2061 (aref result
(incf count
)) yy
2062 (aref result
(incf count
)) zz
)
2063 ; check texture model
2064 (case *draw-enhanced3d-type
*
2065 (2 (setf (aref result
(incf count
)) (funcall *draw-enhanced3d-fun
* row-num col-num
)))
2066 (3 (setf (aref result
(incf count
)) (funcall *draw-enhanced3d-fun
* xx yy zz
)))) ) )
2067 (update-ranges-3d xmin xmax ymin ymax zmin zmax
)
2070 :command
(format nil
" ~a w ~a lw ~a lt ~a lc ~a"
2071 (make-obj-title (get-option '$key
))
2072 (if (> *draw-enhanced3d-type
* 0) "pm3d" "l")
2073 (get-option '$line_width
)
2074 (get-option '$line_type
)
2075 (hex-to-rgb (get-option '$color
)))
2076 :groups
`((,ncols-file
,n
))
2077 :points
(list result
))))))
2085 ;; Object: 'triangle3d'
2087 ;; triangle([x1,y1,z1], [x2,y2,z2], [x3,y3,z3])
2095 (defun-checked triangle3d
(arg1 arg2 arg3
)
2096 (if (or (not ($listp arg1
))
2097 (not (= ($length arg1
) 3))
2099 (not (= ($length arg2
) 3))
2101 (not (= ($length arg3
) 3)))
2102 (merror "draw3d (triangle): vertices are not correct"))
2103 (let* ((x1 ($float
(cadr arg1
)))
2104 (y1 ($float
(caddr arg1
)))
2105 (z1 ($float
(cadddr arg1
)))
2106 (x2 ($float
(cadr arg2
)))
2107 (y2 ($float
(caddr arg2
)))
2108 (z2 ($float
(cadddr arg2
)))
2109 (x3 ($float
(cadr arg3
)))
2110 (y3 ($float
(caddr arg3
)))
2111 (z3 ($float
(cadddr arg3
)))
2112 (grobj (mesh `((mlist simp
)
2113 ((mlist simp
) ,x1
,y1
,z1
)
2114 ((mlist simp
) ,x1
,y1
,z1
) )
2117 ((mlist simp
) ,x2
,y2
,z2
)
2118 ((mlist simp
) ,x3
,y3
,z3
) ) )))
2119 (setf (gr-object-name grobj
) 'triangle
)
2128 ;; Object: 'quadrilateral3d'
2130 ;; quadrilateral([x1,y1,z1], [x2,y2,z2], [x3,y3,z3], [x4,y4,z4])
2138 (defun-checked quadrilateral3d
(arg1 arg2 arg3 arg4
)
2139 (if (or (not ($listp arg1
))
2140 (not (= ($length arg1
) 3))
2142 (not (= ($length arg2
) 3))
2144 (not (= ($length arg3
) 3))
2146 (not (= ($length arg4
) 3)))
2147 (merror "draw3d (quadrilateral): vertices are not correct"))
2148 (let* ((x1 ($float
(cadr arg1
)))
2149 (y1 ($float
(caddr arg1
)))
2150 (z1 ($float
(cadddr arg1
)))
2151 (x2 ($float
(cadr arg2
)))
2152 (y2 ($float
(caddr arg2
)))
2153 (z2 ($float
(cadddr arg2
)))
2154 (x3 ($float
(cadr arg3
)))
2155 (y3 ($float
(caddr arg3
)))
2156 (z3 ($float
(cadddr arg3
)))
2157 (x4 ($float
(cadr arg4
)))
2158 (y4 ($float
(caddr arg4
)))
2159 (z4 ($float
(cadddr arg4
)))
2160 (grobj (mesh `((mlist simp
)
2161 ((mlist simp
) ,x1
,y1
,z1
)
2162 ((mlist simp
) ,x2
,y2
,z2
))
2164 ((mlist simp
) ,x3
,y3
,z3
)
2165 ((mlist simp
) ,x4
,y4
,z4
)))))
2166 (setf (gr-object-name grobj
) 'quadrilateral
)
2175 ;; Object: 'parametric'
2177 ;; parametric(xfun,yfun,par,parmin,parmax)
2187 ;; Note: similar to draw2d-parametric in plot.lisp
2188 (defun-checked parametric
(xfun yfun par parmin parmax
)
2189 (let* ((nticks (get-option '$nticks
))
2191 (tmin ($float parmin
))
2192 (tmax ($float parmax
))
2193 (xmin most-positive-double-float
)
2194 (xmax most-negative-double-float
)
2195 (ymin most-positive-double-float
)
2196 (ymax most-negative-double-float
)
2197 (*plot-realpart
* *plot-realpart
*)
2198 (tt ($float parmin
))
2199 (eps (/ (- tmax tmin
) (- nticks
1)))
2202 (merror "draw2d (parametric): illegal range"))
2203 (when (not (subsetp (append (rest ($listofvars xfun
)) (rest ($listofvars yfun
))) (list par
) :test
#'like
))
2204 (merror "draw2d (parametric): non defined variable"))
2205 (setq *plot-realpart
* (get-option '$draw_realpart
))
2206 (setq f1
(coerce-float-fun xfun
`((mlist), par
)))
2207 (setq f2
(coerce-float-fun yfun
`((mlist), par
)))
2210 do
(setf xx
($float
(funcall f1 tt
)))
2211 (setf yy
($float
(funcall f2 tt
)))
2217 when
(>= tt tmax
) do
(loop-finish)
2218 do
(setq tt
(+ tt eps
))
2219 (if (>= tt tmax
) (setq tt tmax
)) ))
2220 ; update x-y ranges if necessary
2221 (update-ranges-2d xmin xmax ymin ymax
)
2224 :command
(format nil
" ~a w l lw ~a lt ~a lc ~a axis ~a"
2225 (make-obj-title (get-option '$key
))
2226 (get-option '$line_width
)
2227 (get-option '$line_type
)
2228 (hex-to-rgb (get-option '$color
))
2231 :points
`(,(make-array (length result
) :initial-contents result
))) ) )
2241 ;; polar(radius,ang,minang,maxang)
2250 ;; This object is constructed as a parametric function
2251 (defun-checked polar
(radius ang minang maxang
)
2252 (let ((grobj (parametric `((mtimes simp
) ,radius
((%cos simp
) ,ang
))
2253 `((mtimes simp
) ,radius
((%sin simp
) ,ang
))
2254 ang minang maxang
)))
2255 (setf (gr-object-name grobj
) 'polar
)
2264 ;; Object: 'spherical'
2266 ;; spherical(radius,az,minazi,maxazi,zen,minzen,maxzen)
2275 ;; This object is constructed as a parametric surface in 3d.
2276 ;; Functions are defined in format r=r(azimuth,zenith),
2277 ;; where, normally, azimuth is an angle in [0,2*%pi] and zenith in [0,%pi]
2278 (defun-checked spherical
(radius azi minazi maxazi zen minzen maxzen
)
2279 #+sbcl
(declare (notinline parametric_surface
))
2280 (let ((grobj (parametric_surface
2281 `((mtimes simp
) ,radius
((%sin simp
) ,zen
) ((%cos simp
) ,azi
))
2282 `((mtimes simp
) ,radius
((%sin simp
) ,zen
) ((%sin simp
) ,azi
))
2283 `((mtimes simp
) ,radius
((%cos simp
) ,zen
))
2285 zen minzen maxzen
)))
2286 (setf (gr-object-name grobj
) 'spherical
)
2296 ;; Object: 'cylindrical'
2298 ;; cylindrical(r,z,minz,maxz,azi,minazi,maxazi)
2307 ;; This object is constructed as a parametric surface in 3d.
2308 ;; Functions are defined in format z=z(radius,azimuth), where,
2309 ;; normally, azimuth is an angle in [0,2*%pi] and r any real
2310 (defun-checked cylindrical
(r z minz maxz azi minazi maxazi
)
2311 #+sbcl
(declare (notinline parametric_surface
))
2312 (let ((grobj (parametric_surface
2313 `((mtimes simp
) ,r
((%cos simp
) ,azi
))
2314 `((mtimes simp
) ,r
((%sin simp
) ,azi
))
2317 azi minazi maxazi
)))
2318 (setf (gr-object-name grobj
) 'cylindrical
)
2328 ;; Object: 'parametric3d'
2330 ;; parametric(xfun,yfun,zfun,par1,parmin,parmax)
2340 (defun-checked parametric3d
(xfun yfun zfun par1 parmin parmax
)
2341 (let* ((nticks (get-option '$nticks
))
2343 (tmin ($float parmin
))
2344 (tmax ($float parmax
))
2345 (xmin most-positive-double-float
)
2346 (xmax most-negative-double-float
)
2347 (ymin most-positive-double-float
)
2348 (ymax most-negative-double-float
)
2349 (zmin most-positive-double-float
)
2350 (zmax most-negative-double-float
)
2351 (*plot-realpart
* *plot-realpart
*)
2353 (eps (/ (- tmax tmin
) (- nticks
1)))
2355 ncols result f1 f2 f3 xx yy zz
)
2356 (when (not (subsetp (rest ($append
($listofvars xfun
) ($listofvars yfun
) ($listofvars zfun
))) (list par1
) :test
#'like
))
2357 (merror "draw3d (parametric): non defined variable"))
2358 (setq *plot-realpart
* (get-option '$draw_realpart
))
2359 (check-enhanced3d-model "parametric" '(0 1 3 99))
2360 (when (= *draw-enhanced3d-type
* 99)
2361 (update-enhanced3d-expression (list '(mlist) par1
)))
2363 (merror "draw3d (parametric): illegal range"))
2364 (setq f1
(coerce-float-fun xfun
`((mlist) ,par1
)))
2365 (setq f2
(coerce-float-fun yfun
`((mlist) ,par1
)))
2366 (setq f3
(coerce-float-fun zfun
`((mlist) ,par1
)))
2367 (setf ncols
(if (= *draw-enhanced3d-type
* 0) 3 4))
2368 (setf result
(make-array (* ncols nticks
)))
2370 (setf xx
(funcall f1 tt
))
2371 (setf yy
(funcall f2 tt
))
2372 (setf zz
(funcall f3 tt
))
2377 (setf (aref result
(incf count
)) xx
)
2378 (setf (aref result
(incf count
)) yy
)
2379 (setf (aref result
(incf count
)) zz
)
2380 ; check texture model
2381 (case *draw-enhanced3d-type
*
2382 ((1 99) (setf (aref result
(incf count
)) (funcall *draw-enhanced3d-fun
* tt
)))
2383 (3 (setf (aref result
(incf count
)) (funcall *draw-enhanced3d-fun
* xx yy zz
))))
2384 (setf tt
(+ tt eps
)) )
2385 ; update x-y ranges if necessary
2386 (update-ranges-3d xmin xmax ymin ymax zmin zmax
)
2389 :command
(format nil
" ~a w l lw ~a lt ~a lc ~a"
2390 (make-obj-title (get-option '$key
))
2391 (get-option '$line_width
)
2392 (get-option '$line_type
)
2393 (if (> *draw-enhanced3d-type
* 0)
2395 (hex-to-rgb (get-option '$color
))) )
2396 :groups
`((,ncols
0))
2397 :points
(list result
) )) )
2406 ;; Object: 'parametric_surface'
2408 ;; parametric_surface(xfun,yfun,zfun,par1,par1min,par1max,par2,par2min,par2max)
2420 (defun-checked parametric_surface
(xfun yfun zfun par1 par1min par1max par2 par2min par2max
)
2421 (let* ((ugrid (get-option '$xu_grid
))
2422 (vgrid (get-option '$yv_grid
))
2424 (umin ($float par1min
))
2425 (umax ($float par1max
))
2426 (vmin ($float par2min
))
2427 (vmax ($float par2max
))
2428 (xmin most-positive-double-float
)
2429 (xmax most-negative-double-float
)
2430 (ymin most-positive-double-float
)
2431 (ymax most-negative-double-float
)
2432 (zmin most-positive-double-float
)
2433 (zmax most-negative-double-float
)
2434 (*plot-realpart
* *plot-realpart
*)
2435 (ueps (/ (- umax umin
) (- ugrid
1)))
2436 (veps (/ (- vmax vmin
) (- vgrid
1)))
2440 ncols result f1 f2 f3 xx yy zz uu vv
)
2441 (when (not (subsetp (rest ($append
($listofvars xfun
) ($listofvars yfun
) ($listofvars zfun
))) (list par1 par2
) :test
#'like
))
2442 (merror "draw3d (parametric_surface): non defined variable"))
2443 (setq *plot-realpart
* (get-option '$draw_realpart
))
2444 (check-enhanced3d-model "parametric_surface" '(0 2 3 99))
2445 (when (= *draw-enhanced3d-type
* 99)
2446 (update-enhanced3d-expression (list '(mlist) par1 par2
)))
2447 (if (or (< umax umin
)
2449 (merror "draw3d (parametric_surface): illegal range"))
2450 (setq f1
(coerce-float-fun xfun
`((mlist) ,par1
,par2
)))
2451 (setq f2
(coerce-float-fun yfun
`((mlist) ,par1
,par2
)))
2452 (setq f3
(coerce-float-fun zfun
`((mlist) ,par1
,par2
)))
2453 (setf ncols
(if (= *draw-enhanced3d-type
* 0) 3 4))
2454 (setf result
(make-array (* ncols nu nv
)))
2455 (loop for j below nv
2456 initially
(setq vv vmin
)
2458 (loop for i below nu
2460 (setf xx
(funcall f1 uu vv
))
2461 (setf yy
(funcall f2 uu vv
))
2462 (setf zz
(funcall f3 uu vv
))
2467 (setf (aref result
(incf count
)) xx
)
2468 (setf (aref result
(incf count
)) yy
)
2469 (setf (aref result
(incf count
)) zz
)
2470 ; check texture model
2471 (case *draw-enhanced3d-type
*
2472 ((2 99) (setf (aref result
(incf count
)) (funcall *draw-enhanced3d-fun
* uu vv
)))
2473 (3 (setf (aref result
(incf count
)) (funcall *draw-enhanced3d-fun
* xx yy zz
))) )
2474 (setq uu
(+ uu ueps
))
2475 (if (> uu umax
) (setf uu umax
)))
2476 (setq vv
(+ vv veps
))
2477 (if (> vv vmax
) (setf vv vmax
)))
2478 ; update x-y-z ranges if necessary
2479 (update-ranges-3d xmin xmax ymin ymax zmin zmax
)
2481 :name
'parametric_surface
2482 :command
(format nil
" ~a w ~a lw ~a lt ~a lc ~a"
2483 (make-obj-title (get-option '$key
))
2484 (if (> *draw-enhanced3d-type
* 0) "pm3d" "l")
2485 (get-option '$line_width
)
2486 (get-option '$line_type
)
2487 (hex-to-rgb (get-option '$color
)))
2488 :groups
`((,ncols
,nu
)) ; ncols is 4 or 3, depending on colored 4th dimension or not
2489 :points
(list result
))))
2499 ;; tube(xfun,yfun,zfun,rad,par1,parmin,parmax)
2511 (defmacro check-tube-extreme
(ex cx cy cz circ
)
2512 `(when (equal (nth ,ex
(get-option '$capping
)) t
)
2516 (when (> *draw-transform-dimensions
* 0)
2517 (setf cxx
(funcall *draw-transform-f1
* ,cx
,cy
,cz
)
2518 cyy
(funcall *draw-transform-f2
* ,cx
,cy
,cz
)
2519 czz
(funcall *draw-transform-f3
* ,cx
,cy
,cz
)))
2520 (case *draw-enhanced3d-type
*
2521 (0 (setf ,circ
(list cxx cyy czz
)))
2522 ((1 99) (setf ,circ
(list cxx cyy czz
(funcall *draw-enhanced3d-fun
* tt
))))
2523 (3 (setf ,circ
(list cxx cyy czz
(funcall *draw-enhanced3d-fun
* cxx cyy czz
)))))
2525 (setf result
(append result
,circ
))))))
2527 (defun-checked tube
(xfun yfun zfun rad par1 parmin parmax
)
2528 (let* ((ugrid (get-option '$xu_grid
))
2529 (vgrid (get-option '$yv_grid
))
2531 (tmin ($float parmin
))
2532 (tmax ($float parmax
))
2533 (vmax 6.283185307179586) ; = float(2*%pi)
2534 (xmin most-positive-double-float
)
2535 (xmax most-negative-double-float
)
2536 (ymin most-positive-double-float
)
2537 (ymax most-negative-double-float
)
2538 (zmin most-positive-double-float
)
2539 (zmax most-negative-double-float
)
2540 (teps (/ (- tmax tmin
) (- ugrid
1)))
2541 (veps (/ vmax
(- vgrid
1)))
2547 xx yy zz module r vv rcos rsin
2549 uxold uyold uzold ttnext
)
2551 (merror "draw3d (tube): illegal range"))
2552 (when (not (subsetp (rest ($append
($listofvars xfun
) ($listofvars yfun
)
2553 ($listofvars zfun
) ($listofvars rad
)))
2554 (list par1
) :test
#'like
))
2555 (merror "draw3d (tube): non defined variable"))
2556 (check-enhanced3d-model "tube" '(0 1 3 99))
2557 (when (= *draw-enhanced3d-type
* 99)
2558 (update-enhanced3d-expression (list '(mlist) par1
)))
2559 (setq f1
(coerce-float-fun xfun
`((mlist) ,par1
)))
2560 (setq f2
(coerce-float-fun yfun
`((mlist) ,par1
)))
2561 (setq f3
(coerce-float-fun zfun
`((mlist) ,par1
)))
2562 (setf ncols
(if (= *draw-enhanced3d-type
* 0) 3 4))
2564 (coerce-float-fun rad
`((mlist) ,par1
)))
2566 ; calculate center and radius of circle
2568 ((= tt tmin
) ; 1st iteration
2569 (setf cx
(funcall f1 tt
)
2573 (check-tube-extreme 1 cx cy cz circ
)
2574 (setf nx
(- (funcall f1 ttnext
) cx
)
2575 ny
(- (funcall f2 ttnext
) cy
)
2576 nz
(- (funcall f3 ttnext
) cz
)))
2577 (t ; all next iterations along the parametric curve
2581 (setf cx
(funcall f1 tt
)
2584 (setf nx
(- cx cxold
)
2587 (setf r
(funcall radius tt
))
2588 ; calculate the unitary normal vector
2589 (setf module
(sqrt (+ (* nx nx
) (* ny ny
) (* nz nz
))))
2590 (setf nx
(/ nx module
)
2593 ; calculate unitary vector perpendicular to n=(nx,ny,nz)
2594 ; ux.nx+uy.ny+uz.nz=0 => ux=-t(ny+nz)/nx, uy=uz=t
2598 (setf ux
1.0 uy
0.0 uz
0.0))
2600 (setf ux
0.0 uy
1.0 uz
0.0))
2602 (setf ux
0.0 uy
0.0 uz
1.0))
2603 (t ; all other cases
2604 (setf ux
(- (/ (+ ny nz
) nx
))
2607 (setf module
(sqrt (+ (* ux ux
) (* uy uy
) (* uz uz
))))
2608 (setf ux
(/ ux module
)
2611 (when (and (> tt tmin
)
2622 ; vector v = n times u
2623 (setf vx
(- (* ny uz
) (* nz uy
))
2624 vy
(- (* nz ux
) (* nx uz
))
2625 vz
(- (* nx uy
) (* ny ux
)))
2626 ; parametric equation of the circumference of radius
2627 ; r and centered at c=(cx,cy,cz):
2628 ; x(t) = c + r(cos(t)u + sin(t)v),
2629 ; for t in (0, 2*%pi)
2632 (loop for i below vgrid do
2633 (setf rcos
(* r
(cos vv
))
2634 rsin
(* r
(sin vv
)))
2635 (setf xx
(+ cx
(* rcos ux
) (* rsin vx
))
2636 yy
(+ cy
(* rcos uy
) (* rsin vy
))
2637 zz
(+ cz
(* rcos uz
) (* rsin vz
)))
2642 ; check texture model
2643 (case *draw-enhanced3d-type
*
2644 (0 (setf circ
(cons (list xx yy zz
) circ
)))
2645 ((1 99) (setf circ
(cons (list xx yy zz
(funcall *draw-enhanced3d-fun
* tt
)) circ
)))
2646 (3 (setf circ
(cons (list xx yy zz
(funcall *draw-enhanced3d-fun
* xx yy zz
)) circ
))))
2647 (setf vv
(+ vv veps
))
2648 (when (> vv vmax
) (setf vv vmax
)) ) ; loop for
2649 (setf result
(append result
(apply #'append circ
)))
2650 when
(>= tt tmax
) do
(loop-finish)
2651 do
(setf tt
(+ tt teps
))
2652 (when (> tt tmax
) (setf tt tmax
)) ) ; loop do
2653 (check-tube-extreme 2 cx cy cz circ
)
2654 ; update x-y-z ranges
2655 (update-ranges-3d xmin xmax ymin ymax zmin zmax
)
2658 :command
(format nil
" ~a w ~a lw ~a lt ~a lc ~a"
2659 (make-obj-title (get-option '$key
))
2660 (if (> *draw-enhanced3d-type
* 0) "pm3d" "l")
2661 (get-option '$line_width
)
2662 (get-option '$line_type
)
2663 (hex-to-rgb (get-option '$color
)))
2664 :groups
`((,ncols
,vgrid
))
2665 :points
`(,(make-array (length result
) :element-type
'flonum
2666 :initial-contents result
)))))
2676 ;; image(matrix_of_numbers,x0,y0,width,height)
2677 ;; image(matrix_of_[r,g,b],x0,y0,width,height)
2678 ;; image(picture_object,x0,y0,width,height)
2682 (defun-checked image
(mat x0 y0 width height
)
2683 (let ( (fx0 ($float x0
))
2685 (fwidth ($float width
))
2686 (fheight ($float height
))
2687 result nrows ncols dx dy n
)
2688 (cond (($matrixp mat
)
2689 (setf nrows
(length (cdr mat
))
2690 ncols
(length (cdadr mat
)))
2691 (setf dx
(/ fwidth ncols
)
2692 dy
(/ fheight nrows
))
2693 (if (not ($listp
(cadadr mat
))) ; it's a matrix of reals
2694 (setf n
3) ; 3 numbers to be sent to gnuplot: x,y,value
2695 (setf n
5)) ; 5 numbers to be sent: x,y,r,g,b
2697 (3 (setf result
(make-array (* 3 nrows ncols
) :element-type
'flonum
))
2698 (let ((yi (+ fy0 height
(* dy -
0.5)))
2701 (loop for row on
(cdr mat
) by
#'cdr do
2702 (setf xi
(+ fx0
(* dx
0.5)))
2703 (loop for col on
(cdar row
) by
#'cdr do
2704 (setf (aref result
(incf counter
)) xi
2705 (aref result
(incf counter
)) yi
2706 (aref result
(incf counter
)) ($float
(car col
)))
2707 (setf xi
(+ xi dx
)))
2708 (setf yi
(- yi dy
)) )))
2709 (5 (setf result
(make-array (* 5 nrows ncols
) :element-type
'flonum
))
2710 (let ((yi (+ fy0 height
(* dy -
0.5)))
2713 (loop for row on
(cdr mat
) by
#'cdr do
2714 (setf xi
(+ fx0
(* dx
0.5)))
2715 (loop for col on
(cdar row
) by
#'cdr do
2716 (setf colors
(cdar col
))
2717 (setf (aref result
(incf counter
)) xi
2718 (aref result
(incf counter
)) yi
2719 (aref result
(incf counter
)) ($float
(car colors
))
2720 (aref result
(incf counter
)) ($float
(cadr colors
))
2721 (aref result
(incf counter
)) ($float
(caddr colors
)))
2722 (setf xi
(+ xi dx
)))
2723 (setf yi
(- yi dy
)) )))))
2725 (setf nrows
(nth 3 mat
) ; picture height
2726 ncols
(nth 2 mat
)) ; picture width
2727 (setf dx
(/ fwidth ncols
)
2728 dy
(/ fheight nrows
))
2730 ((equal (nth 1 mat
) '$level
) ; gray level picture
2731 (setf n
3)) ; 3 numbers to be sent to gnuplot: x,y,value
2732 ((equal (nth 1 mat
) '$rgb
)
2733 (setf n
5)) ; 5 numbers to be sent: x,y,r,g,b
2734 ((equal (nth 1 mat
) '$rgb_alpha
)
2735 (setf n
6)) ; 6 numbers to be sent: x,y,r,g,b,t
2736 (t (merror "image: picture type ~M not recognized." (nth 1 mat
))))
2737 (setf result
(make-array (* n nrows ncols
) :element-type
'flonum
))
2738 (let ((yi (+ fy0 height
(* dy -
0.5)))
2742 (loop for r from
0 below nrows do
2743 (setf xi
(+ fx0
(* dx
0.5)))
2744 (loop for c from
0 below ncols do
2745 (setf (aref result
(incf count1
)) xi
)
2746 (setf (aref result
(incf count1
)) yi
)
2747 (loop for q from
3 to n do
2748 (setf (aref result
(incf count1
))
2749 ($float
(aref (nth 4 mat
) (incf count2
)))))
2750 (setf xi
(+ xi dx
)))
2751 (setf yi
(- yi dy
)))))
2753 (merror "draw2d (image): Argument not recognized")))
2754 ; update x-y ranges if necessary
2755 (update-ranges-2d fx0
(+ fx0 fwidth
) fy0
(+ fy0 fheight
))
2759 (3 (format nil
" t '' w image"))
2760 (5 (format nil
" t '' w rgbimage"))
2761 (6 (format nil
" t '' w rgbalpha")))
2763 (3 '((3 0))) ; numbers are sent to gnuplot in groups of 3, no blank lines
2764 (5 '((5 0))) ; numbers in groups of 5, no blank lines
2765 (6 '((6 0)))) ; numbers in groups of 6, no blank lines
2766 :points
(list result
)) ) )
2773 (defmacro write-palette-code
()
2774 '(let ((pal (get-option '$palette
)))
2777 (format nil
"set palette gray~%"))
2778 ((equal pal
'$color
)
2779 (format nil
"set palette rgbformulae 7,5,15~%"))
2782 (every #'(lambda (x) (and (integerp x
) (<= (abs x
) 36))) pal
) )
2783 (format nil
"set palette rgbformulae ~a,~a,~a~%"
2784 (car pal
) (cadr pal
) (caddr pal
)))
2786 (every #'(lambda (x) (and (listp x
) (= (length x
) 3))) pal
) )
2789 (with-output-to-string (stream)
2790 (format stream
"set palette defined ( \\~%")
2792 (setf triplete
(nth k pal
))
2793 (format stream
" ~a ~a ~a ~a "
2794 k
(car triplete
) (cadr triplete
) (caddr triplete
))
2796 (format stream
")~%")
2797 (format stream
", \\~%") )))))
2799 (merror "draw: illegal palette description")))))
2803 (defvar *2d-graphic-objects
* (make-hash-table))
2805 ; table of basic 2d graphic objects
2806 (setf (gethash '$points
*2d-graphic-objects
*) 'points
2807 (gethash '$errors
*2d-graphic-objects
*) 'errors
2808 (gethash '$polygon
*2d-graphic-objects
*) 'polygon
2809 (gethash '$ellipse
*2d-graphic-objects
*) 'ellipse
2810 (gethash '$triangle
*2d-graphic-objects
*) 'triangle
2811 (gethash '$rectangle
*2d-graphic-objects
*) 'rectangle
2812 (gethash '$quadrilateral
*2d-graphic-objects
*) 'quadrilateral
2813 (gethash '$region
*2d-graphic-objects
*) 'region
2814 (gethash '$explicit
*2d-graphic-objects
*) 'explicit
2815 (gethash '$implicit
*2d-graphic-objects
*) 'implicit
2816 (gethash '$parametric
*2d-graphic-objects
*) 'parametric
2817 (gethash '$vector
*2d-graphic-objects
*) 'vect
2818 (gethash '$label
*2d-graphic-objects
*) 'label
2819 (gethash '$bars
*2d-graphic-objects
*) 'bars
2820 (gethash '$polar
*2d-graphic-objects
*) 'polar
2821 (gethash '$image
*2d-graphic-objects
*) 'image
2822 (gethash '%points
*2d-graphic-objects
*) 'points
2823 (gethash '%errors
*2d-graphic-objects
*) 'errors
2824 (gethash '%polygon
*2d-graphic-objects
*) 'polygon
2825 (gethash '%ellipse
*2d-graphic-objects
*) 'ellipse
2826 (gethash '%triangle
*2d-graphic-objects
*) 'triangle
2827 (gethash '%rectangle
*2d-graphic-objects
*) 'rectangle
2828 (gethash '%quadrilateral
*2d-graphic-objects
*) 'quadrilateral
2829 (gethash '%region
*2d-graphic-objects
*) 'region
2830 (gethash '%explicit
*2d-graphic-objects
*) 'explicit
2831 (gethash '%implicit
*2d-graphic-objects
*) 'implicit
2832 (gethash '%parametric
*2d-graphic-objects
*) 'parametric
2833 (gethash '%vector
*2d-graphic-objects
*) 'vect
2834 (gethash '%label
*2d-graphic-objects
*) 'label
2835 (gethash '%bars
*2d-graphic-objects
*) 'bars
2836 (gethash '%polar
*2d-graphic-objects
*) 'polar
2837 (gethash '%image
*2d-graphic-objects
*) 'image
)
2839 (defun make-scene-2d (args)
2843 (ini-local-option-variables)
2845 (setf largs
(listify-arguments args
))
2846 ; update option values and detect objects to be plotted
2848 (cond ((equal ($op x
) "=")
2849 (update-gr-option ($lhs x
) ($rhs x
)))
2850 ((not (null (gethash (setf aux
(caar x
)) *2d-graphic-objects
*)))
2854 (list (apply (gethash aux
*2d-graphic-objects
*) (rest x
))))))
2855 (t (merror "draw: 2D graphic object not recognized, ~M" aux
))))
2856 ; save in plotcmd the gnuplot preamble
2858 (concatenate 'string
2859 (unless (or *multiplot-is-active
*
2860 (member (get-option '$terminal
) '($eps $epslatex $epslatex_standalone
)))
2861 (format nil
"set obj 1 fc rgb '~a' fs solid 1.0 noborder ~%"
2862 (get-option '$background_color
)) )
2863 (if (equal (get-option '$proportional_axes
) '$none
)
2864 (format nil
"set size noratio~%")
2865 (format nil
"set size ratio -1~%") )
2866 ; this let statement is to prevent error messages from gnuplot when
2867 ; the amplitude of the ranges equals zero
2868 (let ((xi (first (get-option '$xrange
)))
2869 (xf (second (get-option '$xrange
)))
2870 (yi (first (get-option '$yrange
)))
2871 (yf (second (get-option '$yrange
)))
2872 (x2i (first (get-option '$xrange_secondary
)))
2873 (x2f (second (get-option '$xrange_secondary
)))
2874 (y2i (first (get-option '$yrange_secondary
)))
2875 (y2f (second (get-option '$yrange_secondary
))) )
2876 (when (and (get-option '$xrange
) (near-equal xi xf
))
2877 (setf xi
(- xi
0.01)
2879 (when (and (get-option '$xrange_secondary
) (near-equal x2i x2f
))
2880 (setf x2i
(- x2i
0.01)
2882 (when (and (get-option '$yrange
) (near-equal yi yf
))
2883 (setf yi
(- yi
0.01)
2885 (when (and (get-option '$yrange_secondary
) (near-equal y2i y2f
))
2886 (setf y2i
(- y2i
0.01)
2888 (format nil
"~a~a~a~a"
2889 (if (get-option '$xrange
)
2890 (format nil
"set xrange [~a:~a]~%" xi xf
)
2892 (if (get-option '$xrange_secondary
)
2893 (format nil
"set x2range [~a:~a]~%" x2i x2f
)
2895 (if (get-option '$yrange
)
2896 (format nil
"set yrange [~a:~a]~%" yi yf
)
2898 (if (get-option '$yrange_secondary
)
2899 (format nil
"set y2range [~a:~a]~%" y2i y2f
)
2901 (if (get-option '$cbrange
)
2902 (format nil
"set cbrange [~a:~a]~%"
2903 (first (get-option '$cbrange
))
2904 (second (get-option '$cbrange
)))
2905 (format nil
"set cbrange [*:*]~%") )
2906 (if (get-option '$logx
)
2907 (format nil
"set logscale x~%")
2908 (format nil
"unset logscale x~%"))
2909 (if (get-option '$logx_secondary
)
2910 (format nil
"set logscale x2~%")
2911 (format nil
"unset logscale x2~%"))
2912 (if (get-option '$logy
)
2913 (format nil
"set logscale y~%")
2914 (format nil
"unset logscale y~%"))
2915 (if (get-option '$logy_secondary
)
2916 (format nil
"set logscale y2~%")
2917 (format nil
"unset logscale y2~%"))
2918 (if (get-option '$logcb
)
2919 (format nil
"set logscale cb~%")
2920 (format nil
"unset logscale cb~%") )
2922 ( if
(equal (car (get-option '$grid
)) 0)
2923 (format nil
"unset grid~%")
2924 (format nil
"set grid xtics ytics mxtics mytics~%set mxtics ~d~%set mytics ~d~%"
2925 (car (get-option '$grid
))
2926 (cadr (get-option '$grid
))
2930 (format nil
"set title '~a'~%" (get-option '$title
))
2931 (format nil
"set xlabel '~a'~%" (get-option '$xlabel
))
2932 (format nil
"set x2label '~a'~%" (get-option '$xlabel_secondary
))
2933 (format nil
"set ylabel '~a'~%" (get-option '$ylabel
))
2934 (format nil
"set y2label '~a'~%" (get-option '$ylabel_secondary
))
2936 (if (get-option '$axis_bottom
) (setf suma
(+ suma
1)))
2937 (if (get-option '$axis_left
) (setf suma
(+ suma
2)))
2938 (if (get-option '$axis_top
) (setf suma
(+ suma
4)))
2939 (if (get-option '$axis_right
) (setf suma
(+ suma
8)))
2940 (format nil
"set border ~a~%" suma
) )
2941 (if (get-option '$key_pos
)
2942 (format nil
"set key ~a~%" (get-option '$key_pos
))
2943 (format nil
"set key top right~%") )
2944 (if (get-option '$xaxis
)
2945 (format nil
"set xzeroaxis lw ~a lt ~a lc ~a~%"
2946 (get-option '$xaxis_width
)
2947 (get-option '$xaxis_type
)
2948 (hex-to-rgb (get-option '$xaxis_color
)) )
2949 (format nil
"unset xzeroaxis~%"))
2950 (if (get-option '$yaxis
)
2951 (format nil
"set yzeroaxis lw ~a lt ~a lc ~a~%"
2952 (get-option '$yaxis_width
)
2953 (get-option '$yaxis_type
)
2954 (hex-to-rgb (get-option '$yaxis_color
)) )
2955 (format nil
"unset yzeroaxis~%"))
2956 (if (null (get-option '$xtics_secondary
))
2957 (format nil
"unset x2tics~%set xtics nomirror~%")
2958 (format nil
"set x2tics ~a ~a ~a~%"
2959 (if (get-option '$xtics_secondary_rotate
) "rotate" "norotate")
2960 (if (get-option '$xtics_secondary_axis
) "axis" "border")
2961 (get-option '$xtics_secondary
)))
2962 (if (null (get-option '$xtics
))
2963 (format nil
"unset xtics~%")
2964 (format nil
"set xtics ~a ~a ~a~%"
2965 (if (get-option '$xtics_rotate
) "rotate" "norotate")
2966 (if (get-option '$xtics_axis
) "axis" "border")
2967 (get-option '$xtics
)))
2968 (if (null (get-option '$ytics_secondary
))
2969 (format nil
"unset y2tics~%set ytics nomirror~%")
2970 (format nil
"set ytics nomirror~%set y2tics ~a ~a ~a~%"
2971 (if (get-option '$ytics_secondary_rotate
) "rotate" "norotate")
2972 (if (get-option '$ytics_secondary_axis
) "axis" "border")
2973 (get-option '$ytics_secondary
)))
2974 (if (null (get-option '$ytics
))
2975 (format nil
"unset ytics~%")
2976 (format nil
"set ytics ~a ~a ~a~%"
2977 (if (get-option '$ytics_rotate
) "rotate" "norotate")
2978 (if (get-option '$ytics_axis
) "axis" "border")
2979 (get-option '$ytics
)))
2980 (if (null (get-option '$cbtics
))
2981 (format nil
"unset cbtics~%")
2982 (format nil
"set cbtics ~a~%" (get-option '$cbtics
) ))
2983 (if (get-option '$colorbox
)
2984 (format nil
"set colorbox~%")
2985 (format nil
"unset colorbox~%"))
2986 (format nil
"set cblabel '~a'~%"
2987 (if (stringp (get-option '$colorbox
))
2988 (get-option '$colorbox
)
2990 (write-palette-code)
2991 (if (not (string= (get-option '$user_preamble
) ""))
2992 (format nil
"~a~%" (get-option '$user_preamble
))) ) )
2994 (setf *allocations
* (cons (get-option '$allocation
) *allocations
*))
2995 ; scene description: (dimensions, gnuplot preamble in string format, list of objects)
2998 plotcmd
; gnuplot preamble
2999 objects
; list of objects to be plotted
3007 (defvar *3d-graphic-objects
* (make-hash-table))
3009 ; table of basic 3d graphic objects
3010 (setf (gethash '$points
*3d-graphic-objects
*) 'points3d
3011 (gethash '$elevation_grid
*3d-graphic-objects
*) 'elevation_grid
3012 (gethash '$mesh
*3d-graphic-objects
*) 'mesh
3013 (gethash '$triangle
*3d-graphic-objects
*) 'triangle3d
3014 (gethash '$quadrilateral
*3d-graphic-objects
*) 'quadrilateral3d
3015 (gethash '$explicit
*3d-graphic-objects
*) 'explicit3d
3016 (gethash '$implicit
*3d-graphic-objects
*) 'implicit3d
3017 (gethash '$parametric
*3d-graphic-objects
*) 'parametric3d
3018 (gethash '$vector
*3d-graphic-objects
*) 'vect3d
3019 (gethash '$label
*3d-graphic-objects
*) 'label
3020 (gethash '$parametric_surface
*3d-graphic-objects
*) 'parametric_surface
3021 (gethash '$tube
*3d-graphic-objects
*) 'tube
3022 (gethash '$spherical
*3d-graphic-objects
*) 'spherical
3023 (gethash '$cylindrical
*3d-graphic-objects
*) 'cylindrical
3024 (gethash '%points
*3d-graphic-objects
*) 'points3d
3025 (gethash '%elevation_grid
*3d-graphic-objects
*) 'elevation_grid
3026 (gethash '%mesh
*3d-graphic-objects
*) 'mesh
3027 (gethash '%triangle
*3d-graphic-objects
*) 'triangle3d
3028 (gethash '%quadrilateral
*3d-graphic-objects
*) 'quadrilateral3d
3029 (gethash '%explicit
*3d-graphic-objects
*) 'explicit3d
3030 (gethash '%implicit
*3d-graphic-objects
*) 'implicit3d
3031 (gethash '%parametric
*3d-graphic-objects
*) 'parametric3d
3032 (gethash '%vector
*3d-graphic-objects
*) 'vect3d
3033 (gethash '%label
*3d-graphic-objects
*) 'label
3034 (gethash '%parametric_surface
*3d-graphic-objects
*) 'parametric_surface
3035 (gethash '%tube
*3d-graphic-objects
*) 'tube
3036 (gethash '%spherical
*3d-graphic-objects
*) 'spherical
3037 (gethash '%cylindrical
*3d-graphic-objects
*) 'cylindrical
)
3039 ;; This function builds a 3d scene by calling the
3040 ;; graphic objects constructors.
3041 (defun make-scene-3d (args)
3045 (ini-local-option-variables)
3047 (setf largs
(listify-arguments args
))
3048 ; update option values and detect objects to be plotted
3050 (cond ((equal ($op x
) "=")
3051 (update-gr-option ($lhs x
) ($rhs x
)))
3052 ((not (null (gethash (setf aux
(caar x
)) *3d-graphic-objects
*)))
3056 (list (apply (gethash aux
*3d-graphic-objects
*) (rest x
))))))
3057 (t (merror "draw: 3D graphic object not recognized, ~M" aux
) )))
3058 ; save in plotcmd the gnuplot preamble
3060 (concatenate 'string
3061 (format nil
"set style rectangle fillcolor rgb '~a' fs solid 1.0 noborder~%"
3062 (get-option '$background_color
)) ; background rectangle
3063 ; this let statement is to prevent error messages in gnuplot when
3064 ; the amplitude of the ranges equals zero
3065 (let ((xi (first (get-option '$xrange
)))
3066 (xf (second (get-option '$xrange
)))
3067 (yi (first (get-option '$yrange
)))
3068 (yf (second (get-option '$yrange
)))
3069 (zi (first (get-option '$zrange
)))
3070 (zf (second (get-option '$zrange
))))
3071 (when (near-equal xi xf
)
3072 (setf xi
(- xi
0.01)
3074 (when (near-equal yi yf
)
3075 (setf yi
(- yi
0.01)
3077 (when (near-equal zi zf
)
3078 (setf zi
(- zi
0.01)
3080 (format nil
"set xrange [~a:~a]~%set yrange [~a:~a]~%set zrange [~a:~a]~%"
3082 (if (get-option '$cbrange
)
3083 (format nil
"set cbrange [~a:~a]~%"
3084 (first (get-option '$cbrange
))
3085 (second (get-option '$cbrange
)) )
3086 (format nil
"set cbrange [*:*]~%") )
3087 (case (get-option '$contour
)
3088 ($surface
(format nil
"set contour surface~%set cntrparam levels ~a~%"
3089 (get-option '$contour_levels
) ))
3090 ($base
(format nil
"set contour base~%set cntrparam levels ~a~%"
3091 (get-option '$contour_levels
) ))
3092 ($both
(format nil
"set contour both~%set cntrparam levels ~a~%"
3093 (get-option '$contour_levels
) ))
3094 ($map
(format nil
"set contour base~%unset surface~%set cntrparam levels ~a~%"
3095 (get-option '$contour_levels
))) )
3096 (format nil
"set title '~a'~%" (get-option '$title
))
3097 (format nil
"set xlabel '~a'~%" (get-option '$xlabel
))
3098 (format nil
"set ylabel '~a'~%" (get-option '$ylabel
))
3099 (if (< (length (get-option '$zlabel
)) 5)
3100 (format nil
"set zlabel '~a'~%" (get-option '$zlabel
))
3101 (format nil
"set zlabel '~a' rotate~%" (get-option '$zlabel
)) )
3102 (format nil
"set datafile missing 'NIL'~%")
3103 (if (get-option '$logx
)
3104 (format nil
"set logscale x~%")
3105 (format nil
"unset logscale x~%"))
3106 (if (get-option '$logy
)
3107 (format nil
"set logscale y~%")
3108 (format nil
"unset logscale y~%"))
3109 (if (get-option '$logz
)
3110 (format nil
"set logscale z~%")
3111 (format nil
"unset logscale z~%"))
3112 (if (get-option '$key_pos
)
3113 (format nil
"set key ~a~%" (get-option '$key_pos
))
3114 (format nil
"set key top center~%") )
3115 (if (get-option '$logcb
)
3116 (format nil
"set logscale cb~%")
3117 (format nil
"unset logscale cb~%") )
3118 (if (equal (car (get-option '$grid
)) 0)
3119 (format nil
"unset grid~%")
3120 (format nil
"set grid xtics ytics ztics mxtics mytics mztics~%set mxtics ~d~%set mytics ~d~%"
3121 (car (get-option '$grid
))
3122 (cadr (get-option '$grid
))
3125 (if (get-option '$xaxis
)
3126 (format nil
"set xzeroaxis lw ~a lt ~a lc ~a~%"
3127 (get-option '$xaxis_width
)
3128 (get-option '$xaxis_type
)
3129 (hex-to-rgb (get-option '$xaxis_color
)) )
3130 (format nil
"unset xzeroaxis~%"))
3131 (if (get-option '$yaxis
)
3132 (format nil
"set yzeroaxis lw ~a lt ~a lc ~a~%"
3133 (get-option '$yaxis_width
)
3134 (get-option '$yaxis_type
)
3135 (hex-to-rgb (get-option '$yaxis_color
)) )
3136 (format nil
"unset yzeroaxis~%"))
3137 (if (get-option '$zaxis
)
3138 (format nil
"set zzeroaxis lw ~a lt ~a lc ~a~%"
3139 (get-option '$zaxis_width
)
3140 (get-option '$zaxis_type
)
3141 (hex-to-rgb (get-option '$zaxis_color
)))
3142 (format nil
"unset zzeroaxis~%"))
3143 (if (null (get-option '$xtics
))
3144 (format nil
"unset xtics~%")
3145 (format nil
"set xtics ~a ~a ~a~%"
3146 (if (get-option '$xtics_rotate
) "rotate" "norotate")
3147 (if (get-option '$xtics_axis
) "axis" "border")
3148 (get-option '$xtics
)))
3149 (if (null (get-option '$ytics
))
3150 (format nil
"unset ytics~%")
3151 (format nil
"set ytics ~a ~a ~a~%"
3152 (if (get-option '$ytics_rotate
) "rotate" "norotate")
3153 (if (get-option '$ytics_axis
) "axis" "border")
3154 (get-option '$ytics
)))
3155 (if (null (get-option '$ztics
))
3156 (format nil
"unset ztics~%")
3157 (format nil
"set ztics ~a ~a ~a~%"
3158 (if (get-option '$ztics_rotate
) "rotate" "norotate")
3159 (if (get-option '$ztics_axis
) "axis" "border")
3160 (get-option '$ztics
)))
3161 (if (null (get-option '$cbtics
))
3162 (format nil
"unset cbtics~%")
3163 (format nil
"set cbtics ~a~%"
3164 (get-option '$cbtics
)) )
3165 (if (or (eql (get-option '$contour
) '$map
)
3166 (eql (get-option '$view
) '$map
) )
3167 (format nil
"set view map~%~a~%"
3168 (if (equal (get-option '$proportional_axes
) '$none
)
3170 "set size ratio -1") )
3171 (format nil
"set view ~a, ~a, 1, 1~%~a~%"
3172 (first (get-option '$view
))
3173 (second (get-option '$view
))
3174 (case (get-option '$proportional_axes
)
3175 ($xy
"set view equal xy" )
3176 ($xyz
"set view equal xyz")
3178 (if (not (get-option '$axis_3d
))
3179 (format nil
"set border 0~%unset xtics~%unset ytics~%unset ztics~%"))
3180 (when (not (null (get-option '$enhanced3d
)))
3181 (if (null (get-option '$wired_surface
))
3182 (format nil
"set pm3d at s ~a explicit~%" (get-option '$interpolate_color
))
3183 (format nil
"set style line 1 lt 1 lw 1 lc rgb '#000000'~%set pm3d at s depthorder explicit hidden3d 1~%") ))
3184 (if (get-option '$surface_hide
)
3185 (format nil
"set hidden3d nooffset~%"))
3186 (if (get-option '$xyplane
)
3187 (format nil
"set xyplane at ~a~%" (get-option '$xyplane
)))
3188 (if (get-option '$colorbox
)
3189 (format nil
"set colorbox~%")
3190 (format nil
"unset colorbox~%"))
3191 (format nil
"set cblabel '~a'~%"
3192 (if (stringp (get-option '$colorbox
))
3193 (get-option '$colorbox
)
3195 (write-palette-code)
3196 (if (not (string= (get-option '$user_preamble
) ""))
3197 (format nil
"~a~%" (get-option '$user_preamble
))) ))
3199 (setf *allocations
* (cons (get-option '$allocation
) *allocations
*))
3200 ; scene description: (dimensions, gnuplot preamble in string format, list of objects)
3203 plotcmd
; gnuplot preamble
3204 objects
; list of objects to be plotted
3213 (defmacro write-subarray
(arr str
)
3217 #'concatenate
'string
3220 #'(lambda (z) (format nil
"~a " z
))
3225 (defun draw_gnuplot (&rest args
)
3226 (ini-global-options)
3228 (setf *allocations
* nil
)
3230 (scenes-list '((mlist simp
))) ; these two variables will be used
3231 gfn
; gnuplot_file_name
3232 dfn
; data_file_name
3233 scene-short-description
; to build the text output
3235 cmdstorage
; file maxout.gnuplot
3236 datastorage
; file data.gnuplot
3237 datapath
; path to data.gnuplot
3239 nrows width height
; multiplot parameters
3240 isanimatedgif ismultipage is1stobj biglist grouplist largs
)
3242 (setf largs
(listify-arguments args
))
3244 (cond ((equal ($op x
) "=")
3246 ($terminal
(update-gr-option '$terminal
($rhs x
)))
3247 ($columns
(update-gr-option '$columns
($rhs x
)))
3248 ($dimensions
(update-gr-option '$dimensions
($rhs x
)))
3249 ($file_name
(update-gr-option '$file_name
($rhs x
)))
3250 ($gnuplot_file_name
(update-gr-option '$gnuplot_file_name
($rhs x
)))
3251 ($data_file_name
(update-gr-option '$data_file_name
($rhs x
)))
3252 ($delay
(update-gr-option '$delay
($rhs x
)))
3254 ; deprecated global options
3255 ($file_bgcolor
(update-gr-option '$file_bgcolor
($rhs x
)))
3256 ($pic_width
(update-gr-option '$pic_width
($rhs x
)))
3257 ($pic_height
(update-gr-option '$pic_height
($rhs x
)))
3258 ($eps_width
(update-gr-option '$eps_width
($rhs x
)))
3259 ($eps_height
(update-gr-option '$eps_height
($rhs x
)))
3260 ($pdf_width
(update-gr-option '$pdf_width
($rhs x
)))
3261 ($pdf_height
(update-gr-option '$pdf_height
($rhs x
)))
3263 (otherwise (merror "draw: unknown global option ~M " ($lhs x
)))))
3264 ((equal (caar x
) '$gr3d
)
3265 (setf scenes
(append scenes
(list (funcall #'make-scene-3d
(rest x
))))))
3266 ((equal (caar x
) '$gr2d
)
3267 (setf scenes
(append scenes
(list (funcall #'make-scene-2d
(rest x
))))))
3269 (merror "draw: item ~M is not recognized" x
))) )
3271 (equal (get-option '$terminal
) '$animated_gif
))
3273 (member (get-option '$terminal
)
3274 '($multipage_pdf $multipage_pdfcairo $multipage_eps $multipage_eps_color
)))
3277 gfn
(plot-temp-file (get-option '$gnuplot_file_name
) t
)
3278 dfn
(plot-temp-file (get-option '$data_file_name
) t
))
3280 ;; we now create two files: maxout.gnuplot and data.gnuplot
3283 #+sbcl
(sb-ext:native-namestring gfn
)
3285 :direction
:output
:if-exists
:supersede
))
3286 (if (eql cmdstorage nil
)
3287 (merror "draw: Cannot create file '~a'. Probably maxima_tempdir doesn't point to a writable directory." gfn
))
3290 #+sbcl
(sb-ext:native-namestring dfn
)
3292 :direction
:output
:if-exists
:supersede
))
3293 (if (eql datastorage nil
)
3294 (merror "draw: Cannot create file '~a'. Probably maxima_tempdir doesn't point to a writable directory." dfn
))
3296 (setf datapath
(format nil
"'~a'" dfn
))
3297 ; when one multiplot window is active, change of terminal is not allowed
3298 (if (not *multiplot-is-active
*)
3299 (case (get-option '$terminal
)
3300 ($dumb
(format cmdstorage
"set terminal dumb size ~a, ~a"
3301 (round (/ (first (get-option '$dimensions
)) 10))
3302 (round (/ (second (get-option '$dimensions
)) 10))))
3303 ($dumb_file
(format cmdstorage
"set terminal dumb size ~a, ~a~%set out '~a.dumb'"
3304 (round (/ (first (get-option '$dimensions
)) 10))
3305 (round (/ (second (get-option '$dimensions
)) 10))
3306 (get-option '$file_name
)))
3307 ($canvas
(format cmdstorage
"set terminal canvas enhanced ~a size ~a, ~a~%set out '~a.html'"
3309 (round (first (get-option '$dimensions
)))
3310 (round (second (get-option '$dimensions
)))
3311 (get-option '$file_name
)))
3312 ($png
(format cmdstorage
"set terminal png enhanced truecolor ~a size ~a, ~a~%set out '~a.png'"
3314 (round (first (get-option '$dimensions
)))
3315 (round (second (get-option '$dimensions
)))
3316 (get-option '$file_name
) ) )
3317 ($pngcairo
(format cmdstorage
"set terminal pngcairo dashed enhanced truecolor ~a size ~a, ~a~%set out '~a.png'"
3319 (round (first (get-option '$dimensions
)))
3320 (round (second (get-option '$dimensions
)))
3321 (get-option '$file_name
) ) )
3322 (($eps $multipage_eps
) (format cmdstorage
"set terminal postscript dashed eps enhanced ~a size ~acm, ~acm~%set out '~a.eps'"
3324 (/ (first (get-option '$dimensions
)) 100.0)
3325 (/ (second (get-option '$dimensions
)) 100.0)
3326 (get-option '$file_name
)))
3327 (($eps_color $multipage_eps_color
) (format cmdstorage
"set terminal postscript dashed eps enhanced ~a color size ~acm, ~acm~%set out '~a.eps'"
3329 (/ (first (get-option '$dimensions
)) 100.0)
3330 (/ (second (get-option '$dimensions
)) 100.0)
3331 (get-option '$file_name
)))
3332 ($epslatex
(format cmdstorage
"set terminal epslatex ~a color size ~acm, ~acm~%set out '~a.tex'"
3334 (/ (first (get-option '$dimensions
)) 100.0)
3335 (/ (second (get-option '$dimensions
)) 100.0)
3336 (get-option '$file_name
)))
3337 ($epslatex_standalone
(format cmdstorage
"set terminal epslatex dashed standalone ~a color size ~acm, ~acm~%set out '~a.tex'"
3339 (/ (first (get-option '$dimensions
)) 100.0)
3340 (/ (second (get-option '$dimensions
)) 100.0)
3341 (get-option '$file_name
)))
3342 (($pdf $multipage_pdf
) (format cmdstorage
"set terminal pdf dashed enhanced ~a color size ~acm, ~acm~%set out '~a.pdf'"
3344 (/ (first (get-option '$dimensions
)) 100.0)
3345 (/ (second (get-option '$dimensions
)) 100.0)
3346 (get-option '$file_name
)))
3347 (($pdfcairo $multipage_pdfcairo
) (format cmdstorage
"set terminal pdfcairo dashed enhanced ~a color size ~acm, ~acm~%set out '~a.pdf'"
3349 (/ (first (get-option '$dimensions
)) 100.0)
3350 (/ (second (get-option '$dimensions
)) 100.0)
3351 (get-option '$file_name
)))
3352 ($jpg
(format cmdstorage
"set terminal jpeg enhanced ~a size ~a, ~a~%set out '~a.jpg'"
3354 (round (first (get-option '$dimensions
)))
3355 (round (second (get-option '$dimensions
)))
3356 (get-option '$file_name
)))
3357 ($gif
(format cmdstorage
"set terminal gif enhanced ~a size ~a, ~a~%set out '~a.gif'"
3359 (round (first (get-option '$dimensions
)))
3360 (round (second (get-option '$dimensions
)))
3361 (get-option '$file_name
)))
3362 ($svg
(format cmdstorage
"set terminal svg dashed enhanced ~a size ~a, ~a~%set out '~a.svg'"
3364 (round (first (get-option '$dimensions
)))
3365 (round (second (get-option '$dimensions
)))
3366 (get-option '$file_name
)))
3367 ($animated_gif
(format cmdstorage
"set terminal gif enhanced animate ~a size ~a, ~a delay ~a~%set out '~a.gif'"
3369 (round (first (get-option '$dimensions
)))
3370 (round (second (get-option '$dimensions
)))
3371 (get-option '$delay
)
3372 (get-option '$file_name
)))
3373 ($aquaterm
(format cmdstorage
"set terminal aqua enhanced ~a ~a size ~a ~a~%"
3374 *draw-terminal-number
*
3376 (round (first (get-option '$dimensions
)))
3377 (round (second (get-option '$dimensions
)))))
3378 ($wxt
(format cmdstorage
"set terminal wxt dashed enhanced ~a ~a size ~a, ~a~%"
3379 *draw-terminal-number
*
3381 (round (first (get-option '$dimensions
)))
3382 (round (second (get-option '$dimensions
)))))
3383 ($qt
(format cmdstorage
"set terminal qt dashed enhanced ~a ~a size ~a, ~a~%"
3384 *draw-terminal-number
*
3386 (round (first (get-option '$dimensions
)))
3387 (round (second (get-option '$dimensions
)))))
3388 ($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}~%"
3389 *draw-terminal-number
*
3391 (round (first (get-option '$dimensions
)))
3392 (round (second (get-option '$dimensions
)))
3393 *draw-terminal-number
*
3395 (round (first (get-option '$dimensions
)))
3396 (round (second (get-option '$dimensions
)))))
3397 ($windows
(format cmdstorage
"set terminal windows enhanced ~a ~a size ~a, ~a~%"
3398 *draw-terminal-number
*
3400 (round (first (get-option '$dimensions
)))
3401 (round (second (get-option '$dimensions
)))))
3404 ;; If we arrive here, (get-option '$terminal) returned something
3405 ;; unrecognized; at present (commit ccd8074, 2020-12-07) the following
3406 ;; are accepted by UPDATE-TERMINAL, but not handled here: $obj $ply
3407 ;; $pnm $screen $stl $tiff $vrml
3408 (unless (eq (get-option '$terminal
) '$screen
)
3409 (mtell "draw: warning: I don't know about terminal '~m'; I'll try to restore the default.~%" (get-option '$terminal
))
3410 (mtell "draw: try this: set_draw_defaults(terminal = <something>);~%"))
3412 (format cmdstorage
"set terminal GNUTERM ~a ~a size ~a, ~a~%"
3413 *draw-terminal-number
*
3415 (round (first (get-option '$dimensions
)))
3416 (round (second (get-option '$dimensions
)))))))
3418 ; compute some parameters for multiplot
3419 (when (and (not isanimatedgif
) (not ismultipage
))
3420 (setf ncols
(get-option '$columns
))
3421 (setf nrows
(ceiling (/ (length scenes
) ncols
)))
3422 (if (> (length scenes
) 1)
3423 (format cmdstorage
"~%set size 1.0, 1.0~%set origin 0.0, 0.0~%set multiplot~%")) )
3425 ; Make gnuplot versions newer than 5.0 understand that linetype means
3426 ; we try to set the dash type
3427 (format cmdstorage
"~%if(GPVAL_VERSION >= 5.0){set for [i=1:8] linetype i dashtype i; set format '%h'}")
3429 ;; By default gnuplot assumes everything below 1e-8 to be a rounding error
3430 ;; and rounds it down to 0. This is handy for standalone gnuplot as it allows
3431 ;; to suppress pixels with imaginary part while allowing for small calculation
3432 ;; errors. As plot and draw handle the imaginary part without gnuplot's help
3433 ;; this isn't needed here and is turned off as it often surprises users.
3434 (format cmdstorage
"~%set zero 0.0")
3436 ; We use whitespace as a separator, so override any datafile separator
3437 ; the user has set. The user could have set the separator to a comma
3438 ; for reading CSV files, for example.
3439 (format cmdstorage
"~%set datafile separator whitespace")
3441 ; write descriptions of 2d and 3d scenes
3443 (alloc (reverse *allocations
*))
3445 thisalloc origin1 origin2 size1 size2
)
3447 ; recalculate nrows for automatic scene allocations
3448 (setf nrows
(ceiling (/ (count nil alloc
) ncols
)))
3451 (setf width
(/ 1.0 ncols
)
3452 height
(/ 1.0 nrows
)))
3453 (dolist (scn scenes
)
3454 ; write size and origin if necessary
3455 (cond ((or isanimatedgif ismultipage
)
3456 (format cmdstorage
"~%set size 1.0, 1.0~%")
3457 (format cmdstorage
"set obj 1 rectangle behind from screen 0.0,0.0 to screen 1.0,1.0~%") )
3458 (t ; it's not an animated gif
3459 (setf thisalloc
(car alloc
))
3460 (setf alloc
(cdr alloc
))
3462 (thisalloc ; user defined scene allocation
3463 (setf origin1
(first thisalloc
)
3464 origin2
(second thisalloc
)
3465 size1
(third thisalloc
)
3466 size2
(fourth thisalloc
)))
3467 (t ; automatic scene allocation
3468 (setf origin1
(* width
(mod nilcounter ncols
))
3469 origin2
(* height
(- nrows
1.0 (floor (/ nilcounter ncols
))))
3473 (format cmdstorage
"~%set size ~a, ~a~%" size1 size2
)
3474 (format cmdstorage
"set origin ~a, ~a~%" origin1 origin2
)
3475 (unless (or *multiplot-is-active
*
3476 (member (get-option '$terminal
) '($epslatex $epslatex_standalone
)))
3477 (format cmdstorage
"set obj 1 rectangle behind from screen ~a,~a to screen ~a,~a~%"
3478 origin1 origin2
(+ origin1 size1
) (+ origin2 size2
))) ))
3482 (format cmdstorage
"~a" (second scn
))
3483 (cond ((= (first scn
) 2) ; it's a 2d scene
3484 (setf scene-short-description
'(($gr2d simp
)))
3485 (format cmdstorage
"plot "))
3486 ((= (first scn
) 3) ; it's a 3d scene
3487 (setf scene-short-description
'(($gr3d simp
)))
3488 (format cmdstorage
"splot ")))
3489 (dolist (obj (third scn
))
3490 (setf scene-short-description
3491 (cons (gr-object-name obj
) scene-short-description
))
3494 (format cmdstorage
", \\~%") )
3495 (let ((pcom (gr-object-command obj
)))
3499 (format cmdstorage
"~a~a~a~a"
3501 (format nil
" index ~a" (incf i
))
3506 (t (format cmdstorage
"~a~a~a"
3508 (format nil
" index ~a" (incf i
))
3510 (setf grouplist
(append grouplist
(gr-object-groups obj
)))
3511 (setf biglist
(append biglist
(gr-object-points obj
))) )
3513 ; let's write data in data.gnuplot
3514 (do ( (blis biglist
(cdr blis
))
3515 (glis grouplist
(cdr glis
) ))
3517 (let* ((vect (car blis
))
3522 (non-numeric-region nil
)
3525 ((= m
0) ; no blank lines
3526 (do ((cont 0 (+ cont ncol
)))
3528 (setf coordinates
(subseq vect cont
(+ cont ncol
)))
3529 ; control of non numeric y values,
3530 ; code related to draw_realpart
3533 (when (and (finite-real-p (aref coordinates
0)) (finite-real-p (aref coordinates
1)))
3534 (setf non-numeric-region nil
)
3535 (write-subarray coordinates datastorage
) ))
3538 ((and (finite-real-p (aref coordinates
0)) (finite-real-p (aref coordinates
1)))
3539 (write-subarray coordinates datastorage
))
3541 (setf non-numeric-region t
)
3542 (format datastorage
"~%")))))) )
3544 (t ; blank lines every m lines
3545 (do ((cont 0 (+ cont ncol
)))
3548 (format datastorage
"~%")
3550 (write-subarray (subseq vect cont
(+ cont ncol
)) datastorage
)
3552 (format datastorage
"~%~%") )
3554 (setf scenes-list
(cons (reverse scene-short-description
) scenes-list
)) )) ; end let-dolist scenes
3557 (cond ((or isanimatedgif ismultipage
) ; this is an animated gif or multipage plot file
3559 (format cmdstorage
"~%unset output~%quit~%~%")
3560 (format cmdstorage
"~%set term dumb~%~%") )
3562 #+(or (and sbcl win32
) (and sbcl win64
) (and ccl windows
))
3563 ($system $gnuplot_command gfn
)
3564 #-
(or (and sbcl win32
) (and sbcl win64
) (and ccl windows
))
3565 ($system
(format nil
"~a \"~a\""
3568 (t ; non animated gif
3569 ; command file maxout.gnuplot is now ready
3570 (format cmdstorage
"~%")
3571 (cond ((> (length scenes
) 1)
3572 (format cmdstorage
"unset multiplot~%unset output ~%"))
3573 ; if we want to save the coordinates in a file,
3574 ; print them when hitting the x key after clicking the mouse button
3575 ((not (string= (get-option '$xy_file
) ""))
3577 "set print \"~a\" append~%bind x \"print MOUSE_X,MOUSE_Y\"~%"
3578 (get-option '$xy_file
))) )
3580 ; in svg and pdfcairo terminals it is necessary to unset output to force
3581 ; Gnuplot to write the last few bytes ("</svg>" in the svg case)
3582 ; at the end of the file. On windows in all other terminals that write
3583 ; to files if the output isn't unset the file isn't closed and therefore
3584 ; cannot be moved or removed after a plot is finished.
3586 ; If the plot isn't written to a file the variable "output" is empty and
3587 ; unused and unsetting it a second time doesn't change anything
3588 ; => It is always save to unset the output at the end of a scene.
3589 (when (not *multiplot-is-active
*) ; not in a one window multiplot
3590 (format cmdstorage
"unset output~%"))
3594 ; connect to gnuplot via pipes
3595 ((and (member (get-option '$terminal
) '($screen $aquaterm $wxt $x11 $qt $windows
))
3596 (equal $draw_renderer
'$gnuplot_pipes
))
3597 (check-gnuplot-process)
3598 (when (not *multiplot-is-active
*) ; not in a one window multiplot
3599 (send-gnuplot-command "unset output"))
3600 (send-gnuplot-command "reset")
3601 (send-gnuplot-command
3602 (format nil
"load '~a'" gfn
)))
3603 ; call gnuplot via system command
3606 #+(or (and sbcl win32
) (and sbcl win64
) (and ccl windows
))
3607 (if (member (get-option '$terminal
) '($screen $aquaterm $wxt $x11 $qt $windows
))
3608 ($system $gnuplot_command
"-persist" gfn
)
3609 ($system $gnuplot_command gfn
))
3610 #-
(or (and sbcl win32
) (and sbcl win64
) (and ccl windows
))
3611 ($system
(if (member (get-option '$terminal
) '($screen $aquaterm $wxt $x11 $qt $windows
))
3614 (format nil $gnuplot_view_args gfn
))
3615 (format nil
"~a \"~a\""
3619 ; the output is a simplified description of the scene(s)
3620 (reverse scenes-list
)) )
3623 ;; This function transforms an integer number into
3624 ;; a string, adding zeros at the left side until the
3625 ;; length of the string equals 10. This function is
3626 ;; useful to name a sequence of frames.
3627 (defun $add_zeroes
(num)
3628 (format nil
"~10,'0d" ($sconcat num
)) )
3631 ;; copies current plot in window into a file
3632 (defun $draw_file
(&rest opts
)
3635 (if (equal ($op x
) "=")
3636 (update-gr-option ($lhs x
) ($rhs x
))
3637 (merror "draw: item ~M is not recognized as an option assignment" x
)))
3638 (case (get-option '$terminal
)
3639 ($canvas
(setf str
(format nil
"set terminal canvas enhanced ~a size ~a, ~a~%set out '~a.html'"
3641 (round (first (get-option '$dimensions
)))
3642 (round (second (get-option '$dimensions
)))
3643 (get-option '$file_name
))))
3644 ($png
(setf str
(format nil
"set terminal png enhanced truecolor ~a size ~a, ~a~%set out '~a.png'"
3646 (round (first (get-option '$dimensions
)))
3647 (round (second (get-option '$dimensions
)))
3648 (get-option '$file_name
) ) ))
3649 ($pngcairo
(setf str
(format nil
"set terminal pngcairo dashed enhanced truecolor ~a size ~a, ~a~%set out '~a.png'"
3651 (round (first (get-option '$dimensions
)))
3652 (round (second (get-option '$dimensions
)))
3653 (get-option '$file_name
) ) ))
3654 ($eps
(setf str
(format nil
"set terminal postscript dashed eps enhanced ~a size ~acm, ~acm~%set out '~a.eps'"
3655 (write-font-type) ; other alternatives are Arial, Courier
3656 (/ (first (get-option '$dimensions
)) 100.0)
3657 (/ (second (get-option '$dimensions
)) 100.0)
3658 (get-option '$file_name
))))
3659 ($epslatex
(format str
"set terminal epslatex ~a color dashed size ~acm, ~acm~%set out '~a.tex'"
3661 (/ (first (get-option '$dimensions
)) 100.0)
3662 (/ (second (get-option '$dimensions
)) 100.0)
3663 (get-option '$file_name
)))
3664 ($epslatex_standalone
(format str
"set terminal epslatex dashed standalone ~a color size ~acm, ~acm~%set out '~a.tex'"
3666 (/ (first (get-option '$dimensions
)) 100.0)
3667 (/ (second (get-option '$dimensions
)) 100.0)
3668 (get-option '$file_name
)))
3669 ($eps_color
(setf str
(format nil
"set terminal postscript dashed eps enhanced ~a color size ~acm, ~acm~%set out '~a.eps'"
3671 (/ (first (get-option '$dimensions
)) 100.0)
3672 (/ (second (get-option '$dimensions
)) 100.0)
3673 (get-option '$file_name
))))
3674 ($pdf
(setf str
(format nil
"set terminal pdf dashed enhanced ~a color size ~acm, ~acm~%set out '~a.pdf'"
3676 (/ (first (get-option '$dimensions
)) 100.0)
3677 (/ (second (get-option '$dimensions
)) 100.0)
3678 (get-option '$file_name
))))
3679 ($pdfcairo
(setf str
(format nil
"set terminal pdfcairo dashed enhanced ~a color size ~acm, ~acm~%set out '~a.pdf'"
3681 (/ (first (get-option '$dimensions
)) 100.0)
3682 (/ (second (get-option '$dimensions
)) 100.0)
3683 (get-option '$file_name
))))
3684 ($jpg
(setf str
(format nil
"set terminal jpeg ~a size ~a, ~a~%set out '~a.jpg'"
3686 (round (first (get-option '$dimensions
)))
3687 (round (second (get-option '$dimensions
)))
3688 (get-option '$file_name
))))
3689 ($gif
(setf str
(format nil
"set terminal gif ~a size ~a, ~a~%set out '~a.gif'"
3691 (round (first (get-option '$dimensions
)))
3692 (round (second (get-option '$dimensions
)))
3693 (get-option '$file_name
))))
3694 ($svg
(setf str
(format nil
"set terminal svg dashed enhanced ~a size ~a, ~a~%set out '~a.svg'"
3696 (round (first (get-option '$dimensions
)))
3697 (round (second (get-option '$dimensions
)))
3698 (get-option '$file_name
))))
3699 (otherwise (merror "draw: not a file format")))
3700 (send-gnuplot-command (format nil
"~a~%replot~%unset output~%" str
)) ))
3703 ;; When working with multiple windows, for example
3704 ;; terminal = [wxt, 5], only the newest window is active.
3705 ;; This function activates any other previous window at will.
3706 (defun $activate_window
(term num
)
3707 (when (or (not (member term
'($screen $wxt $aquaterm
)))
3708 (not (integerp num
))
3710 (merror "draw: Incorrect terminal or window number"))
3713 ($wxt
(setf str
"wxt"))
3714 ($aquaterm
(setf str
"aquaterm"))
3715 ($qt
(setf str
"qt"))
3716 (otherwise (setf str
"GNUTERM")))
3717 (send-gnuplot-command (format nil
"set terminal ~a ~a~%" str num
)) ))
