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