src/gnuplot_def.lisp

   1 ;; gnuplot_def.lisp: routines for Maxima's interface to gnuplot
   2 ;; Copyright (C) 2007-2021 J. Villate
   3 ;; Time-stamp: "2024-03-25 09:10:05 villate"
   4 ;;
   5 ;; This program is free software; you can redistribute it and/or
   6 ;; modify it under the terms of the GNU General Public License
   7 ;; as published by the Free Software Foundation; either version 2
   8 ;; of the License, or (at your option) any later version.
   9 ;;
  10 ;; This program is distributed in the hope that it will be useful,
  11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 ;; GNU General Public License for more details.
  14 ;;
  15 ;; You should have received a copy of the GNU General Public License
  16 ;; along with this program; if not, write to the Free Software
  17 ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
  18 ;; MA  02110-1301, USA
  19
  20 (in-package :maxima)
  21
  22 ;; Checks that color is a six-digit hexadecimal number with the prefix #,
  23 ;; or a symbol for one of the 12 pre-defined colors, in which case the
  24 ;; hexadecimal code for that color will be returned. Unknown colors are
  25 ;; converted into black.
  26 (defun rgb-color (color)
  27   (if (plotcolorp color)
  28       (case color
  29         ($red "#ff0000")
  30         ($green "#00ff00")
  31         ($blue "#0000ff")
  32         ($magenta "#ff00ff")
  33         ($cyan "#00ffff")
  34         ($yellow "#ffff00")
  35         ($orange "#ffa500")
  36         ($violet "#ee82ee")
  37         ($brown "#a52a2a")
  38         ($gray "#bebebe")
  39         ($black "#000000")
  40         ($white "#ffffff")
  41         (t color))
  42       "#000000"))
  43
  44 ;; Given a list of valid colors (see rgb-color function) and an object c
  45 ;; that can be a real number or a string, produces a gnuplot color
  46 ;; specification for c; when c is real, its nearest integer is assigned
  47 ;; to one of the numbers in the list, using modulo length of the list.
  48 (defun gnuplot-color (colors c)
  49   (unless (listp colors) (setq colors (list colors)))
  50   (when (realp c)
  51     (unless (integerp c) (setq c (round c)))
  52     (setq c (nth (mod (1- c) (length colors)) colors)))
  53   (format nil "rgb ~s" (rgb-color c)))
  54
  55 (defun gnuplot-pointtype (type)
  56   (case type
  57     ($bullet 7) ($circle 6) ($plus 1) ($times 2) ($asterisk 3) ($box 5)
  58     ($square 4) ($triangle 9) ($delta 8) ($wedge 11) ($nabla 10)
  59     ($diamond 13) ($lozenge 12) (t 7)))
  60
  61 (defun gnuplot-pointtypes (types n)
  62   (unless (integerp n) (setq n (round n)))
  63   (unless (listp types) (setq types (list types)))
  64   (gnuplot-pointtype (nth (mod (- n 1) (length types)) types)))
  65
  66 ;; style is a list starting with one of the symbols: points, lines,
  67 ;; linespoints or dots,
  68 ;; The meaning of the numbers that follow the symbol are:
  69 ;;
  70 ;;   lines, linewidth, color
  71 ;;   points, radius, color, pointtype, pointinterval
  72 ;;   linespoints, linewidth, radius, color, pointtype, pointinterval
  73 ;;   dots, color
  74 ;;
  75 ;; linewidth and radius are measured in the same units and can be
  76 ;; floating-point numbers.
  77 ;;
  78 ;; type must be an integer
  79 ;; color can be an integer, used as index to get one of the colors defined
  80 ;; by the color option, or a 6-digit hexadecimal number #rrggbb
  81
  82 (defun gnuplot-curve-style (style colors types i)
  83   (unless (listp style) (setq style (list style)))
  84   (unless (listp colors) (setq colors (list colors)))
  85   (with-output-to-string
  86     (st)
  87     (case (first style)
  88       ($dots
  89        (format st "with dots")
  90        (if (second style)
  91          (format st " lt ~d" (gnuplot-color colors (second style)))
  92          (format st " lt ~d" (gnuplot-color colors i))))
  93       ($impulses
  94        (format st "with impulses")
  95        (if (integerp (second style))
  96          (format st " lt ~d" (gnuplot-color colors (second style)))
  97          (format st " lt ~d" (gnuplot-color colors i))))
  98       ($lines
  99        (format st "with lines")
 100        (if (realp (second style))
 101          (format st " lw ~f" (second style)))
 102        (if (third style)
 103          (format st " lt ~d" (gnuplot-color colors (third style)))
 104          (format st " lt ~d" (gnuplot-color colors i))))
 105       ($points
 106        (format st "with points")
 107        (if (realp (second style))
 108          (format st " ps ~f" (/ (second style) 2))
 109          (format st " ps 1.5"))
 110        (if (third style)
 111          (format st " lt ~d" (gnuplot-color colors (third style)))
 112          (format st " lt ~d" (gnuplot-color colors i)))
 113        (if (integerp (fourth style))
 114          (format st " pt ~d" (gnuplot-pointtypes types (fourth style)))
 115          (format st " pt ~d" (gnuplot-pointtypes types i)))
 116        (if (integerp (fifth style))
 117          (format st " pointinterval ~d" (fifth style))
 118          (format st " pointinterval 10" ))
 119          )
 120       ($linespoints
 121        (format st "with linespoints")
 122        (if (realp (second style))
 123          (format st " lw ~f" (second style)))
 124        (if (realp (third style))
 125          (format st " ps ~f" (/ (third style) 2))
 126          (format st " ps 1.5"))
 127        (if (fourth style)
 128          (format st " lt ~d" (gnuplot-color colors (fourth style)))
 129          (format st " lt ~d" (gnuplot-color colors i)))
 130        (if (integerp (fifth style))
 131          (format st " pt ~d" (gnuplot-pointtypes types (fifth style)))
 132          (format st " pt ~d" (gnuplot-pointtypes types i)))
 133        (if (integerp (sixth style))
 134          (format st " pointinterval ~d" (sixth style))
 135          (format st " pointinterval 10" ))
 136          )
 137       (t (format st "with lines lt ~d" (gnuplot-color colors i))))))
 138
 139
 140 (defun gnuplot-palette (palette)
 141 ;; palette should be a list starting with one of the symbols: hue,
 142 ;; saturation, value, gray or gradient.
 143 ;;
 144 ;; If the symbol is gray, it should be followed by two floating point
 145 ;; numbers that indicate the initial gray level and the interval of
 146 ;; gray values.
 147 ;;
 148 ;; If the symbol is one of hue, saturation or value, it must be followed
 149 ;; by three numbers that specify the hue, saturation and value for the
 150 ;; initial color, and a fourth number that gives the range of values for
 151 ;; the increment of hue, saturation or value.
 152 ;; The values for the initial hue, saturation, value and grayness should
 153 ;; be within 0 and 1, while the range can be higher or even negative.
 154 ;;
 155 ;; If the symbol is gradient, it must be followed by either a list of valid
 156 ;; colors or by a list of lists with two elements, a number and a valid color.
 157
 158   (unless (listp palette) (setq palette (list palette)))
 159   (let (hue sat val gray range fun)
 160     (case (first palette)
 161       ($gray
 162        (case (length (rest palette))
 163          (2 (setq gray (second palette)) (setq range (third palette)))
 164          (t (merror
 165              (intl:gettext
 166               "palette: gray must be followed by two numbers."))))
 167        (when (or (< gray 0) (> gray 1))
 168          (setq gray (- gray (floor gray)))))
 169       (($hue $saturation $value)
 170        (case (length (rest palette))
 171          (4 (setq hue (second palette))
 172             (setq sat (third palette))
 173             (setq val (fourth palette))
 174             (setq range (fifth palette)))
 175          (t (merror
 176              (intl:gettext
 177               "palette: ~M must be followed by four numbers.")
 178               (first palette))))
 179        (when (or (< hue 0) (> hue 1)) (setq hue (- hue (floor hue))))
 180        (when (or (< sat 0) (> sat 1)) (setq sat (- sat (floor sat))))
 181        (when (or (< val 0) (> val 1)) (setq val (- val (floor val))))))
 182     (with-output-to-string (st)
 183       (case (first palette)
 184         ($hue
 185          (if (or (< (+ hue range) 0) (> (+ hue range) 1))
 186              (setq fun (format nil "~,3f+~,3f*gray-floor(~,3f+~,3f*gray)"
 187                                hue range hue range))
 188              (setq fun (format nil "~,3f+~,3f*gray" hue range)))
 189          (format st "model HSV functions ~a, ~,3f, ~,3f" fun sat val))
 190         ($saturation
 191          (if (or (< (+ sat range) 0) (> (+ sat range) 1))
 192              (setq fun (format nil "~,3f+~,3f*gray-floor(~,3f+~,3f*gray)"
 193                                sat range sat range))
 194              (setq fun (format nil "~,3f+~,3f*gray" sat range)))
 195          (format st "model HSV functions ~,3f, ~a, ~,3f" hue fun val))
 196         ($value
 197          (if (or (< (+ val range) 0) (> (+ val range) 1))
 198              (setq fun (format nil "~,3f+~,3f*gray" val range))
 199              (setq fun (format nil "~,3f+~,3f*gray-floor(~,3f+~,3f*gray)"
 200                                val range val range)))
 201          (format st "model HSV functions ~,3f, ~,3f, ~a" hue sat fun))
 202         ($gray
 203          (if (or (< (+ gray range) 0) (> (+ gray range) 1))
 204              (setq fun (format nil "~,3f+~,3f*gray" gray range))
 205              (setq fun (format nil "~,3f+~,3f*gray-floor(~,3f+~,3f*gray)"
 206                                gray range gray range)))
 207          (format st "model RGB functions ~a, ~a, ~a" fun fun fun))
 208
 209         ($gradient
 210          (let* ((colors (rest palette)) (n (length colors)) (map nil))
 211            ;; map is constructed as (n1 c1 n2 c2 ... nj cj) where ni is a
 212            ;; decreasing sequence of numbers (n1=1, nj=0) and ci are colors
 213            (cond
 214              ;; Maxima list of numbers and colors (((mlist) ni ci) ...)
 215              ((listp (first colors))
 216               (setq colors (sort colors #'< :key #'cadr))
 217               (dotimes (i n)
 218                 (setq map (cons (rgb-color (third (nth i colors))) ;; color
 219                                 (cons
 220                                  (/ (- (second (nth i colors))   ;; ni minus
 221                                        (second (first colors)))  ;; smallest ni
 222                                     (- (second (nth (- n 1) colors));; biggest
 223                                        (second (first colors)))) ;; - smallest
 224                                  map)))))
 225              ;; list of only colors
 226              (t (dotimes (i n)
 227                   (setq map (cons (rgb-color (nth i colors))  ;; color i
 228                                   (cons (/ i (1- n)) map))))))    ;; number i
 229
 230            ;; prints map with the format:  nj, "cj", ...,n1, "c1"
 231            (setq fun (format nil "~{~f ~s~^, ~}" (reverse map)))
 232            ;; outputs the string: defined (nj, "cj", ...,n1, "c1")
 233            (format st "defined (~a)" fun)))
 234         (t
 235          (merror
 236           (intl:gettext
 237            "palette: wrong keyword ~M. Must be hue, saturation, value, gray or gradient.")
 238           (first palette)))))))
 239
 240 (defun gnuplot-plot3d-command (file palette gstyles colors titles n)
 241 (let (title (style "with pm3d"))
 242   (with-output-to-string (out)
 243     (format out "splot ")
 244   (do ((i 1 (+ i 1))) ((> i n) (format out "~%"))
 245     (unless palette
 246       (if gstyles
 247           (setq style (ensure-string (nth (mod i (length gstyles)) gstyles)))
 248           (setq style
 249                 (format nil "with lines lt ~a" (gnuplot-color colors i)))))
 250     (when (> i 1) (format out ", "))
 251     (if titles
 252         (setq title (nth (mod i (length titles)) titles))
 253         (setq title ""))
 254     (format out "~s title ~s ~a" file title style)))))
 255
 256 (defun gnuplot-terminal-and-file (plot-options)
 257   (let ((gstrings
 258          (if (getf plot-options '$gnuplot_strings) "enhanced" "noenhanced"))
 259         (gnuplot-svg-background (getf plot-options '$gnuplot_svg_background))
 260         terminal-command out-file (preserve-file t))
 261   (cond
 262     ((getf plot-options '$svg_file)
 263      (if (getf plot-options '$gnuplot_svg_term_command)
 264          (setq terminal-command
 265                (getf plot-options '$gnuplot_svg_term_command))
 266          (setq terminal-command
 267                (format nil "set term svg font \",14\" ~a~@[ background '~a'~]" gstrings gnuplot-svg-background)))
 268      (setq out-file (getf plot-options '$svg_file)))
 269     ((getf plot-options '$png_file)
 270      (if (getf plot-options '$gnuplot_png_term_command)
 271          (setq terminal-command
 272                (getf plot-options '$gnuplot_png_term_command))
 273          (setq terminal-command
 274                (format nil "set term pngcairo font \",12\" ~a" gstrings)))
 275      (setq out-file (getf plot-options '$png_file)))
 276     ((getf plot-options '$pdf_file)
 277      (if (getf plot-options '$gnuplot_pdf_term_command)
 278          (setq terminal-command
 279                (getf plot-options '$gnuplot_pdf_term_command))
 280          (setq terminal-command
 281                (format nil "set term pdfcairo color solid lw 3 size 17.2 cm, 12.9 cm font \",18\" ~a" gstrings)))
 282      (setq out-file (getf plot-options '$pdf_file)))
 283     ((getf plot-options '$ps_file)
 284      (if (getf plot-options '$gnuplot_ps_term_command)
 285          (setq terminal-command
 286                (getf plot-options '$gnuplot_ps_term_command))
 287          (setq terminal-command
 288                (format nil "set term postscript eps color solid lw 2 size 16.4 cm, 12.3 cm font \",24\" ~a" gstrings)))
 289      (setq out-file (getf plot-options '$ps_file)))
 290     ((eq (getf plot-options '$gnuplot_term) '$ps)
 291      (if (getf plot-options '$gnuplot_ps_term_command)
 292          (setq terminal-command
 293                (getf plot-options '$gnuplot_ps_term_command))
 294          (setq terminal-command
 295                (format nil "set term postscript eps color solid lw 2 size 16.4 cm, 12.3 cm font \",24\" ~a" gstrings)))
 296      (if (getf plot-options '$gnuplot_out_file)
 297          (setq out-file (getf plot-options '$gnuplot_out_file))
 298          (setq out-file (format nil "~a.ps" (random-name 16)))))
 299     ((eq (getf plot-options '$gnuplot_term) '$dumb)
 300      (if (getf plot-options '$gnuplot_dumb_term_command)
 301          (setq terminal-command
 302                (getf plot-options '$gnuplot_ps_term_command))
 303          (setq terminal-command "set term dumb 79 22"))
 304      (if (getf plot-options '$gnuplot_out_file)
 305          (setq out-file (getf plot-options '$gnuplot_out_file))
 306          (setq out-file (format nil "~a.txt" (random-name 16)))))
 307     ((eq (getf plot-options '$gnuplot_term) '$default)
 308      (if (getf plot-options '$gnuplot_default_term_command)
 309          (setq terminal-command
 310                (getf plot-options '$gnuplot_default_term_command))
 311          (setq terminal-command
 312                (if (getf plot-options '$window)
 313                    (format nil "set term GNUTERM ~d ~a~%"
 314                            (getf plot-options '$window) gstrings)
 315                    (format nil "set term GNUTERM ~a~%" gstrings)))))
 316     ((getf plot-options '$gnuplot_term)
 317      (setq
 318       terminal-command
 319           (format nil "set term ~(~a~)"
 320            (ensure-string (getf plot-options '$gnuplot_term))))
 321      (if (getf plot-options '$gnuplot_out_file)
 322          (setq out-file (getf plot-options '$gnuplot_out_file))
 323          (setq preserve-file nil
 324           out-file
 325           (format nil "maxplot.~(~a~)"
 326                   (get-gnuplot-term (getf plot-options '$gnuplot_term)))))))
 327
 328   (unless (null out-file) (setq out-file (plot-file-path out-file preserve-file plot-options)))
 329   (list terminal-command out-file)))
 330
 331 (defmethod plot-preamble ((plot gnuplot-plot) plot-options)
 332   (let ((palette (getf plot-options '$palette))
 333                       (meshcolor (if (member '$mesh_lines_color plot-options)
 334                                      (getf plot-options '$mesh_lines_color)
 335                                      '$black)) terminal-file)
 336     (when (find 'mlist palette :key #'car) (setq palette (list palette)))
 337     ;; sets-up terminal command and output file name
 338     (setq terminal-file (gnuplot-terminal-and-file plot-options))
 339     (setf
 340      (slot-value plot 'data)
 341      (concatenate
 342       'string
 343       (slot-value plot 'data)
 344       (with-output-to-string (dest)
 345         ;; reset initial state
 346         (format dest "reset~%unset output~%unset multiplot~%set clip two~%")
 347         ;; user's preamble
 348         (when (and (getf plot-options '$gnuplot_preamble)
 349                    (> (length  (getf plot-options '$gnuplot_preamble)) 0))
 350           (format dest "~a~%" (getf plot-options '$gnuplot_preamble)))
 351         ;; Don't round numbers with absolute value less than 1e-8 to zero
 352         (format dest "set zero 0.0~%")
 353         ;; prints terminal and output commands
 354         (when (first terminal-file)
 355           (format dest "~a~%" (first terminal-file)))
 356         (when (second terminal-file)
 357           (format dest "set output ~s~%" (second terminal-file)))
 358         ;; options specific to plot3d
 359         (when (string= (getf plot-options '$type) "plot3d")
 360           (format dest "set xyplane relative 0~%")
 361           (if palette
 362               (progn
 363                 (if meshcolor
 364                     (progn
 365                       (format dest
 366                               "if (GPVAL_VERSION < 5.0) set style line 100 lt rgb ~s lw 1; set pm3d hidden3d 100~%"
 367                               (rgb-color meshcolor))
 368                       (format dest
 369                               "if ((GPVAL_VERSION >= 5.0) && (GPVAL_VERSION < 6.0)) set pm3d hidden3d 100 border lw 0.5 lt rgb ~s~%"
 370                               (rgb-color meshcolor))
 371                       (format dest
 372                               "if (GPVAL_VERSION >= 6.0) set pm3d hidden3d border lw 0.5 lt rgb ~s~%"
 373                               (rgb-color meshcolor))
 374                       (unless (getf plot-options '$gnuplot_4_0)
 375                         (format dest "set pm3d depthorder~%")))
 376                     (format dest "set pm3d~%"))
 377                 (format dest "unset hidden3d~%")
 378                 (format dest "set palette ~a~%"
 379                         (gnuplot-palette (rest (first palette)))))
 380               (format dest "set hidden3d~%"))
 381           (let ((elev (getf plot-options '$elevation))
 382                 (azim (getf plot-options '$azimuth)))
 383             (when (or elev azim)
 384               (if elev
 385                   (format dest "set view ~d" elev)
 386                   (format dest "set view "))
 387               (when azim (format dest ", ~d" azim))
 388               (format dest "~%"))))
 389         ;; color_bar can be used by plot3d or plot2d
 390         (unless (getf plot-options '$color_bar)
 391           (format dest "unset colorbox~%"))
 392         ;; ----- BEGIN GNUPLOT 4.0 WORK-AROUND -----
 393         ;; When the expression plotted is constant, Gnuplot 4.0 fails
 394         ;; with a division by 0.  Explicitly assigning cbrange prevents
 395         ;; the error. Also set zrange to match cbrange.
 396         (when (floatp (getf plot-options '$const_expr))
 397           (format
 398            dest "set cbrange [~a : ~a]~%"
 399            (1- (getf plot-options '$const_expr))
 400            (1+ (getf plot-options '$const_expr)))
 401           (format
 402            dest "set zrange [~a : ~a]~%"
 403            (1- (getf plot-options '$const_expr))
 404            (1+ (getf plot-options '$const_expr))))
 405         ;; -----  END GNUPLOT 4.0 WORK-AROUND  -----
 406         ;; logarithmic plots
 407         (when (getf plot-options '$logx) (format dest "set log x~%"))
 408         (when (getf plot-options '$logy) (format dest "set log y~%"))
 409         ;; axes labels and legend
 410         (when (getf plot-options '$xlabel)
 411           (format dest "set xlabel ~s~%" (getf plot-options '$xlabel)))
 412         (when (getf plot-options '$ylabel)
 413           (format dest "set ylabel ~s~%" (getf plot-options '$ylabel)))
 414         (when (getf plot-options '$zlabel)
 415           (format dest "set zlabel ~s~%" (getf plot-options '$zlabel)))
 416         (when (and (member '$legend plot-options)
 417                    (null (getf plot-options '$legend)))
 418           (format dest "unset key~%"))
 419         ;; plotting box
 420         (when (and (member '$box plot-options) (not (getf plot-options '$box)))
 421           (format dest "unset border~%")
 422           (if (and (getf plot-options '$axes)
 423                    (string= (getf plot-options '$type) "plot2d"))
 424               (format dest "set xtics axis~%set ytics axis~%set ztics axis~%")
 425               (format dest "unset xtics~%unset ytics~%unset ztics~%")))
 426         ;; 2d grid (specific to plot2d)
 427         (when (string= (getf plot-options '$type) "plot2d")
 428           (format dest "set grid front~%")
 429           (if (getf plot-options '$grid2d)
 430               (format dest "set grid~%")
 431               (format dest "unset grid~%"))
 432           ;; plot size and aspect ratio for plot2d
 433           (if (getf plot-options '$same_xy)
 434               (format dest "set size ratio -1~%")
 435               (if (getf plot-options '$yx_ratio)
 436                   (format dest "set size ratio ~f~%"
 437                           (getf plot-options '$yx_ratio))
 438                   (if (not (getf plot-options '$xy_scale))
 439                       ;; emit the default only if there is no xy_scale specified.
 440                       (format dest "set size ratio 0.75~%"))))
 441           (if (and (getf plot-options '$xy_scale)
 442                    (listp (getf plot-options '$xy_scale)))
 443               (format dest "set size ~{~f~^, ~}~%"
 444                       (getf plot-options '$xy_scale))))
 445         ;; plot size and aspect ratio for plot3d
 446         (when (string= (getf plot-options '$type) "plot3d")
 447           (when (getf plot-options '$same_xy)
 448             (format dest "set view equal xy~%"))
 449           (when (getf plot-options '$same_xyz)
 450             (format dest "set view equal xyz~%"))
 451           (when (getf plot-options '$zmin)
 452             (format dest "set xyplane at ~f~%" (getf plot-options '$zmin))))
 453         ;; axes tics
 454         (when (member '$xtics plot-options)
 455           (let ((xtics (getf plot-options '$xtics)))
 456             (if (consp xtics)
 457                 (format dest "set xtics ~{~f~^, ~}~%" xtics)
 458                 (if xtics
 459                     (format dest "set xtics ~f~%" xtics)
 460                     (format dest "unset xtics~%")))))
 461         (when (member '$ytics plot-options)
 462           (let ((ytics (getf plot-options '$ytics)))
 463             (if (consp ytics)
 464                 (format dest "set ytics ~{~f~^, ~}~%" ytics)
 465                 (if ytics
 466                     (format dest "set ytics ~f~%" ytics)
 467                     (format dest "unset ytics~%")))))
 468         (when (member '$ztics plot-options)
 469           (let ((ztics (getf plot-options '$ztics)))
 470             (if (consp ztics)
 471                 (format dest "set ztics ~{~f~^, ~}~%" ztics)
 472                 (if ztics
 473                     (format dest "set ztics ~f~%" ztics)
 474                     (format dest "unset ztics~%")))))
 475         (when (member '$color_bar_tics plot-options)
 476           (let ((cbtics (getf plot-options '$color_bar_tics)))
 477             (if (consp cbtics)
 478                 (format dest "set cbtics ~{~f~^, ~}~%" cbtics)
 479                 (if cbtics
 480                     (format dest "set cbtics ~f~%" cbtics)
 481                     (format dest "unset cbtics~%")))))
 482         ;; axes ranges and style
 483         (when (and (getf plot-options '$x) (listp (getf plot-options '$x)))
 484           (format dest "set xrange [~{~,,,,,,'eg~^ : ~}]~%" (getf plot-options '$x)))
 485         (when (and (getf plot-options '$y) (listp (getf plot-options '$y)))
 486           (format dest "set yrange [~{~,,,,,,'eg~^ : ~}]~%" (getf plot-options '$y)))
 487         (when (and (getf plot-options '$z) (listp (getf plot-options '$z)))
 488           (format dest "set zrange [~{~,,,,,,'eg~^ : ~}]~%" (getf plot-options '$z)))
 489         (when (and (string= (getf plot-options '$type) "plot2d")
 490                    (member '$axes plot-options))
 491           (if (getf plot-options '$axes)
 492               (case (getf plot-options '$axes)
 493                 ($x (format dest "set xzeroaxis~%"))
 494                 ($y (format dest "set yzeroaxis~%"))
 495                 ($solid (format dest "set zeroaxis lt -1~%"))
 496                 (t (format dest "set zeroaxis~%")))))
 497         ;; title and labels
 498         (when (getf plot-options '$title)
 499           (format dest "set title \"~a\"~%" (getf plot-options '$title)))
 500         (when (getf plot-options '$label)
 501           (dolist (label (getf plot-options '$label))
 502             (when (and (listp label) (= (length label) 4))
 503               (format dest "set label ~s at ~{~f~^, ~}~%"
 504                       (cadr label) (cddr label)))))
 505         ;; identifier for missing data
 506         (format dest "set datafile missing ~s~%" *missing-data-indicator*))))
 507     ;;returns a list with the name of the file created, or nil
 508     (if (null (second terminal-file))
 509         nil (list (second terminal-file)))))
 510
 511 (defmethod plot2d-command ((plot gnuplot-plot) fun options range)
 512   ;; Compute points to plot for each element of FUN.
 513   ;; If no plottable points are found, end with an error.
 514   (let (points-lists)
 515     (setq points-lists
 516           (mapcar #'(lambda (f) (cdr (draw2d f range options))) (cdr fun)))
 517     (when (= (count-if #'(lambda (x) x) points-lists) 0)
 518       (merror (intl:gettext "plot2d: nothing to plot.~%")))
 519     (let ((legends-new) (legends (getf options '$legend)))
 520       (unless (null legends)
 521         (dotimes (i (length legends))
 522           (unless (null (cdr (nth i points-lists)))
 523             (push (nth i legends) legends-new)))
 524         (setf (getf options '$legend) (reverse legends-new))))
 525     (setf
 526      (slot-value plot 'data)
 527      (concatenate
 528       'string
 529       (slot-value plot 'data)
 530       (with-output-to-string (st)
 531         (unless (or (getf options '$logy)
 532                     (and (getf options '$y) (listp (getf options '$y))))
 533           (let (x y ymin ymax (xmin +most-negative-flonum+)
 534                   (xmax +most-positive-flonum+))
 535             (when (getf options '$x)
 536               (setq xmin (first (getf options '$x)))
 537               (setq xmax (second (getf options '$x))))
 538             (dolist (points-list points-lists)
 539               (dotimes (i (/ (length points-list) 2))
 540                 (setq x (nth (* i 2) points-list))
 541                 (setq y (nth (1+ (* i 2)) points-list))
 542                 (when (and (numberp x) (>= x xmin) (<= x xmax))
 543                   (when (numberp y)
 544                     (if (numberp ymin)
 545                         (if (numberp ymax)
 546                             (progn
 547                               (when (< y ymin) (setq ymin y))
 548                               (when (> y ymax) (setq ymax y)))
 549                           (if (< y ymin)
 550                               (setq ymax ymin ymin y)
 551                             (setq ymax y)))
 552                       (if (numberp ymax)
 553                           (if (> y ymax)
 554                               (setq ymin ymax ymax y)
 555                             (setq ymin y))
 556                         (setq ymin y)))))))
 557             (when (and (numberp ymin) (numberp ymax) (< ymin ymax))
 558               (psetq ymin (- (* 1.05 ymin) (* 0.05 ymax))
 559                      ymax (- (* 1.05 ymax) (* 0.05 ymin)))
 560               (format st "set yrange [~,,,,,,'eg: ~,,,,,,'eg]~%" ymin ymax))))
 561         ;; user's commands; may overule any of the previous settings
 562         (when (and (getf options '$gnuplot_postamble)
 563                    (> (length  (getf options '$gnuplot_postamble)) 0))
 564           (format st "~a~%" (getf options '$gnuplot_postamble)))
 565         ;; plot command
 566         (format st "plot")
 567         (when (getf options '$x)
 568           (format st " [~{~,,,,,,'eg~^ : ~}]" (getf options '$x)))
 569         (when (getf options '$y)
 570           (unless (getf options '$x)
 571             (format st " []"))
 572           (format st " [~{~,,,,,,'eg~^ : ~}]"  (getf options '$y)))
 573         (let ((legend (getf options '$legend))
 574               (colors (getf options '$color))
 575               (types (getf options '$point_type))
 576               (styles (getf options '$style))
 577               (i 0) style plot-name)
 578           (unless (listp legend) (setq legend (list legend)))
 579           (unless (listp colors) (setq colors (list colors)))
 580           (unless (listp styles) (setq styles (list styles)))
 581           (loop for v in (cdr fun) for points-list in points-lists do
 582                (when points-list
 583                  (when ($listp (car points-list))
 584                    (dolist (level (cdar points-list))
 585                      (if styles
 586                          (setq style (nth (mod i (length styles)) styles))
 587                          (setq style nil))
 588                      (when ($listp style) (setq style (cdr style)))
 589                      (incf i)
 590                      (setq plot-name (ensure-string level))
 591                      (when (> i 1) (format st ","))
 592                      (format st " '-'")
 593                      (format st " title ~s " plot-name)
 594                      (format st (gnuplot-curve-style style colors types i)))
 595                    (return))
 596                  (if styles
 597                      (setq style (nth (mod i (length styles)) styles))
 598                      (setq style nil))
 599                  (when ($listp style) (setq style (cdr style)))
 600                  (incf i)
 601                  ;; label the expression according to the legend,
 602                  ;; unless it is "false" or there is only one expression
 603                  (if (member '$legend options)
 604                      (setq plot-name
 605                            (if (first legend)
 606                                (ensure-string
 607                                 (nth (mod (- i 1) (length legend)) legend)) nil))
 608                      (if (= 2 (length fun))
 609                          (setq plot-name nil)
 610                          (progn
 611                            (setq
 612                             plot-name
 613                             (with-output-to-string (pn)
 614                               (cond ((atom v) (format pn "~a" ($sconcat v)))
 615                                     ((eq (second v) '$parametric)
 616                                      (format pn "~a, ~a"
 617                                              ($sconcat (third v))
 618                                              ($sconcat (fourth v))))
 619                                     ((eq (second v) '$discrete)
 620                                      (format pn "discrete~a" i))
 621                                     (t (format pn "~a" ($sconcat v))))))
 622                            (when (> (length plot-name) 50)
 623                              (setq plot-name (format nil "fun~a" i))))))
 624                  (when (> i 1) (format st ","))
 625                  (format st " '-'")
 626                  (if plot-name
 627                      (format st " title ~s " plot-name)
 628                      (format st " notitle "))
 629                  (format st (gnuplot-curve-style style colors types i)))))
 630         ;; Parses points data
 631         (format st "~%")
 632         (let (in-discontinuity points)
 633           (loop for points-list in points-lists do
 634                (when points-list
 635                  ;; case "contour" with several plots in one list
 636                  (when ($listp (car points-list))
 637                    (dolist (level (cdr points-list))
 638                      (loop for (v w) on (cdr level) by #'cddr do
 639                           (cond ((eq v 'moveto)
 640                                  ;; A blank line means a discontinuity
 641                                  (if (null in-discontinuity)
 642                                      (progn
 643                                        (format st "~%")
 644                                        (setq in-discontinuity t))))
 645                                 (t
 646                                  (format st "~,,,,,,'eg ~,,,,,,'eg ~%" v w)
 647                                  (setq points t)
 648                                  (setq in-discontinuity nil))))
 649                      (if (and (null points)
 650                               (first (getf options '$x))
 651                               (first (getf options '$y)))
 652                          (format st "~,,,,,,'eg ~,,,,,,'eg ~%"
 653                                  (first (getf options '$x))
 654                                  (first (getf options '$y))))
 655                      (format st "e~%"))
 656                    (return))
 657                  ;; other cases with only one plot per list
 658                  (loop for (v w) on points-list by #'cddr do
 659                       (cond ((eq v 'moveto)
 660                              ;; A blank line means a discontinuity
 661                              (if (null in-discontinuity)
 662                                  (progn
 663                                    (format st "~%")
 664                                    (setq in-discontinuity t))))
 665                             (t
 666                              (format st "~,,,,,,'eg ~,,,,,,'eg ~%" v w)
 667                              (setq points t)
 668                              (setq in-discontinuity nil))))
 669                  (if (and (null points)
 670                           (first (getf options '$x)) (first (getf options '$y)))
 671                      (format st "~,,,,,,'eg ~,,,,,,'eg ~%"
 672                              (first (getf options '$x))
 673                              (first (getf options '$y)))))
 674                (when points-list (format st "e~%")))))))))
 675
 676 (defmethod plot3d-command ((plot gnuplot-plot) functions options titles)
 677   (let ((i 0) fun xrange yrange lvars trans (n (length functions)))
 678     (setf
 679      (slot-value plot 'data)
 680      (concatenate
 681       'string
 682       (slot-value plot 'data)
 683       (with-output-to-string ($pstream)
 684         ;; user's commands; may overule any of the previous settings
 685         (when (and (getf options '$gnuplot_postamble)
 686                    (> (length  (getf options '$gnuplot_postamble)) 0))
 687           (format $pstream "~a~%" (getf options '$gnuplot_postamble)))
 688         ;; gnuplot command to produce the 3d plot
 689         (format $pstream "~a"
 690                 (gnuplot-plot3d-command "-" (getf options '$palette)
 691                                         (getf options '$gnuplot_curve_styles)
 692                                         (getf options '$color)
 693                                         titles n))
 694         ;; generate the mesh points for each surface in the functions stack
 695         (dolist (f functions)
 696           (setq i (+ 1 i))
 697           (setq fun (first f))
 698           (setq xrange (second f))
 699           (setq yrange (third f))
 700           (if ($listp fun)
 701               (progn
 702                 (setq trans
 703                       ($make_transform `((mlist) ,(second xrange)
 704                                          ,(second yrange) $z)
 705                                        (second fun) (third fun) (fourth fun)))
 706                 (setq fun '$zero_fun))
 707               (let*
 708                   ((x0 (third xrange))
 709                    (x1 (fourth xrange))
 710                    (y0 (third yrange))
 711                    (y1 (fourth yrange))
 712                    (xmid (+ x0 (/ (- x1 x0) 2)))
 713                    (ymid (+ y0 (/ (- y1 y0) 2))))
 714                 (setq lvars `((mlist) ,(second xrange) ,(second yrange)))
 715                 (setq fun (coerce-float-fun fun lvars "plot3d"))
 716                 ;; Evaluate FUN at the middle point of the range.
 717                 ;; Looking at a single point is somewhat unreliable.
 718                 ;; Call FUN with numerical arguments (symbolic arguments may
 719                 ;; fail due to trouble computing real/imaginary parts for
 720                 ;; complicated expressions, or it may be a numerical function)
 721                 (when (cdr ($listofvars (mfuncall fun xmid ymid)))
 722                   (mtell
 723                    (intl:gettext
 724                     "plot3d: expected <expr. of v1 and v2>, [v1,min,max], [v2,min,max]~%"))
 725                   (mtell
 726                    (intl:gettext
 727                     "plot3d: keep going and hope for the best.~%")))))
 728           (let* ((pl
 729                   (draw3d
 730                    fun (third xrange) (fourth xrange) (third yrange)
 731                    (fourth yrange) (first (getf options '$grid))
 732                    (second (getf options '$grid))))
 733                  (ar (polygon-pts pl)))
 734             (declare (type (cl:array t) ar))
 735             (when trans (mfuncall trans ar))
 736             (when (getf options '$transform_xy)
 737               (mfuncall (getf options '$transform_xy) ar))
 738             (output-points pl (first (getf options '$grid)))
 739             (format $pstream "e~%"))))))))
 740
 741 (defmethod plot-shipout ((plot gnuplot-plot) options &optional output-file)
 742    (case (getf options '$plot_format)
 743      ($gnuplot
 744       (let ((file (plot-set-gnuplot-script-file-name options)))
 745         (with-open-file (fl
 746                          #+sbcl (sb-ext:native-namestring file)
 747                          #-sbcl file
 748                          :direction :output :if-exists :supersede)
 749           (format fl "~a" (slot-value plot 'data)))
 750         (gnuplot-process options file output-file)
 751         (cons '(mlist) (cons file output-file))))
 752      ($gnuplot_pipes
 753       (send-gnuplot-command (slot-value plot 'data))
 754       (when output-file
 755         (send-gnuplot-command "unset output")
 756         (cons '(mlist) output-file)))))