interfaces/emacs/imaxima/imaxima.lisp

   1 ;; Copyright (C) 2001, 2002, 2003, 2004 Jesper Harder
   2 ;; Copyright (C) 2007, 2008 Yasuaki Honda
   3 ;; Copyright (C) 2020, 2021, 2022 Leo Butler
   4 ;;
   5 ;; Plotting support section of this file is the copy of the same
   6 ;; section of wxmathml.lisp with very small modification. The file
   7 ;; wxmathml.lisp is a part of the distribution of wxMaxima.
   8
   9 ;; Created: 14 Nov 2001
  10 ;; Version: See version.texi
  11 ;; Keywords: maxima
  12 ;; Time-stamp: <16-05-2022 10:50:32 Leo Butler>
  13 ;;
  14 ;; This program is free software; you can redistribute it and/or
  15 ;; modify it under the terms of the GNU General Public License as
  16 ;; published by the Free Software Foundation; either version 2 of
  17 ;; the License, or (at your option) any later version.
  18 ;;
  19 ;; This program is distributed in the hope that it will be
  20 ;; useful, but WITHOUT ANY WARRANTY; without even the implied
  21 ;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
  22 ;; PURPOSE.  See the GNU General Public License for more details.
  23 ;;
  24 ;; You should have received a copy of the GNU General Public
  25 ;; License along with this program; if not, write to the Free
  26 ;; Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA
  27 ;;
  28 ;;; History:
  29 ;;; Putting prefix package name to the variable does cause
  30 ;;; error when the file is loaded into older clisp, e.g. 2.29.
  31 ;;; I changed it so that it checks the existence of the symbol
  32 ;;; in the custom package prior to accessing it.
  33 ;;; by yasuaki honda 2006/02/26
  34 ;;;
  35 ;;; When imaxima-setup bug in imaxima.el was fixed,
  36 ;;; it became clear that the following code does not work
  37 ;;; when imaxima.lisp is loaded by:
  38 ;;;     %i1 load("/xxx/imaxima.lisp");
  39 ;;; Putting prefix package name to the variable solves the
  40 ;;; issue.
  41 ;;; by yasuaki honda
  42
  43 (in-package :maxima)
  44
  45 (setq $maxima_frontend "imaxima")
  46 (setq $maxima_frontend_version *autoconf-version*)
  47 (setq $maxima_frontend_bugreportinfo "imaxima is part of maxima.")
  48
  49 (defvar *windows-OS* (string= *autoconf-windows* "true"))
  50 (defmvar $wxplot_size '((mlist simp) 400 250))
  51 (defmvar $wxplot_old_gnuplot nil)
  52 (defvar *image-counter* 0)
  53
  54 (defun wx-gnuplot-installation-check ()
  55   ;; The function check-gnuplot-process is defined in
  56   ;; maxima/src/plot.lisp since at least 5.12.0.
  57   (flet ((wx-gnuplot-installed-p ()
  58            (ignore-errors (check-gnuplot-process) t)))
  59     (unless (wx-gnuplot-installed-p)
  60       (merror (format t "Gnuplot error: Gnuplot is not installed,
  61 nor Gnuplot is not recognized by maxima")))))
  62
  63 (declare-top (special lop rop $gcprint $inchar *autoconf-version*))
  64
  65 ;;;
  66 ;;; Very unfortunately, the following code does not work in
  67 ;;; SBCL.
  68 ;;; by yasuaki honda
  69 #-sbcl
  70 (unless (fboundp 'maxima::print-invert-case)
  71   (defun print-invert-case (obj)
  72     (princ-to-string obj)))
  73
  74 (defun print-case-sensitive (obj)
  75   (if obj
  76       (print-invert-case obj)
  77     nil))
  78
  79 (defun diff-symbol () '$d)
  80
  81 (defun main-prompt ()
  82   (format () (concatenate 'string (string (code-char 3)) "(~A~D) " (string (code-char 4)))
  83     (stripdollar (print-case-sensitive $inchar)) $linenum))
  84
  85 (defun break-dbm-loop (at)
  86   (let* (
  87          (*quit-tags* (cons (cons *break-level* *quit-tag*) *quit-tags*))
  88          (*break-level* (if (not at) *break-level* (cons t *break-level*)))
  89          (*quit-tag* (cons nil nil))
  90          (*break-env* *break-env*)
  91          (*mread-prompt* "")
  92          (*diff-bindlist* nil)
  93          (*diff-mspeclist* nil)
  94          val
  95          )
  96     (declare (special *mread-prompt* ))
  97     (and (consp at) (set-env at))
  98     (cond ((null at)
  99            (break-frame 0 nil)))
 100     (catch 'step-continue
 101       (catch *quit-tag*
 102         (unwind-protect
 103             (do () (())
 104                 (format *debug-io*
 105                         (concatenate 'string
 106                                      (string (code-char 3))
 107                                      "~&~@[(~a:~a) ~]"
 108                                      (string (code-char 4)))
 109                     (unless (stringp at) "dbm")
 110                     (length *quit-tags*))
 111                 (setq val
 112                       (catch 'macsyma-quit
 113                         (let ((res (dbm-read *debug-io*  nil *top-eof* t)))
 114                           (declare (special *mread-prompt*))
 115                           (cond ((and (consp res) (keywordp (car res)))
 116                                  (let ((value (break-call (car res)
 117                                                           (cdr res) 'break-command)))
 118                                    (cond ((eq value :resume) (return)))
 119                                    ))
 120                                 (t
 121                                  (setq $__ (nth 2 res))
 122                                  (setq $% (meval* $__))
 123                                  (setq $_ $__)
 124                                  (displa $%)
 125                                  ))
 126                           nil
 127                           )))
 128                 (and (eql val 'top)
 129                      (throw-macsyma-top))
 130                       )
 131          (restore-bindings)
 132         )))))
 133
 134 (setq $display2d '$imaxima)
 135
 136 ;; TeX-printing
 137 ;; (c) copyright 1987, Richard J. Fateman
 138 ;; Small changes for interfacing with TeXmacs: Andrey Grozin, 2001
 139 ;; Yet more small changes for interfacing with imaxima: Jesper Harder 2001
 140
 141 ;; (defun tex (... is removed
 142
 143 (defun unquote-%-internal (str c)
 144   (let* ((qstr (format nil "~A~A" #\\ c))
 145          (pos (search qstr str)))
 146     (if pos
 147         (concatenate 'string (subseq str 0 pos) (format nil "~A" c)
 148                      (unquote-%-internal (subseq str (+ pos 2)) c))
 149       str)))
 150
 151 (defun unquote-% (str)
 152   (setq str (unquote-%-internal str #\$))
 153   (setq str (unquote-%-internal str #\%))
 154   (setq str (unquote-%-internal str #\&))
 155   (setq str (unquote-%-internal str #\_))
 156   (setq str (unquote-%-internal str #\#))
 157   str)
 158
 159 (defun verb-quote (str)
 160   (let ((var "") (charlist
 161                   '((#\Newline . "| \\\\ \\verb| "))))
 162     (dotimes (i (length str))
 163       (let ((chari (elt str i)))
 164         (setq var (concatenate 'string var
 165                                (or (cdr (assoc chari charlist :test #'eql))
 166                                    (string chari))))))
 167   var))
 168
 169 (defun tex-string (x)
 170   (let ((sym-name
 171          (if (symbolp x)
 172              (print-case-sensitive x)
 173            x)))
 174     (cond ((equal sym-name "") "")
 175           ((eql (elt sym-name 0) #\\) sym-name)
 176           ((member (elt sym-name 0) '(#\$ #\&))
 177            (setq sym-name (unquote-% (subseq sym-name 1)))
 178            (concatenate 'string "\\verb|   " (verb-quote sym-name) "|"))
 179           (t (setq sym-name (unquote-% sym-name))
 180              (concatenate 'string "\\verb|" (verb-quote sym-name) "|")))))
 181
 182 (defun tex-char (x)
 183   (if (eql x #\|) "\\verb/|/"
 184     (concatenate 'string "\\verb|" (string x) "|")))
 185
 186 (defun myquote (str)
 187   (let ((var "") (charlist
 188                   '((#\{ . "\\left\\{\\right.")
 189                     (#\} . "\\left\\}\\right.")
 190                     (#\space . "\\ ")
 191                     (#\Newline . "} \\\\ \\mathrm{ ")
 192                     (#\# . "\\#")
 193                     (#\$ . "\\$")
 194                     (#\% . "\\%")
 195                     (#\& . "\\&")
 196                     (#\_ . "\\_"))))
 197     (dotimes (i (length str))
 198       (let ((chari (elt str i)))
 199         (setq var (concatenate 'string var
 200                                (or (cdr (assoc chari charlist :test #'eql))
 201                                    (string chari))))))
 202   var))
 203
 204 (defun ascii-char-p (c)
 205   "Helper function for IMAXIMA-ACCUMULATE."
 206   (if (listp c)
 207       (every #'identity (mapcar #'ascii-char-p c))
 208     (and (characterp c) (< (char-code c) 127.))))
 209 (defun imaxima-accumulate (l &optional (result '()) (state 'other))
 210   "L is a list of characters of length >1. Wrap each sublist of ascii
 211 characters in \\mathrm{}, leave others alone."
 212   (if (null l)
 213       (if (eq state 'ascii)
 214           (append result '(#\}))
 215         result)
 216     (let ((c (list (car l))))
 217       (cond ((eq state 'other)
 218              (if (ascii-char-p c)
 219                  (setq c (append (coerce "\\mathrm{" 'list) c) state 'ascii)))
 220             ((eq state 'ascii)
 221              (unless (ascii-char-p c)
 222                (setq c (append (list #\}) c) state 'other)))
 223             (t
 224              (merror "imaxima-accumulate")))
 225       (setq result (append result c))
 226       (imaxima-accumulate (cdr l) result state))))
 227
 228 (defun tex-stripdollar (sym)
 229   "TEX-STRIPDOLLAR strips a leading `$' or `&' from symbol SYM. If the
 230 length of the NAME of SYM is 1, return that string; otherwise, wrap
 231 NAME in \\mathrm{} (but see IMAXIMA-ACCUMULATE for handling of
 232 non-ascii characters."
 233   (or (symbolp sym) (return-from tex-stripdollar sym))
 234   (let* ((name (print-case-sensitive sym))
 235          (pname (if (member (elt name 0) '(#\$ #\&)) (subseq name 1) name))
 236          (mname (myquote pname))
 237          (lname (coerce mname 'list))
 238          (len (length pname)))
 239       (cond
 240        ((eql len 1) mname)
 241        (t (coerce (imaxima-accumulate lname) 'string)))))
 242
 243 ;; (defun strcat (... is removed
 244
 245 ;; 10/14/87 RJF  convert 1.2e20 to 1.2 \cdot 10^{20}
 246 ;; 03/30/01 RLT  make that 1.2 \times 10^{20}
 247 ;; (defun texnumformat(atom) is removed
 248
 249 ;; (defun tex-paren (x l r)  is removed
 250
 251 ;;;
 252 ;;; The definition of tex-array is modified to fix bug #30, reported by Thomas Weidner.
 253 ;;; The following definition is provided by Thomas.
 254 ;;; Dec.6, 2006
 255 ;;;
 256
 257 (defun tex-array (x l r)
 258  (let ((f))
 259       (if (eq 'mqapply (caar x))
 260           (setq f (cadr x)
 261                 x (cdr x))
 262           (setq f (caar x)))
 263       (if (and (atom (cadr x)) (atom f))
 264           ;; subscript is an atom -- don't use \isubscript
 265           (progn
 266             (setq l (tex f l nil lop 'mfunction)
 267                   r (nconc (tex-list (cdr x) nil (list "}") ",") r))
 268             (nconc l (list "_{") r))
 269         (progn
 270           (setq l (tex f (append l (list "\\isubscript{"))  nil lop 'mfunction)
 271                 r (nconc (tex-list (cdr x) nil (list "}") ",") r))
 272           (nconc  l (list "}{") r )))))
 273
 274 ;; set up a list , separated by symbols (, * ...)  and then tack on the
 275 ;; ending item (e.g. "]" or perhaps ")"
 276
 277 (defun tex-list (x l r sym)
 278   (if (null x) r
 279       (do ((nl))
 280           ((null (cdr x))
 281            (setq nl (nconc nl (tex (car x)  l r 'mparen 'mparen)))
 282            nl)
 283 ;;        (setq nl (nconc nl (tex (car x)  l (list sym) 'mparen 'mparen))
 284           (setq nl (nconc nl (tex (car x)  l (list (concatenate 'string sym "\\linebreak[0]")) 'mparen 'mparen))
 285                   x (cdr x)
 286                   l nil))))
 287
 288 ;; (defun tex-prefix (x l r) is removed
 289
 290 ;; (defun tex-infix (x l r) is removed
 291
 292 ;; (defun tex-postfix (x l r) is removed
 293
 294 ;; (defun tex-nary (x l r) is removed
 295 #|
 296 (defun tex-nary (x l r)
 297   (let* ((op (caar x)) (sym (texsym op)) (y (cdr x)) (ext-lop lop) (ext-rop rop))
 298     (cond ((null y)       (tex-function x l r t)) ; this should not happen
 299           ((null (cdr y)) (tex-function x l r t)) ; this should not happen, too
 300           (t (do ((nl) (lop ext-lop op) (rop op (if (null (cdr y)) ext-rop op)))
 301                  ((null (cdr y)) (setq nl (nconc nl (tex (car y)  l r lop rop))) nl)
 302                  (setq nl (nconc nl (tex (car y)  l (list sym)   lop rop))
 303                        y (cdr y)
 304                        l nil))))))
 305 |#
 306 ;; (defun tex-nofix (x l r) is removed
 307
 308 ;; (defun tex-matchfix (x l r) is removed
 309
 310 ;; (defun texsym (x) is removed
 311
 312 ;; (defun texword (x) is removed
 313
 314 ;; (defprop bigfloat tex-bigfloat tex) is removed
 315
 316 ;;;
 317 ;;; Fixed to treat big float correctly.
 318 ;;;
 319 (defun tex-bigfloat (x l r) (tex-list (fpformat x) l r nil))
 320
 321 ;;absolute value
 322 (defprop $%phi "\\phi" texword) ;; yhonda
 323
 324 ;; reported conjugate treatment in imaxima be fixed.
 325 (defprop $conjugate ("^{\\star}") texsym)
 326
 327 (defprop mquote 201. tex-rbp)
 328
 329 (defprop msetq 180. tex-rbp)
 330 (defprop msetq 20. tex-rbp)
 331
 332 (defprop mset 180. tex-lbp)
 333 (defprop mset 20. tex-rbp)
 334
 335 (defprop mdefine 180. tex-lbp)
 336 (defprop mdefine 20. tex-rbp)
 337
 338 (defprop mdefmacro 180. tex-lbp)
 339 (defprop mdefmacro 20. tex-rbp)
 340
 341 (defprop marrow 25 tex-lbp)
 342 (defprop marrow 25 tex-rbp)
 343
 344 (defprop mfactorial 160. tex-lbp)
 345
 346 (defprop mexpt 140. tex-lbp)
 347 (defprop mexpt 139. tex-rbp)
 348
 349
 350 (defprop mncexpt 135. tex-lbp)
 351 (defprop mncexpt 134. tex-rbp)
 352
 353 (defprop mnctimes 110. tex-lbp)
 354 (defprop mnctimes 109. tex-rbp)
 355
 356 ;;(defprop mtimes tex-nary tex)
 357 ;;(defprop mtimes "\\*" texsym)
 358 (defprop mtimes 120. tex-lbp)
 359 (defprop mtimes 120. tex-rbp)
 360
 361 (defprop %sqrt tex-sqrt tex)
 362
 363 (defun tex-sqrt(x l r)
 364 ;; format as \\sqrt { } assuming implicit parens for sqr grouping
 365    (tex (cadr x) (append l  '("\\isqrt{")) (append '("}") r) 'mparen 'mparen))
 366
 367 (defprop mquotient 122. tex-lbp) ;;dunno about this
 368 (defprop mquotient 123. tex-rbp)
 369
 370 (defun tex-mquotient (x l r)
 371   (if (or (null (cddr x)) (cdddr x)) (wna-err (caar x)))
 372   (cond ((and (atom (cadr x)) (atom (caddr x)))
 373          ;; both denom and numerator are atoms
 374          (setq l (tex (cadr x) (append l '("\\frac{")) nil nil nil) ;;fixme
 375                r (tex (caddr x) (list "}{") (append '("}")r) 'mparen 'mparen)))
 376         ((atom (cadr x))
 377          ;; numerator is an atom
 378          (setq l (tex (cadr x) (append l '("\\ifracd{")) nil 'mparen 'mparen)
 379                r (tex (caddr x) (list "}{") (append '("}")r) 'mparen 'mparen)))
 380         ((atom (caddr x))
 381          ;; denom is an atom
 382          (setq l (tex (cadr x) (append l '("\\ifracn{")) nil 'mparen 'mparen)
 383                r (tex (caddr x) (list "}{") (append '("}")r) 'mparen 'mparen)))
 384         (t
 385          ;; neither are atoms
 386          (setq l (tex (cadr x) (append l '("\\ifrac{")) nil 'mparen 'mparen)
 387                r (tex (caddr x) (list "}{") (append '("}")r) 'mparen 'mparen))))
 388   (append l r))
 389
 390 ;; easily extended to union, intersect, otherops
 391
 392 ;; (defun tex-limit(x l r) is removed. mactex.lisp version considers direction.
 393
 394 ;;binomial coefficients
 395
 396 (defprop %binomial tex-choose tex)
 397
 398 ;; (defun tex-choose (x l r) is removed
 399
 400 (defprop rat 120. tex-lbp)
 401 (defprop rat 121. tex-rbp)
 402
 403 (defprop mplus 100. tex-lbp)
 404 (defprop mplus 100. tex-rbp)
 405
 406 ;; (defun tex-mplus (x l r) is removed
 407
 408 (defprop mminus 100. tex-rbp)
 409 (defprop mminus 100. tex-lbp)
 410
 411 (defprop mequal 80. tex-lbp)
 412 (defprop mequal 80. tex-rbp)
 413
 414 (defprop mnotequal 80. tex-lbp)
 415 (defprop mnotequal 80. tex-rbp)
 416
 417 (defprop mgreaterp 80. tex-lbp)
 418 (defprop mgreaterp 80. tex-rbp)
 419
 420 (defprop mgeqp 80. tex-lbp)
 421 (defprop mgeqp 80. tex-rbp)
 422
 423 (defprop mlessp 80. tex-lbp)
 424 (defprop mlessp 80. tex-rbp)
 425
 426 (defprop mleqp 80. tex-lbp)
 427 (defprop mleqp 80. tex-rbp)
 428
 429 (defprop mnot 70. tex-rbp)
 430
 431 (defprop mand 80. tex-lbp)
 432 (defprop mand 80. tex-rbp)
 433
 434 (defprop mor 50. tex-lbp)
 435 (defprop mor 50. tex-rbp)
 436
 437 ;; make sin(x) display as sin x , but sin(x+y) as sin(x+y)
 438 ;; etc
 439
 440 (mapc #'tex-setup
 441   '(
 442      (%acot "\\operatorname{arccot}")
 443      (%asec "\\operatorname{arcsec}")
 444      (%acsc "\\operatorname{arccsc}")
 445      (%sech "\\operatorname{sech}")
 446      (%csch "\\operatorname{csch}")
 447      (%asinh "\\operatorname{arcsinh}")
 448      (%acosh "\\operatorname{arccosh}")
 449      (%atanh "\\operatorname{arctanh}")
 450      (%acoth "\\operatorname{arccoth}")
 451      (%asech "\\operatorname{arcsech}")
 452      (%acsch "\\operatorname{arccsch}")
 453      )) ;; etc
 454
 455 (defprop mcond 25. tex-lbp)
 456 (defprop mcond 25. tex-rbp)
 457 (defprop %derivative tex-derivative tex)
 458
 459 (defprop mdo 30. tex-lbp)
 460 (defprop mdo 30. tex-rbp)
 461 (defprop mdoin 30. tex-rbp)
 462
 463 ;; these aren't quite right
 464
 465
 466 ;; Undone and trickier:
 467 ;; handle reserved symbols stuff, just in case someone
 468 ;; has a macsyma variable named (yuck!!) \over  or has a name with
 469 ;; {} in it.
 470 ;; Maybe do some special hacking for standard notations for
 471 ;; hypergeometric fns, alternative summation notations  0<=n<=inf, etc.
 472
 473 ;;Undone and really pretty hard: line breaking
 474
 475
 476 (defun tex-mtext (x l r) (tex-list (cdr x) l r ""))
 477
 478 (defun tex-mlabel (x l r)
 479   (tex (caddr x)
 480     (append l
 481       (if (cadr x)
 482           (list (format nil (concatenate 'string (string (code-char 23))
 483                                          "~A"
 484                                          (string (code-char 23)))
 485                         (myquote (print-case-sensitive (stripdollar (cadr x))))))
 486         nil))
 487     r 'mparen 'mparen))
 488
 489 (defun tex-spaceout (x l r)
 490   (append l (list "\\verb|" (make-string (cadr x) :initial-element #\space) "|") r))
 491
 492 ; jh: verb & mbox
 493
 494 (defun input-label-p (label)
 495   (if (symbolp label)
 496       (let ((name (symbol-name label)))
 497         (and (> (length name) 3)
 498              (string= "$%I" (subseq name 0 3))))))
 499
 500 (defun latex (x)
 501 ;  (princ x)  ;; uncomment to debug.
 502   (if (and (listp x) (car x) (listp (car x)) (caar x)
 503            (equal (caar x) 'mlabel)
 504            (cdr x)
 505            (cadr x)
 506            (input-label-p (cadr x)))
 507       (let (($display2d nil))
 508         (declare (special $display2d))
 509         (displa x)
 510         (return-from latex)))
 511   (mapc #'princ
 512         (cond ((and (listp x) (cdr x) (stringp (cadr x))
 513                     (equal (string-right-trim '(#\Space) (cadr x)) "Is"))
 514                (tex x (list (string (code-char 21)))
 515                     (list (string (code-char 22))) 'mparen 'mparen))
 516               ((and (listp x) (cdr x) (stringp (caddr x))
 517                     (equal (string-right-trim '(#\Space) (caddr x)) ""))
 518                (tex (reverse (cons "\\ " (rest (reverse x)))) (list (string (code-char 2)))
 519                     (list (string (code-char 5))) 'mparen 'mparen))
 520               (t
 521                (tex x (list (string (code-char 2)))
 522                  (list (string (code-char 5))) 'mparen 'mparen)))))
 523
 524 (let ((old-displa (symbol-function 'displa)))
 525   (defun displa (form)
 526     (if (eq $display2d '$imaxima)
 527         (latex form)
 528       (funcall old-displa form))))
 529
 530 (defun ask-prop (object property fun-or-number)
 531   (if fun-or-number (setq fun-or-number (list '| | fun-or-number)))
 532 ;;; Asks the user a question about the property of an object.
 533 ;;; Returns only $yes, $no or $unknown.
 534   (if (symbolp property)
 535       (setq property (print-case-sensitive property)))
 536   (do ((end-flag) (answer))
 537       (end-flag (cond ((memq answer '($yes |$Y| |$y|)) '$yes)
 538                       ((memq answer '($no |$N| |$n|)) '$no)
 539                       ((memq answer '($unknown $uk)) '$unknown)))
 540     (setq answer (retrieve
 541                   `((mtext) "Is  " ,object
 542                     ,(if (member (get-first-char property) '(#\a #\e #\i #\o #\u)
 543                                  :test #'char-equal)
 544                          '"  an "
 545                          '"  a ")
 546                     ,property ,@fun-or-number "?")
 547                   nil))
 548     (cond
 549       ((memq answer '($yes |$Y| |$y| |$N| |$n| $no $unknown $uk))
 550        (setq end-flag t))
 551       (t (mtell
 552           "~%Acceptable answers are Yes, Y, No, N, Unknown, Uk~%")))))
 553
 554 ;;
 555 ;; Plotting support
 556 ;;
 557
 558 (defvar $imaxima_tmp_subdir nil "Bound to the value of `imaxima-tmp-subdir' in `imaxima-mode'.")
 559 (defun imaxima-apply (fun args)
 560   "Binds `*maxima-tempdir*' to `$imaxima_tmp_subdir' before `apply'."
 561   (declare (special *maxima-tempdir* $imaxima_tmp_subdir))
 562   (let ((*maxima-tempdir* $imaxima_tmp_subdir))
 563     (apply fun args)))
 564
 565 (defun wxxml-tag (x l r)
 566   (let ((name (cadr x))
 567         (tag (caddr x)))
 568     (append l (list (format nil "<~a>~a</~a>" tag name tag)) r)))
 569
 570 (defun wxplot-filename (&optional (suff t))
 571   (declare (special *image-counter*))
 572   (incf *image-counter*)
 573   (let* ((name (format nil "maxout_~d~a" *image-counter* (if suff ".eps" "")))
 574          (filename (imaxima-apply #'plot-temp-file (list name))))
 575     (if (probe-file filename)
 576         (delete-file filename))
 577     filename))
 578
 579 (defvar $wx_data_file "data_~a.gnuplot" "A FORMAT string that takes exactly one argument, *image-counter*; or a MAXIMA function.")
 580 (defvar $wx_gnuplot_file "maxout_~a.gnuplot" "A FORMAT string that takes exactly one argument, *image-counter*; or a MAXIMA function.")
 581
 582 (defun wxplot-data+maxout ()
 583   (declare (special *image-counter* $wx_data_file $wx_gnuplot_file))
 584   (let ((datafile (if (stringp $wx_data_file) (format nil $wx_data_file *image-counter*) (mfuncall $wx_data_file *image-counter*)))
 585         (gnpltfile (if (stringp $wx_data_file) (format nil $wx_gnuplot_file *image-counter*) (mfuncall $wx_gnuplot_file *image-counter*))))
 586     (cons datafile gnpltfile)))
 587
 588 (defun $range (i j)
 589   (let ((x (gensym)))
 590     (mfuncall '$makelist x x i j)))
 591
 592 (defun maybe-load-package-for (wx-fun)
 593   (let ((fun ($get wx-fun '$function))
 594         (pkg ($get wx-fun '$load_package)))
 595     (if (and pkg (not (fboundp fun))) ($load pkg))))
 596
 597 (defun wxplot (wx-fun &rest args)
 598   ;; if gnuplot is not installed, this will terminate the
 599   ;; further execution.
 600   (wx-gnuplot-installation-check)
 601   (let ((filename (wxplot-filename))
 602         (data+maxout (wxplot-data+maxout))
 603         (fun ($get wx-fun '$function)))
 604     (maybe-load-package-for wx-fun)
 605     (imaxima-apply fun
 606                    `(,@args
 607                      ((mlist simp) $plot_format $gnuplot)
 608                      ((mlist simp) $gnuplot_term $ps)
 609                      ((mlist simp) $ps_file ,filename)
 610                      ((mlist simp) $gnuplot_script_file ,(cdr data+maxout))))
 611     ($ldisp `((wxxmltag simp) ,filename "img"))
 612     fun))
 613
 614 (defun wxdraw (wx-fun &rest args)
 615   (declare (special *image-counter*))
 616   ;; if gnuplot is not installed, this will terminate the
 617   ;; further execution.
 618   (wx-gnuplot-installation-check)
 619   (let* ((filename (wxplot-filename nil))
 620          (datafile (format nil "data_~a.gnuplot" *image-counter*))
 621          (gnpltfile (format nil "maxout_~a.gnuplot" *image-counter*))
 622          (fun ($get wx-fun '$function))
 623          (*windows-OS* t))
 624     (maybe-load-package-for wx-fun)
 625     (prog1
 626         (imaxima-apply fun
 627                        (append
 628                         `(((mequal simp) $terminal $eps_color)
 629                           ((mequal simp) $dimensions
 630                            ((mlist simp)
 631                             ;; convert points to 1/100 of cm
 632                             ,(* 3.53 ($first $wxplot_size))
 633                             ,(* 3.53 ($second $wxplot_size))))
 634                           ((mequal simp) $file_name ,filename)
 635                           ((mequal simp) $data_file_name ,datafile)
 636                           ((mequal simp) $gnuplot_file_name ,gnpltfile))
 637                         args))
 638       ($ldisp `((wxxmltag simp) ,(format nil "~a.eps" filename) "img")))))
 639
 640 (defmacro wx-def-plot/draw (fun pkg parent &optional init  &rest body)
 641   (let ((wx-fun (intern (format nil "$WX~a" (stripdollar fun)))))
 642     `(progn
 643        ,init
 644        ($put ',wx-fun ',pkg '$load_package)
 645        ($put ',wx-fun ',fun '$function)
 646        (defun ,wx-fun (&rest args)
 647          ,body
 648          (imaxima-apply ',parent (cons ',wx-fun args))))))
 649
 650 (wx-def-plot/draw $draw          $draw          wxdraw)
 651 (wx-def-plot/draw $draw2d        $draw          wxdraw)
 652 (wx-def-plot/draw $draw3d        $draw          wxdraw)
 653 (wx-def-plot/draw $plot2d        nil            wxplot)
 654 (wx-def-plot/draw $plot3d        nil            wxplot)
 655 (wx-def-plot/draw $implicit_plot $implicit_plot wxplot)
 656 (wx-def-plot/draw $contour_plot  nil            wxplot)
 657 (wx-def-plot/draw $julia         $dynamics      wxplot)
 658 (wx-def-plot/draw $mandelbrot    $dynamics      wxplot)
 659
 660 ;; We could load drawdf package, because we want to overwrite wxdrawdf.
 661 ;; However, we do not need to, because wxdrawdf is a wrapper for wxdraw.
 662 ;; The following will load drawdf, then overwrite wxdrawdf with our own:
 663 ;; (wx-def-plot/draw $drawdf     $drawdf        wxdraw ($load '$drawdf))
 664
 665
 666 ;; end of imaxima.lisp