B. Quelltext
B.1 kmaxima.asd
;;; ----------------------------------------------------------------------------
;;; kmaxima.asd
;;;
;;; Copyright (C) 2011 Dr. Dieter Kaiser
;;;
;;; This program is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2 of the License, or
;;; (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
;;; ----------------------------------------------------------------------------
(defpackage #:kmaxima-asd
(:use :cl :asdf))
(in-package :kmaxima-asd)
(defsystem kmaxima
:name "kmaxima"
:version "0.1"
:serial t
:components ((:file "defpackage")
(:file "src/mmacro")
(:file "src/mutils")
(:file "src/parser-def")
(:file "src/parser")
(:file "src/nformat")
(:file "src/grind")
(:file "src/display")
(:file "src/msystem")
(:file "src/float")
(:file "src/simplify")
(:file "src/mload")
(:file "src/ifactor")))
B.2 defpackage.lisp
;;; ----------------------------------------------------------------------------
;;; defpackage.lisp
;;;
;;; Copyright (C) 2011 Dr. Dieter Kaiser
;;;
;;; This program is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2 of the License, or
;;; (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
;;; ----------------------------------------------------------------------------
(in-package :cl-user)
(defpackage :kmaxima
(:nicknames :kmaxima)
(:use :cl)
(:shadow #:float)
(:export
;; Constants
#:$%e #:$%pi #:$%gamma #:$%phi
;; General symbols
#:$false
#:$true
#:displayinput
#:simp
#:mspec
;; mmacros.lisp
#:ncons #:while #:defun-prop #:defmspec #:defmvar #:errset
;; parser.lisp
#:$+ #:$- #:$* #:$** #:$^ #:$^^
#:$< #:$<= #:$= #:$> #:$>= #:|$(|
#:|$)| #:|$[| #:|$]| #:|$,| #:|$:| #:|$:=|
#:|$::| #:|$::=| #:|$!| #:|$#| #:|$'| #:|$''|
#:|$$| #:|$;| #:|$&| #:|$&&|
#:*maxima-operators*
#:*parse-stream*
#:*parse-stream-eof*
#:*parse-tyi*
#:*scan-buffered-token*
#:gobble-comment
#:tyi
#:parse-tyi
#:parse-tyi-peek
#:unparse-tyi
#:mread
#:peek-one-token
#:scan-one-token
#:scan-operator-token
#:scan-string
;; nformat.lisp
#:$powerdispflag
#:$ratdispflag
#:$%edispflag
#:$exptdispflag
#:$sqrtdispflag
#:$negsumdispflag
#:nformat
#:nformat-all
#:nformat-mplus
#:nformat-mtimes
#:nformat-mexpt
;; display.lisp
#:*in-display-p*
#:*linearray*
#:*lines*
#:*level*
#:*break*
#:*size*
#:*bkpt*
#:*bkptout*
#:*bkptwd*
#:*bkptdp*
#:*bkptht*
#:*bkptlevel*
#:*width*
#:*height*
#:*depth*
#:*right*
#:*maxht*
#:*maxdp*
#:*oldrow*
#:*oldcol*
#:*mratp*
#:mdisplay
#:dimension
#:dimension-nary
#:dimnary
#:dim-mquotient
#:d-hbar
#:dratio
#:checkfit
;; float.lisp
#:bigfloatzero
#:bigfloatone
#:bfhalf
#:bcons
#:check-bigfloat
#:intofp
#:fpformat
#:$bfloat
;; More symbols ...
#:$quit
#:$sqrtdispflag
#:add2lnc
#:alphabetp
#:defprop
#:exploden
#:fixnump
#:getprop
#:getpropl
#:implode
#:mexpt
#:mfunctionp
#:mlist
#:mlistp
#:mminus
#:mminusp
#:mparen
#:mplus
#:mquotient
#:mtimes
#:putprop
#:rat
#:%sqrt
#:*alphabet*
))
B.3 mmacro.lisp
;;; ----------------------------------------------------------------------------
;;; mmacro.lisp
;;;
;;; Copyright (C) 2011 Dr. Dieter Kaiser
;;;
;;; This file contains modified code from:
;;;
;;; Copyright (C) 1984, 1987 William Schelter, University of Texas
;;;
;;; This program is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2 of the License, or
;;; (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
;;; ----------------------------------------------------------------------------
(in-package :kmaxima)
;;; ----------------------------------------------------------------------------
(eval-when (:compile-toplevel :load-toplevel :execute)
(setq *read-default-float-format* 'double-float))
;;; ----------------------------------------------------------------------------
(defmacro ncons (x)
`(cons ,x nil))
;;; ----------------------------------------------------------------------------
(defmacro float (x &optional (y 1d0))
`(cl:float ,x ,y))
;;; ----------------------------------------------------------------------------
(defmacro while (condition &rest body)
`(do ()
((not ,condition))
,@body))
;;; ----------------------------------------------------------------------------
(defmacro defun-prop (f arg &body body)
`(setf (get ',(first f) ',(second f)) #'(lambda ,arg ,@body)))
(defmacro defmspec (func arg &body body)
`(defun-prop (,func mspec) ,arg ,@body))
;;; ----------------------------------------------------------------------------
(defvar *variable-initial-values* (make-hash-table))
(defmacro defmvar (var &rest val-and-doc)
(cond ((> (length val-and-doc) 2)
(setq val-and-doc (list (car val-and-doc) (second val-and-doc)))))
`(progn
(unless (gethash ',var *variable-initial-values*)
(setf (gethash ',var *variable-initial-values*) ,(first val-and-doc)))
(defvar ,var ,@val-and-doc)))
;;; ----------------------------------------------------------------------------
(defvar *errset* nil)
(defmacro errset (&rest l)
`(handler-case (list ,(car l))
(error (e) (when *errset* (error e)))))
;;; ----------------------------------------------------------------------------
B.4 mutils.lisp
;;; ----------------------------------------------------------------------------
;;; mutils.lisp
;;;
;;; Copyright (C) 2011 Dr. Dieter Kaiser
;;;
;;; This file contains modified code from:
;;;
;;; Copyright (C) 1984, 1987 William Schelter, University of Texas
;;; Copyright (C) 1981 Massachusetts Institute of Technology
;;;
;;; This program is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2 of the License, or
;;; (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
;;; ----------------------------------------------------------------------------
(in-package :kmaxima)
;;; ----------------------------------------------------------------------------
(defun fixnump (x)
(typep x 'fixnum))
(defun bignump (x)
(typep x 'bignum))
;;; ----------------------------------------------------------------------------
(defun mfunctionp (x)
(cond ((symbolp x)
(and (not (macro-function x))
(fboundp x) t))
((functionp x))))
;;; ----------------------------------------------------------------------------
(defvar *alphabet* (list #\_ #\%))
(defun alphabetp (ch)
(and (characterp ch)
(or (alpha-char-p ch)
(member ch *alphabet*))))
;;; ----------------------------------------------------------------------------
(defun putprop (sym val indic)
(and (symbolp sym)
(setf (get sym indic) val)))
(defmacro defprop (sym val indic)
`(putprop ',sym ',val ',indic))
(defun getprop (sym indic)
(and (symbolp sym)
(get sym indic)))
(defun getpropl (sym indicl)
(cond ((symbolp sym)
(setq sym (symbol-plist sym))
(loop for tail on sym by #'cddr
when (member (car tail) indicl :test #'eq)
do (return tail)))
(t (return-from getpropl nil))))
;;; ----------------------------------------------------------------------------
(defmvar $props '((mlist simp)))
(setf (get '$props 'assign) 'neverset)
(defun add2lnc (item llist)
(if (memalike item (if (mlistp llist) (cdr llist) llist))
llist
(progn
(unless (atom item)
(setf llist
(delete (assoc (car item) llist :test #'equal)
llist :count 1 :test #'equal)))
(nconc llist (list item)))))
;;; ----------------------------------------------------------------------------
(defun moperatorp (x op)
(and (consp x)
(consp (car x))
(eq (caar x) op)))
(defun mminusp (x)
(and (consp x)
(consp (car x))
(eq (caar x) 'mminus)))
(defun mplusp (x)
(and (consp x)
(consp (car x))
(eq (caar x) 'mplus)))
(defun mtimesp (x)
(and (consp x)
(consp (car x))
(eq (caar x) 'mtimes)))
(defun mexptp (x)
(and (consp x)
(consp (car x))
(eq (caar x) 'mexpt)))
(defun mlistp (x)
(and (consp x)
(consp (car x))
(eq (caar x) 'mlist)))
;;; ----------------------------------------------------------------------------
(defun mnumberp (x)
(or (numberp x)
(and (consp x)
(consp (car x))
(member (caar x) '(rat bigfloat))
t)))
(defun ratnump (x)
(and (consp x)
(consp (car x))
(eq (caar x) 'rat)))
(defun bigfloatp (x)
(and (consp x)
(consp (car x))
(eq (caar x) 'bigfloat)))
(defun zerop1 (x)
(or (and (numberp x)
(zerop x))
(and (bigfloatp x)
(zerop (second x)))))
(defun onep (x)
(zerop (- x 1)))
(defun onep1 (x)
(or (and (numberp x)
(zerop (- x 1)))
(and (bigfloatp x)
(zerop (second (sub x 1))))))
(defun minusp1 (x)
(cond ((realp x) (minusp x))
((ratnump x) (minusp (rat-num x)))
((bigfloatp x) (minusp (cadr x)))))
(defun mintegerp (x)
(or (and (numberp x) (integerp x))
(getprop x '$integer)
(getprop x '$odd)
(getprop x '$even)))
;;; ----------------------------------------------------------------------------
(defun decl-constant (x)
(getprop x '$constant))
(defun mconstantp (x)
(or (numberp x)
(decl-constant x)))
;;; ----------------------------------------------------------------------------
(defmvar $fpprintprec 0)
(defvar *maxfpprintprec* (ceiling (log (expt 2 (float-digits 1.0d0)) 10.0)))
(defun exploden (sym)
(declare (special *maxfpprintprec* $fpprintprec))
(let (str)
(cond ((symbolp sym)
(setq str (print-invert-case sym)))
((floatp sym)
(let ((a (abs sym))
(printprec (if (or (= $fpprintprec 0)
(> $fpprintprec *maxfpprintprec*))
*maxfpprintprec*
$fpprintprec)))
(multiple-value-bind (form width)
(cond ((or (zerop a)
(<= 1 a 1e7))
(values "~vf" (+ 1 printprec)))
((<= 0.001 a 1)
(values "~vf" (+ printprec
(cond ((< a 0.01) 3)
((< a 0.1) 2)
(t 1)))))
(t
(values "~ve" (+ 5 printprec))))
(setq str (string-trim " " (format nil form width sym))))))
((integerp sym)
(let ((leading-digit (if (> *print-base* 10) #\0 )))
(setq str (coerce (format nil "~A" sym) 'list))
(if (and leading-digit
(not (digit-char-p (car str) 10)))
(setq str (cons leading-digit str)))
(return-from exploden str)))
(t (setq str (format nil "~A" sym))))
(coerce str 'list)))
;;; ----------------------------------------------------------------------------
(defun implode (lis)
(intern-invert-case (coerce lis 'string)))
(defun make-maxima-symbol (lis)
(loop for v in lis
when (symbolp v)
collecting (char (symbol-name v) 0) into tem
else
when (characterp v)
collecting v into tem
else do (merror "make-maxima-symbol: Internal error in.")
finally
(return (make-symbol (maybe-invert-string (coerce tem 'string))))))
;;; ----------------------------------------------------------------------------
(defun symbolconc (&rest syms)
(intern (apply #'concatenate 'string
(mapcar #'(lambda (sym)
(cond ((floatp sym)
(format nil "~S" sym))
((integerp sym)
(format nil "~D" sym))
((symbolp sym)
(symbol-name sym))
(t sym)))
syms))))
;;; ----------------------------------------------------------------------------
(let ((local-table (copy-readtable nil)))
(setf (readtable-case local-table) :invert)
(defun print-invert-case (sym)
(let ((*readtable* local-table)
(*print-case* :upcase))
(princ-to-string sym))))
(defun maybe-invert-string (str)
(let ((all-upper t)
(all-lower t))
(dotimes (i (length str))
(let ((ch (char str i)))
(when (both-case-p ch)
(if (upper-case-p ch)
(setq all-lower nil)
(setq all-upper nil)))))
(cond (all-upper (string-downcase str))
(all-lower (string-upcase str))
(t str))))
(defun intern-invert-case (str)
(intern (maybe-invert-string str) :kmaxima))
;;; ----------------------------------------------------------------------------
(defun maxima-symbol-p (sym)
(if (or (symbolp sym)
(stringp sym))
(car (member (char (string sym) 0) '(#\$ #\%)))))
(defun stripdollar (x)
(cond ((numberp x) x)
((null x) 'false)
((eq x t) 'true)
((maxima-symbol-p x)
(intern (subseq (string x) 1)))
(t x)))
;;; ----------------------------------------------------------------------------
(defun getalias (x)
(cond ((getprop x 'alias))
((eq x '$false) nil)
(t x)))
;;; ----------------------------------------------------------------------------
(defun amperchk (name)
(cond ((symbolp name) name)
((stringp name)
(getalias (or (getopr0 name)
(implode (cons #\$ (coerce name 'list))))))))
;;; ----------------------------------------------------------------------------
(defmvar $aliases '((mlist simp)))
(defmspec $alias (form)
(if (oddp (length (setq form (cdr form))))
(merror "alias: takes an even number of arguments."))
(do ((l nil (cons (alias (pop form) (pop form)) l)))
((null form)
`((mlist simp) ,@(nreverse l)))))
(defun alias (x y)
(unless (and (symbolp x) (symbolp y))
(merror "alias: the arguments must be symbolic names: found ~M and ~M"
x y))
(cond ((eq x y) y)
((getprop x 'reversealias)
(if (not (eq x y))
(merror "alias: ~M already is aliased." x)))
(t
(putprop x y 'alias)
(putprop y x 'reversealias)
(add2lnc y $aliases)
y)))
(defun remalias (x &optional remp)
(let ((y (and (or remp
(member x (cdr $aliases) :test #'equal))
(getprop x 'reversealias))))
(cond ((and y (eq x '%derivative))
(remprop x 'reversealias)
(setf $aliases (delete x $aliases :count 1 :test #'eq))
(remprop '$diff 'alias) '$diff)
(y
(remprop x 'reversealias)
(remprop x 'noun)
(setf $aliases (delete x $aliases :count 1 :test #'eq))
(remprop (setq x y) 'alias)
(remprop x 'verb)
x))))
;;; ----------------------------------------------------------------------------
(defun $nounify (x)
(if (not (or (symbolp x) (stringp x)))
(merror "nounify: argument must be a symbol or a string."))
(setq x (amperchk x))
(cond ((getprop x 'verb))
((getprop x 'noun) x)
(t
(let* ((y (exploden x))
(u (eql (car y) #\$)))
(cond ((or u (not (eql (car y) #\%)))
(setq y (implode (cons #\% (if u (cdr y) y))))
(putprop y x 'noun)
(putprop x y 'verb))
(t x))))))
(defun $verbify (x)
(if (not (or (symbolp x) (stringp x)))
(merror "verbify: argument must be a symbol or a string."))
(setq x (amperchk x))
(cond ((getprop x 'noun))
((eq x '||) x)
((and (char= (char (symbol-name x) 0) #\%)
(prog2
($nounify (implode (cons #\$ (cdr (exploden x)))))
(getprop x 'noun))))
(t x)))
;;; ----------------------------------------------------------------------------
(defun mop (form)
(if (eq (caar form) 'mqapply)
(cadr form)
(caar form)))
(defun margs (form)
(if (eq (caar form) 'mqapply)
(cddr form)
(cdr form)))
;;; ----------------------------------------------------------------------------
(defun alike1 (x y)
(labels ((memqarr (ll)
(if (member 'array ll :test #'eq) t)))
(cond ((eq x y))
((atom x) (equal x y))
((atom y) nil)
(t
(and (not (atom (car x)))
(not (atom (car y)))
(eq (caar x) (caar y))
(eq (memqarr (cdar x)) (memqarr (cdar y)))
(alike (cdr x) (cdr y)))))))
(defun alike (x y)
(do ((x x (cdr x))
(y y (cdr y)))
((atom x) (equal x y))
(if (or (atom y)
(not (alike1 (car x) (car y))))
(return nil))))
(defun memalike (x l)
(do ((l l (cdr l)))
((null l))
(when (alike1 x (car l)) (return l))))
;;; ----------------------------------------------------------------------------
(defun free (expr var)
(cond ((alike1 expr var) nil)
((atom expr) t)
(t
(and (consp (car expr))
(free (caar expr) var)
(freel (cdr expr) var)))))
(defun freel (l var)
(do ((l l (cdr l)))
((null l) t)
(when (not (free (car l) var)) (return nil))))
;;; ----------------------------------------------------------------------------
;;; ----------------------------------------------------------------------------
(defun recur-apply (fun form)
(cond ((eq (caar form) 'bigfloat) form)
(t
(let ((newargs (mapcar fun (cdr form))))
(if (alike newargs (cdr form))
form
(simplifya (cons (cons (caar form)
(member 'array (cdar form) :test #'eq))
newargs)
nil))))))
;;; ----------------------------------------------------------------------------
(defun $float (e)
(cond ((numberp e) (float e))
((and (symbolp e) (getprop e '$numer)))
((or (atom e) (member 'array (cdar e) :test #'eq)) e)
((eq (caar e) 'rat) (rat2float e))
((eq (caar e) 'bigfloat) (fp2float e))
((member (caar e) '(mexpt mncexpt) :test #'eq)
(let ((res (recur-apply #'$float e)))
(if (floatp res)
res
(list (ncons (caar e)) ($float (cadr e)) (caddr e)))))
(t (recur-apply #'$float e))))
;;; ----------------------------------------------------------------------------
(defun show-symbols (&optional indic)
(with-package-iterator (next-symbol (list-all-packages) :internal :external)
(loop
(multiple-value-bind (more? symbol) (next-symbol)
(if more?
(progn
(cond
((get symbol indic)
(format t "~&~15A ~A" symbol (get symbol indic)))
))
(return))))))
;;; ----------------------------------------------------------------------------
B.5 parser-def.lisp
;;; ----------------------------------------------------------------------------
;;; parser-def.lisp
;;;
;;; Copyright (C) 2011 Dr. Dieter Kaiser
;;;
;;; This file contains modified code from:
;;;
;;; Copyright (C) 1984, 1987 William Schelter, University of Texas
;;; Copyright (C) 1980 Massachusetts Institute of Technology
;;;
;;; This program is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2 of the License, or
;;; (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
;;; ----------------------------------------------------------------------------
(in-package :kmaxima)
;;; ----------------------------------------------------------------------------
(defmacro led-propl () ''(led))
(defmacro nud-propl () ''(nud))
(defun inherit-propl (op-to op-from getl)
(let ((propl (getpropl op-from getl)))
(if propl
(progn
(remprop op-to (car propl))
(putprop op-to (cadr propl) (car propl)))
(merror "has no ~a properties. ~a ~a" getl op-from 'wrng-type-arg))))
(defun make-parser-fun-def (op p bvl body)
(if (not (consp op))
`(,(symbolconc 'def- p '-fun) ,op ,bvl ,(car bvl) . ,body)
`(progn
,(make-parser-fun-def (car op) p bvl body)
,@(mapcar #'(lambda (x)
`(inherit-propl ',x
',(car op)
(,(symbolconc p '-propl))))
(cdr op)))))
;;; ----------------------------------------------------------------------------
(defvar *symbols-defined* nil)
(defvar *maxima-operators* nil)
(defmacro define-initial-symbols (&rest l)
(let ((*symbols-defined* nil)
(*maxima-operators* nil))
(define-initial-symbols* l)
`(progn
(setq *symbols-defined* (copy-list ',*symbols-defined*))
(setq *maxima-operators* (subst () () ',*maxima-operators*)))))
(defun define-initial-symbols* (l)
(setq *symbols-defined*
(sort (copy-list l)
#'(lambda (x y)
(< (length (exploden x)) (length (exploden y))))))
(setq *maxima-operators* (cstrsetup *symbols-defined*)))
(defun define-symbol (x)
(define-initial-symbols* (cons x *symbols-defined*))
(symbolconc '$ (maybe-invert-string x)))
(defun undefine-symbol (opr)
(define-initial-symbols* (delete opr *symbols-defined* :test #'equal)))
(defun cstrsetup (arg)
(labels ((add2cstr1 (x tree)
(cond ((null tree) x)
((atom (car tree))
(cond ((equal (car tree) (car x))
(rplacd tree (add2cstr1 (cdr x) (cdr tree))))
(t
(list tree (cond ((atom (car x)) x)
((equal (caar x) 'ans) (car x))
(t x))))))
((equal (caar tree) (car x))
(rplacd (car tree) (add2cstr1 (cdr x) (cdar tree)))
tree)
((null (cdr tree))
(rplacd tree (list x))
tree)
(t
(rplacd tree (add2cstr1 x (cdr tree)))
tree)))
(add2cstr (x tree ans)
(add2cstr1 (nconc (exploden x) (cons (list 'ans ans) nil)) tree)))
(do ((arg arg (cdr arg))
(tree nil))
((null arg) (list* () '(ans ()) tree))
(if (atom (car arg))
(setq tree
(add2cstr (car arg)
tree
(symbolconc '$
(if (stringp (car arg))
(maybe-invert-string (car arg))
(car arg)))))
(setq tree (add2cstr (caar arg) tree (cadar arg)))))))
;;; ----------------------------------------------------------------------------
(let ((opr-table (make-hash-table :test #'equal)))
(defun getopr0 (x)
(or (getprop x 'opr)
(and (stringp x)
(gethash x opr-table))))
(defun putopr (x y)
(or (and (symbolp x) (putprop x y 'opr))
(and (stringp x) (setf (gethash x opr-table) y))))
(defun remopr (x)
(or (and (symbolp x) (remprop x 'opr))
(and (stringp x) (remhash x opr-table)))))
(defun getopr (x)
(or (getopr0 x) x))
(defun getop (x)
(or (getprop x 'op) x))
(mapc #'(lambda (x)
(putprop (car x) (cadr x) 'op)
(putopr (cadr x) (car x)))
'((mplus "+") (mminus "-") (mtimes "*")
(mexpt "**") (mexpt "^") (mnctimes ".")
(rat "/") (mquotient "/") (mncexpt "^^")
(mequal "=") (mgreaterp ">") (mlessp "<")
(mleqp "<=") (mgeqp ">=") (mnotequal "#")
(mand "and") (mor "or") (mnot "not")
(msetq ":") (mdefine ":=") (mdefmacro "::=")
(mquote "'") (mlist "[") (mset "::")
(mfactorial "!") (mprogn "(") (mcond "if")))
;;; ----------------------------------------------------------------------------
B.6 parser.lisp
;;; ----------------------------------------------------------------------------
;;; parser.lisp
;;;
;;; Copyright (C) 2011 Dr. Dieter Kaiser
;;;
;;; This file contains modified code from:
;;;
;;; Copyright (C) 1984, 1987 William Schelter, University of Texas
;;; Copyright (C) 1981 Massachusetts Institute of Technology
;;;
;;; This program is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2 of the License, or
;;; (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
;;; ----------------------------------------------------------------------------
(in-package :kmaxima)
;;; ----------------------------------------------------------------------------
(defprop $true T alias)
;;; ----------------------------------------------------------------------------
(defvar *parse-window* nil)
(defvar *parse-window-length* 25)
(defvar *parse-stream* nil)
(defvar *parse-tyi* nil)
(defvar *parse-stream-eof* -1)
(defvar *prompt-on-read-hang* nil)
(defvar *read-hang-prompt* "")
(defvar *mread-prompt* nil)
(defvar *mread-eof-obj* nil)
(defvar *mopl* nil)
;;; ----------------------------------------------------------------------------
(defconstant +flonum-exponent-marker+ #\D)
(defvar *whitespaces* '(#\tab #\space #\linefeed #\return #\page #\newline))
(defvar *exponent-chars* '(#\E #\e #\F #\f #\B #\b #\D #\d #\S #\s ))
;;; ----------------------------------------------------------------------------
(define-initial-symbols
|+| |-| |*| |^| |<| |=| |>| |(| |)| |[| |]| |,|
|:| |!| |#| |'| |$| |;|
|**| |^^| |:=| |::| |<=| |>=| |''| |&&|
|::=|
)
;;; ----------------------------------------------------------------------------
(let ((previous-tyi #\a))
(defun tyi (&optional (stream *standard-input*) eof)
(labels ((tyi-raw ()
(let ((ch (read-char-no-hang stream nil eof)))
(if ch
ch
(progn
(when (and *prompt-on-read-hang* *read-hang-prompt*)
(princ *read-hang-prompt*)
(force-output *standard-output*))
(read-char stream nil eof)))))
(backslash-check (ch)
(if (eq previous-tyi #\\ )
(progn (setq previous-tyi #\a) ch)
(setq previous-tyi
(if (eq ch #\\ )
(let ((next-char (peek-char nil stream nil eof)))
(if (or (eq next-char #\newline)
(eq next-char #\return))
(eat-continuations ch)
ch))
ch))))
(eat-continuations (ch)
(setq ch (tyi-raw))
(do ()
((not (or (eq ch #\newline) (eq ch #\return))))
(let ((next-char (peek-char nil stream nil eof)))
(if (and (eq ch #\return) (eq next-char #\newline))
(tyi-raw)))
(setq ch (tyi-raw))
(let ((next-char (peek-char nil stream nil eof)))
(if (and (eq ch #\\ )
(or (eq next-char #\return)
(eq next-char #\newline)))
(setq ch (tyi-raw))
(return-from eat-continuations ch))))
ch))
(let ((ch (tyi-raw)))
(if (eq ch eof)
ch
(backslash-check ch))))))
;;; ----------------------------------------------------------------------------
(defun parse-tyi-init (stream eof)
(or *parse-window*
(progn
(setq *parse-window* (make-list *parse-window-length*))
(nconc *parse-window* *parse-window*)))
(let ((tem (tyi stream eof)))
(setf (car *parse-window*) tem
*parse-window* (cdr *parse-window*))
tem))
(defun parse-tyi ()
(let ((tem *parse-tyi*))
(cond ((null tem)
(parse-tyi-init *parse-stream* *parse-stream-eof*))
((atom tem)
(setq *parse-tyi* nil)
tem)
(t
(setq *parse-tyi* (cdr tem))
(car tem)))))
(defun parse-tyi-peek ()
(let ((tem *parse-tyi*))
(cond ((null tem)
(setq *parse-tyi*
(parse-tyi-init *parse-stream* *parse-stream-eof*)))
((atom tem) tem)
(t (car tem)))))
(defun unparse-tyi (ch)
(let ((tem *parse-tyi*))
(if (null tem)
(setq *parse-tyi* ch)
(setq *parse-tyi* (cons ch tem)))))
;;; ----------------------------------------------------------------------------
(defun mopstrip (x)
(cond ((null x) 'false)
((or (eq x t) (eq x 't)) 'true)
((numberp x) x)
((symbolp x)
(or (getprop x 'reversealias)
(let ((name (symbol-name x)))
(if (member (char name 0) '(#\$ #\%) :test #'char=)
(subseq name 1)
name))))
(t x)))
;;; ----------------------------------------------------------------------------
(defun mread-synerr (format-string &rest l)
(let (tem
*errset*
(file "stdin"))
(errset (setq tem (file-position *parse-stream*))
(setq file (namestring *parse-stream*)))
(when tem
(format t "~%~a:~a:" file tem))
(format t "incorrect syntax: ")
(apply 'format t format-string
(mapcar #'(lambda (x)
(if (symbolp x) (print-invert-case x) x))
l))
(when (eql *parse-stream* *standard-input*)
(let ((n *parse-window-length*)
some ch)
(loop for i from (1- n) downto (- n 20)
while (setq ch (nth i *parse-window*))
do
(cond ((eql ch #\newline)
(push #\n some)
(push #\\ some))
((eql ch #\tab)
(push #\t some)
(push #\\ some))
(t (push ch some))))
(format t "~%~{~c~}~%~vt^" some (- (length some) 2))
(read-line *parse-stream* nil nil)))
(terpri)
(throw 'maxima-continue t)))
;;; ----------------------------------------------------------------------------
(defun parse-err ()
(mread-synerr "Syntax error"))
(defun parse-bug-err (op)
(mread-synerr
"Parser bug in ~A. Please report this to the Maxima maintainers,~
~%including the characters you just typed which caused the error. Thanks."
(mopstrip op)))
(defun parse-delim-err (op)
(mread-synerr "Illegal use of delimiter ~A" (mopstrip op)))
(defun parse-erb-err (op l)
(declare (ignore l))
(mread-synerr "Too many ~A's" (mopstrip op)))
(defun parse-premterm-err (op)
(mread-synerr "Premature termination of input at ~A." (mopstrip op)))
;;; ----------------------------------------------------------------------------
(defvar *scan-buffered-token* (list nil))
(defun peek-one-token (&optional (eof-p nil) (eof nil) &aux token)
(cond ((car *scan-buffered-token*)
(cdr *scan-buffered-token*))
(t
(cond ((eq eof (setq token (scan-one-token eof-p eof)))
eof)
(t
(rplacd *scan-buffered-token* token)
(cdr (rplaca *scan-buffered-token* t)))))))
(defun scan-one-token (&optional (eof-p nil) (eof nil) &aux test)
(cond ((car *scan-buffered-token*)
(rplaca *scan-buffered-token* nil)
(cdr *scan-buffered-token*))
((scan-operator-token *maxima-operators*))
((eql (setq test (parse-tyi-peek)) *parse-stream-eof*)
(parse-tyi)
(if eof-p
eof
(merror "parser: end of file while scanning expression.")))
((eql test #\/ )
(parse-tyi)
(cond ((char= (parse-tyi-peek) #\* )
(parse-tyi)
(gobble-comment)
(scan-one-token eof-p eof))
(t '$/)))
((eql test #\. )
(parse-tyi)
(if (digit-char-p (parse-tyi-peek) 10)
(scan-number-after-dot (list (list #\. ) nil))
'|$.|))
((eql test #\" )
(parse-tyi)
(scan-string))
((eql test #\? )
(parse-tyi)
(cond ((char= (parse-tyi-peek) #\" )
(parse-tyi)
(scan-string))
((char= (parse-tyi-peek) #\: )
(scan-keyword-token))
(t (scan-lisp-token))))
((digit-char-p test 10)
(scan-number-before-dot nil))
(t (scan-maxima-token))))
;;; ----------------------------------------------------------------------------
(defun gobble-comment ()
(do ((depth 1)
(ch (parse-tyi-peek) (parse-tyi-peek)))
((eql 0 depth) t)
(cond ((eql ch *parse-stream-eof*)
(merror "Parser: end of file in comment."))
((char= ch #\* )
(parse-tyi)
(cond ((char= (parse-tyi-peek) #\/ )
(parse-tyi)
(decf depth))))
((char= ch #\/ )
(parse-tyi)
(cond ((char= (parse-tyi-peek) #\*)
(parse-tyi)
(incf depth))))
(t (parse-tyi)))))
;;; ----------------------------------------------------------------------------
(defun scan-operator-token (obj)
(do ((ch (parse-tyi-peek) (parse-tyi-peek)))
((not (member ch *whitespaces*)))
(parse-tyi))
(scan-operator-token-aux obj))
(defun scan-operator-token-aux (obj)
(labels ((parser-assoc (ch lis)
(do ((v lis (cdr v)))
((null v))
(cond ((consp (car v))
(if (eql (caar v) ch) (return (car v))))
((eql (car v) ch)
(return v))))))
(let* ((ch (parse-tyi-peek))
(lis (if (eql ch *parse-stream-eof*)
nil
(parser-assoc ch obj)))
result)
(cond
((null lis) nil)
(t
(parse-tyi)
(cond
((atom (cadr lis))
(setq result (scan-operator-token-aux (list (cdr lis)))))
((null (cddr lis))
(setq result
(and (eql (car (cadr lis)) 'ans)
(or (not (alphabetp (cadr (exploden (cadadr lis)))))
(member (parse-tyi-peek) *whitespaces*))
(cadr (cadr lis)))))
(t
(let ((res (and (eql (car (cadr lis)) 'ans) (cadadr lis)))
(token (scan-operator-token-aux (cddr lis))))
(setq result
(or token
res
(scan-operator-token-aux (list (cadr lis))))))))
(or result (unparse-tyi ch))
result)))))
;;; ----------------------------------------------------------------------------
(defun scan-maxima-token ()
(getalias (implode (cons '#\$ (scan-token t)))))
(defun scan-lisp-token ()
(let ((charlist (scan-token nil)))
(if charlist
(implode charlist)
(mread-synerr "Lisp symbol expected."))))
(defun scan-keyword-token ()
(let ((charlist (cdr (scan-token nil))))
(if charlist
(let ((*package* (find-package :keyword)))
(implode charlist))
(mread-synerr "Lisp keyword expected."))))
(defun scan-token (flag)
(do ((ch (parse-tyi-peek) (parse-tyi-peek))
(l () (cons ch l)))
((or (eql ch *parse-stream-eof*)
(and flag
(not (or (digit-char-p ch (max 10 *read-base*))
(alphabetp ch)
(char= ch #\\ )))))
(nreverse (or l (list (parse-tyi)))))
(when (char= (parse-tyi) #\\ )
(setq ch (parse-tyi)))
(setq flag t)))
;;; ----------------------------------------------------------------------------
(defun scan-string ()
(let ((buf (make-array 50 :element-type '#.(array-element-type "a")
:fill-pointer 0 :adjustable t)))
(do ((ch (parse-tyi-peek) (parse-tyi-peek)))
((cond ((eql ch *parse-stream-eof*))
((char= ch #\")
(parse-tyi) t))
(copy-seq buf))
(if (char= (parse-tyi) #\\ )
(setq ch (parse-tyi)))
(vector-push-extend ch buf))))
;;; ----------------------------------------------------------------------------
(defmvar $fast_bfloat_conversion t)
(defmvar $fast_bfloat_threshold 100000)
(defvar *fast-bfloat-extra-bits* 0)
(defun cl-rat-to-maxima (x)
(if (integerp x)
x
(list '(rat simp) (numerator x) (denominator x))))
(defun make-number (data)
(setq data (nreverse data))
(let ((marker (car (nth 3 data))))
(unless (eql marker +flonum-exponent-marker+)
(when (member marker '(#\E #\F #\S #\D #\L ))
(setf (nth 3 data) (list +flonum-exponent-marker+)))))
(if (not (equal (nth 3 data) '(#\B)))
(read-from-string (coerce (apply #'append data) 'string))
(let ((int-part (read-from-string
(coerce (or (first data) '(#\0)) 'string)))
(frac-part (read-from-string
(coerce (or (third data) '(#\0)) 'string)))
(frac-len (length (third data)))
(exp-sign (first (fifth data)))
(expo (read-from-string (coerce (sixth data) 'string))))
(if (and $fast_bfloat_conversion
(> (abs expo) $fast_bfloat_threshold))
(let* ((extra-prec (+ *fast-bfloat-extra-bits*
(ceiling (log expo 2d0))))
(fpprec (+ fpprec extra-prec))
(mant (+ (* int-part (expt 10 frac-len)) frac-part))
(bf-mant (bcons (intofp mant)))
(p (power (bcons (intofp 10))
(- (if (char= exp-sign #\- )
(- expo)
expo)
frac-len)))
(result (mul bf-mant p)))
(let ((fpprec (- fpprec extra-prec)))
(check-bigfloat result)))
(let ((ratio (* (+ int-part (* frac-part (expt 10 (- frac-len))))
(expt 10 (if (char= exp-sign #\- )
(- expo)
expo)))))
($bfloat (cl-rat-to-maxima ratio)))))))
(defun scan-digits (data continuation? continuation &optional exponent-p)
(do ((ch (parse-tyi-peek) (parse-tyi-peek))
(l () (cons ch l)))
((not (and (characterp ch)
(digit-char-p ch (max 10 *read-base*))))
(cond ((member ch continuation?)
(funcall continuation
(list* (list (char-upcase (parse-tyi)))
(nreverse l)
data)))
((and (null l) exponent-p)
(merror "parser: incomplete number; missing exponent?"))
(t
(make-number (cons (nreverse l) data)))))
(parse-tyi)))
(defun scan-number-exponent (data)
(push (list (if (or (char= (parse-tyi-peek) #\+ )
(char= (parse-tyi-peek) #\- ))
(parse-tyi)
#\+ ))
data)
(scan-digits data nil nil t))
(defun scan-number-rest (data)
(let ((ch (caar data)))
(cond ((member ch '(#\.))
(scan-number-after-dot data))
((member ch *exponent-chars*)
(setf data (push (list #\. ) (rest data)))
(push (list #\0 ) data)
(push (list ch ) data)
(scan-number-exponent data)))))
(defun scan-number-before-dot (data)
(scan-digits data (push #\. *exponent-chars*) #'scan-number-rest ))
(defun scan-number-after-dot (data)
(scan-digits data *exponent-chars* #'scan-number-exponent ))
;;; ----------------------------------------------------------------------------
(eval-when (:execute :compile-toplevel :load-toplevel)
(defmacro def-nud-equiv (op equiv)
(list 'putprop (list 'quote op) (list 'function equiv) (list 'quote 'nud)))
(defmacro def-nud-fun (op-name op-l . body)
(list* 'defun-prop (list* op-name 'nud 'nil) op-l body))
(defmacro def-led-equiv (op equiv)
(list 'putprop (list 'quote op) (list 'function equiv) (list 'quote 'led)))
(defmacro def-led-fun (op-name op-l . body)
(list* 'defun-prop (list* op-name 'led 'nil) op-l body)))
;;; ----------------------------------------------------------------------------
(defun operatorp (lex)
(and (symbolp lex)
(getpropl lex '(nud led))))
(defun operatorp1 (lex)
(and (symbolp lex)
(getpropl lex '(lbp rbp nud led))))
;;; ----------------------------------------------------------------------------
(defun set-lbp-and-rbp (op lbp rbp)
(cond ((not (consp op))
(let ((existing-lbp (getprop op 'lbp))
(existing-rbp (getprop op 'rbp)))
(cond ((not lbp))
((not existing-lbp)
(putprop op lbp 'lbp))
((not (eql existing-lbp lbp))
(merror "Incompatible LBP's defined for operator ~a" op)))
(cond ((not rbp))
((not existing-rbp)
(putprop op rbp 'rbp))
((not (eql existing-rbp rbp))
(merror "Incompatible RBP's defined for operator ~a" op)))))
(t
(mapcar #'(lambda (x) (set-lbp-and-rbp x lbp rbp)) op))))
(defmacro def-nud ((op . lbp-rbp) bvl . body)
(let ((lbp (nth 0 lbp-rbp))
(rbp (nth 1 lbp-rbp)))
`(progn
'compile
,(make-parser-fun-def op 'nud bvl body)
(set-lbp-and-rbp ',op ',lbp ',rbp))))
(defmacro def-led ((op . lbp-rbp) bvl . body)
(let ((lbp (nth 0 lbp-rbp))
(rbp (nth 1 lbp-rbp)))
`(progn
'compile
,(make-parser-fun-def op 'led bvl body)
(set-lbp-and-rbp ',op ',lbp ',rbp))))
;;; ----------------------------------------------------------------------------
(defmacro def-lbp (op val) `(defprop ,op ,val lbp))
(defmacro def-rbp (op val) `(defprop ,op ,val rbp))
(defun lbp (op) (cond ((getprop op 'lbp)) (t 200)))
(defun rbp (op) (cond ((getprop op 'rbp)) (t 200)))
;;; ----------------------------------------------------------------------------
(defmacro def-pos (op pos) `(defprop ,op ,pos pos))
(defmacro def-rpos (op pos) `(defprop ,op ,pos rpos))
(defmacro def-lpos (op pos) `(defprop ,op ,pos lpos))
(defun lpos (op) (cond ((getprop op 'lpos)) (t '$any)))
(defun rpos (op) (cond ((getprop op 'rpos)) (t '$any)))
(defun pos (op) (cond ((getprop op 'pos)) (t '$any)))
(defprop $any "untyped" english)
(defprop $clause "logical" english)
(defprop $expr "algebraic" english)
;;; ----------------------------------------------------------------------------
(defmacro def-match (op match) `(defprop ,op ,match match))
(defmacro def-mheader (op header) `(defprop ,op ,header mheader))
(defun mheader (op)
(or (getprop op 'mheader) (list op)))
;;; ----------------------------------------------------------------------------
(defmacro def-collisions (op &rest alist)
(let ((keys (do ((i 1 (ash i 1))
(lis alist (cdr lis))
(nl () (cons (cons (caar lis) i) nl)))
((null lis) nl))))
`(progn
'compile
(defprop ,op ,(let nil (copy-tree keys)) keys)
,@(mapcar
#'(lambda (data)
`(defprop
,(car data)
,(do ((i 0 (logior i (cdr (assoc (car lis)
keys :test #'eq))))
(lis (cdr data) (cdr lis)))
((null lis) i))
,op))
alist))))
(defun collision-lookup (op active-bitmask key-bitmask)
(let ((result (logand active-bitmask key-bitmask)))
(if (not (zerop result))
(do ((l (get op 'keys) (cdr l)))
((null l) (parse-bug-err 'collision-check))
(if (not (zerop (logand result (cdar l))))
(return (caar l)))))))
(defun collision-check (op active-bitmask key)
(let ((key-bitmask (get key op)))
(if (not key-bitmask)
(mread-synerr "~A is an unknown keyword in a ~A statement."
(mopstrip key) (mopstrip op)))
(let ((collision (collision-lookup op active-bitmask key-bitmask)))
(if collision
(if (eq collision key)
(mread-synerr "This ~A's ~A slot is already filled."
(mopstrip op)
(mopstrip key))
(mread-synerr "A ~A cannot have a ~A with a ~A field."
(mopstrip op)
(mopstrip key)
(mopstrip collision))))
(logior (cdr (assoc key (get op 'keys) :test #'eq)) active-bitmask))))
;;; ----------------------------------------------------------------------------
(defun mread (stream &optional eof)
(let ((*parse-stream* stream)
(*mread-eof-obj* eof)
(*scan-buffered-token* (list nil))
(*parse-tyi* nil))
(when *mread-prompt*
(when *parse-window*
(setf (car *parse-window*) nil
*parse-window* (cdr *parse-window*)))
(princ *mread-prompt*)
(force-output))
(if (eq *mread-eof-obj* (peek-one-token t *mread-eof-obj*))
*mread-eof-obj*
(do ((labels ())
(input (parse '$any 0) (parse '$any 0)))
(nil)
(case (peek-one-token)
((|$;| |$$|
)
(return (list (mheader (scan-one-token))
(if labels
(cons (mheader '|$[| ) (nreverse labels)))
input)))
((|$&&|)
(scan-one-token)
(if (symbolp input)
(push input labels)
(mread-synerr "Invalid && tag. Tag must be a symbol")))
(t
(parse-bug-err 'mread)))))))
;;; ----------------------------------------------------------------------------
(defun parse (mode rbp)
(labels ((led-call (op l)
(let ((tem (getprop op 'led))
res)
(setq res
(if (null tem)
(mread-synerr "~A is not an infix operator"
(mopstrip op))
(funcall tem op l)))
res))
(nud-call (op)
(let ((tem (getprop op 'nud))
res)
(setq res
(if (null tem)
(if (operatorp op)
(mread-synerr "~A is not a prefix operator"
(mopstrip op))
(cons '$any op))
(funcall tem op)))
res)))
(do ((left (nud-call (scan-one-token))
(led-call (scan-one-token) left)))
((>= rbp (lbp (peek-one-token)))
(convert left mode)))))
(defun convert (item mode)
(if (or (eq mode (car item))
(eq '$any mode)
(eq '$any (car item)))
(cdr item)
(mread-synerr "Found ~A expression where ~A expression expected"
(getprop (car item) 'english)
(getprop mode 'english))))
(defun parse-prefix (op)
(list (pos op)
(mheader op)
(parse (rpos op) (rbp op))))
(defun parse-postfix (op l)
(list (pos op)
(mheader op)
(convert l (lpos op))))
(defun parse-infix (op l)
(list (pos op)
(mheader op)
(convert l (lpos op))
(parse (rpos op) (rbp op))))
(defun parse-nofix (op)
(list (pos op)
(mheader op)))
(defun parse-nary (op l)
(list* (pos op)
(mheader op)
(convert l (lpos op))
(prsnary op (lpos op) (lbp op))))
(defun prsnary (op mode rbp)
(do ((nl (list (parse mode rbp))
(cons (parse mode rbp) nl)))
((not (eq op (peek-one-token)))
(nreverse nl))
(scan-one-token)))
(defun parse-matchfix (op)
(list* (pos op)
(mheader op)
(prsmatch (getprop op 'match) (lpos op))))
(defun prsmatch (match mode)
(cond ((eq match (peek-one-token)) (scan-one-token) nil)
(t
(do ((nl (list (parse mode 10))
(cons (parse mode 10) nl)))
((eq match (peek-one-token))
(scan-one-token)
(nreverse nl))
(if (eq '|$,| (peek-one-token))
(scan-one-token)
(mread-synerr "Missing ~A"
(mopstrip match)))))))
;;; ----------------------------------------------------------------------------
(def-nud-equiv |$[| parse-matchfix)
(def-match |$[| |$]|)
(def-lbp |$[| 200)
(def-mheader |$[| (mlist))
(def-pos |$[| $any)
(def-lpos |$[| $any)
(def-led (|$[| 200) (op left)
(setq left (convert left '$any))
(if (numberp left) (parse-err))
(let ((header (if (atom left)
(list (amperchk left) 'array)
'(mqapply array)))
(right (prsmatch '|$]| '$any)))
(cond ((null right)
(mread-synerr "No subscripts given"))
((atom left)
(setq right (cons header right))
(cons '$any (getalias right)))
(t
(cons '$any (cons header (cons left right)))))))
(def-nud-equiv |$]| parse-delim-err)
(def-led-equiv |$]| parse-erb-err)
(def-lbp |$]| 5)
;;; ----------------------------------------------------------------------------
(def-mheader |$(| (mprogn))
(def-nud (|$(| 200) (op)
(let ((right) (hdr (mheader '|$(|)))
(cond ((eq '|$)| (peek-one-token)) (parse-err))
((or (null (setq right (prsmatch '|$)| '$any)))
(cdr right))
(cons '$any (cons hdr right)))
(t (cons '$any (car right))))))
(def-led (|$(| 200) (op left)
(setq left (convert left '$any))
(if (numberp left) (parse-err))
(let ((hdr (and (atom left) (mheader (amperchk left))))
(r (prsmatch '|$)| '$any)))
(cons '$any
(cond ((atom left)
(cons hdr r))
(t
(cons '(mqapply) (cons left r)))))))
(def-nud-equiv |$)| parse-delim-err)
(def-led-equiv |$)| parse-erb-err)
(def-lbp |$)| 5)
;;; ----------------------------------------------------------------------------
(def-mheader |$'| (mquote))
(def-nud (|$'|) (op)
(let (right)
(cond ((eq '|$(| (peek-one-token))
(list '$any (mheader '|$'|) (parse '$any 190)))
((or (atom (setq right (parse '$any 190)))
(member (caar right)
'(mquote mlist mprog mprogn lambda) :test #'eq))
(list '$any (mheader '|$'|) right))
((eq 'mqapply (caar right))
(cond ((eq (caaadr right) 'lambda)
(list '$any (mheader '|$'|) right))
(t
(rplaca (cdr right)
(cons (cons ($nounify (caaadr right))
(cdaadr right))
(cdadr right)))
(cons '$any right))))
(t
(cons '$any
(cons (cons ($nounify (caar right)) (cdar right))
(cdr right)))))))
(def-nud (|$''|) (op)
(let (right)
(cons '$any
(cond ((eq '|$(| (peek-one-token))
(meval (parse '$any 190)))
((atom (setq right (parse '$any 190)))
(meval right))
((eq 'mqapply (caar right))
(rplaca (cdr right)
(cons (cons ($verbify (caaadr right))
(cdaadr right))
(cdadr right)))
right)
(t
(cons (cons ($verbify (caar right)) (cdar right))
(cdr right)))))))
;;; ----------------------------------------------------------------------------
(def-led-equiv |$:| parse-infix)
(def-lbp |$:| 180)
(def-rbp |$:| 20)
(def-pos |$:| $any)
(def-rpos |$:| $any)
(def-lpos |$:| $any)
(def-mheader |$:| (msetq))
(def-led-equiv |$::| parse-infix)
(def-lbp |$::| 180)
(def-rbp |$::| 20)
(def-pos |$::| $any)
(def-rpos |$::| $any)
(def-lpos |$::| $any)
(def-mheader |$::| (mset))
(def-led-equiv |$:=| parse-infix)
(def-lbp |$:=| 180)
(def-rbp |$:=| 20)
(def-pos |$:=| $any)
(def-rpos |$:=| $any)
(def-lpos |$:=| $any)
(def-mheader |$:=| (mdefine))
(def-led-equiv |$::=| parse-infix)
(def-lbp |$::=| 180)
(def-rbp |$::=| 20)
(def-pos |$::=| $any)
(def-rpos |$::=| $any)
(def-lpos |$::=| $any)
(def-mheader |$::=| (mdefmacro))
;;; ----------------------------------------------------------------------------
(def-led-equiv |$!| parse-postfix)
(def-lbp |$!| 160)
(def-pos |$!| $expr)
(def-lpos |$!| $expr)
(def-mheader |$!| (mfactorial))
(def-mheader |$!!| ($genfact))
(def-led (|$!!| 160) (op left)
(list '$expr
(mheader '$!!)
(convert left '$expr)
(list (mheader '$/) (convert left '$expr) 2)
2))
(def-lbp |$^| 140)
(def-rbp |$^| 139)
(def-pos |$^| $expr)
(def-lpos |$^| $expr)
(def-rpos |$^| $expr)
(def-mheader |$^| (mexpt))
(def-led ((|$^| |$^^|)) (op left)
(cons '$expr
(getalias (list (mheader op)
(convert left (lpos op))
(parse (rpos op) (rbp op))))))
(mapc #'(lambda (prop)
(let ((propval (get '$^ prop)))
(if propval (putprop '$** propval prop))))
'(lbp rbp pos rpos lpos mheader))
(inherit-propl '$** '$^ '(led))
(def-lbp |$^^| 140)
(def-rbp |$^^| 139)
(def-pos |$^^| $expr)
(def-lpos |$^^| $expr)
(def-rpos |$^^| $expr)
(def-mheader |$^^| (mncexpt))
(def-led-equiv |$.| parse-infix)
(def-lbp |$.| 130)
(def-rbp |$.| 129)
(def-pos |$.| $expr)
(def-lpos |$.| $expr)
(def-rpos |$.| $expr)
(def-mheader |$.| (mnctimes))
(def-led-equiv |$*| parse-nary)
(def-lbp |$*| 120)
;RBP not needed
(def-pos |$*| $expr)
;RPOS not needed
(def-lpos |$*| $expr)
(def-mheader |$*| (mtimes))
(def-led-equiv $/ parse-infix)
(def-lbp $/ 120)
(def-rbp $/ 120)
(def-pos $/ $expr)
(def-rpos $/ $expr)
(def-lpos $/ $expr)
(def-mheader $/ (mquotient))
(def-nud-equiv |$+| parse-prefix)
(def-lbp |$+| 100)
(def-rbp |$+| 134) ; Value increased from 100 to 134 (DK 02/2010).
(def-pos |$+| $expr)
(def-rpos |$+| $expr)
;LPOS not needed
(def-mheader |$+| (mplus))
(def-led ((|$+| |$-|) 100) (op left)
(setq left (convert left '$expr))
(do ((nl (list (if (eq op '$-)
(list (mheader '$-) (parse '$expr 100))
(parse '$expr 100))
left)
(cons (parse '$expr 100) nl)))
((not (member (peek-one-token) '($+ $-) :test #'eq))
(list* '$expr (mheader '$+) (nreverse nl)))
(if (eq (peek-one-token) '$+) (scan-one-token))))
(def-nud-equiv |$-| parse-prefix)
(def-lbp |$-| 100)
(def-rbp |$-| 134)
(def-pos |$-| $expr)
(def-rpos |$-| $expr)
;LPOS not needed
(def-mheader |$-| (mminus))
;;; ----------------------------------------------------------------------------
(def-led-equiv |$=| parse-infix)
(def-lbp |$=| 80)
(def-rbp |$=| 80)
(def-pos |$=| $clause)
(def-rpos |$=| $expr)
(def-lpos |$=| $expr)
(def-mheader |$=| (mequal))
(def-led-equiv |$#| parse-infix)
(def-lbp |$#| 80)
(def-rbp |$#| 80)
(def-pos |$#| $clause)
(def-rpos |$#| $expr)
(def-lpos |$#| $expr)
(def-mheader |$#| (mnotequal))
;;; ----------------------------------------------------------------------------
(def-led-equiv |$>| parse-infix)
(def-lbp |$>| 80)
(def-rbp |$>| 80)
(def-pos |$>| $clause)
(def-rpos |$>| $expr)
(def-lpos |$>| $expr)
(def-mheader |$>| (mgreaterp))
(def-led-equiv |$>=| parse-infix)
(def-lbp |$>=| 80)
(def-rbp |$>=| 80)
(def-pos |$>=| $clause)
(def-rpos |$>=| $expr)
(def-lpos |$>=| $expr)
(def-mheader |$>=| (mgeqp))
(def-led-equiv |$<| parse-infix)
(def-lbp |$<| 80)
(def-rbp |$<| 80)
(def-pos |$<| $clause)
(def-rpos |$<| $expr)
(def-lpos |$<| $expr)
(def-mheader |$<| (mlessp))
(def-led-equiv |$<=| parse-infix)
(def-lbp |$<=| 80)
(def-rbp |$<=| 80)
(def-pos |$<=| $clause)
(def-rpos |$<=| $expr)
(def-lpos |$<=| $expr)
(def-mheader |$<=| (mleqp))
(def-nud-equiv $not parse-prefix)
;LBP not needed
(def-rbp $not 70)
(def-pos $not $clause)
(def-rpos $not $clause)
(def-lpos $not $clause)
(def-mheader $not (mnot))
(def-led-equiv $and parse-nary)
(def-lbp $and 65)
;RBP not needed
(def-pos $and $clause)
;RPOS not needed
(def-lpos $and $clause)
(def-mheader $and (mand))
(def-led-equiv $or parse-nary)
(def-lbp $or 60)
;RBP not needed
(def-pos $or $clause)
;RPOS not needed
(def-lpos $or $clause)
(def-mheader $or (mor))
(def-led-equiv |$,| parse-nary)
(def-lbp |$,| 10)
;RBP not needed
(def-pos |$,| $any)
;RPOS not needed
(def-lpos |$,| $any)
(def-mheader |$,| ($ev))
(def-nud-equiv $then parse-delim-err)
(def-lbp $then 5)
(def-rbp $then 25)
(def-nud-equiv $else parse-delim-err)
(def-lbp $else 5)
(def-rbp $else 25)
(def-nud-equiv $elseif parse-delim-err)
(def-lbp $elseif 5)
(def-rbp $elseif 45)
(def-pos $elseif $any)
(def-rpos $elseif $clause)
;No LBP - Default as high as possible
(def-rbp $if 45)
(def-pos $if $any)
(def-rpos $if $clause)
;No LPOS
(def-mheader $if (mcond))
(def-nud ($if) (op)
(list* (pos op)
(mheader op)
(parse-condition op)))
(defun parse-condition (op)
(list* (parse (rpos op) (rbp op))
(if (eq (peek-one-token) '$then)
(parse '$any (rbp (scan-one-token)))
(mread-synerr "Missing `then'"))
(case (peek-one-token)
(($else) (list t (parse '$any (rbp (scan-one-token)))))
(($elseif) (parse-condition (scan-one-token)))
(t ; Note: $false instead of () makes DISPLA suppress display!
(list t '$false)))))
;;; ----------------------------------------------------------------------------
(defmacro make-mdo () '(list (list 'mdo) nil nil nil nil nil nil nil))
(defmacro mdo-op (x) `(car (car ,x)))
(defmacro mdo-for (x) `(second ,x))
(defmacro mdo-from (x) `(third ,x))
(defmacro mdo-step (x) `(fourth ,x))
(defmacro mdo-next (x) `(fifth ,x))
(defmacro mdo-thru (x) `(sixth ,x))
(defmacro mdo-unless (x) `(seventh ,x))
(defmacro mdo-body (x) `(eighth ,x))
;;; ----------------------------------------------------------------------------
(defun parse-$do (lex &aux (left (make-mdo)))
(setf (car left) (mheader 'mdo))
(do ((op lex (scan-one-token)) (active-bitmask 0))
(nil)
(if (eq op '|$:|) (setq op '$from))
(setq active-bitmask (collision-check '$do active-bitmask op))
(let ((data (parse (rpos op) (rbp op))))
(case op
($do (setf (mdo-body left) data) (return (cons '$any left)))
($for (setf (mdo-for left) data))
($from (setf (mdo-from left) data))
($in (setf (mdo-op left) 'mdoin)
(setf (mdo-from left) data))
($step (setf (mdo-step left) data))
($next (setf (mdo-next left) data))
($thru (setf (mdo-thru left) data))
(($unless $while)
(if (eq op '$while)
(setq data (list (mheader '$not) data)))
(setf (mdo-unless left)
(if (null (mdo-unless left))
data
(list (mheader '$or) data (mdo-unless left)))))
(t (parse-bug-err '$do))))))
(def-nud-equiv $for parse-$do)
(def-nud-equiv $from parse-$do)
(def-nud-equiv $step parse-$do)
(def-nud-equiv $next parse-$do)
(def-nud-equiv $thru parse-$do)
(def-nud-equiv $unless parse-$do)
(def-nud-equiv $while parse-$do)
(def-nud-equiv $do parse-$do)
(def-lbp $for 25)
(def-lbp $from 25)
(def-lbp $step 25)
(def-lbp $next 25)
(def-lbp $thru 25)
(def-lbp $unless 25)
(def-lbp $while 25)
(def-lbp $do 25)
(def-rbp $do 25)
(def-rbp $for 200)
(def-rbp $from 95)
(def-rbp $in 95)
(def-rbp $step 95)
(def-rbp $next 45)
(def-rbp $thru 95)
(def-rbp $unless 45)
(def-rbp $while 45)
(def-rpos $do $any)
(def-rpos $for $any)
(def-rpos $from $any)
(def-rpos $step $expr)
(def-rpos $next $any)
(def-rpos $thru $expr)
(def-rpos $unless $clause)
(def-rpos $while $clause)
(def-mheader $do (mdo))
(def-collisions $do
($do . ())
($for . ($for))
($from . ($in $from))
($in . ($in $from $step $next))
($step . ($in $step $next))
($next . ($in $step $next))
($thru . ($in $thru))
($unless . ())
($while . ()))
;;; ----------------------------------------------------------------------------
(def-mheader |$;| (displayinput))
(def-nud-equiv |$;| parse-premterm-err)
(def-lbp |$;| -1)
(def-mheader |$$| (nodisplayinput))
(def-nud-equiv |$$| parse-premterm-err)
(def-lbp |$$| -1)
(def-nud-equiv |$&&| parse-delim-err)
(def-lbp |$&&| -1)
;;; ----------------------------------------------------------------------------
(defun $prefix (operator &optional (rbp 180) (rpos '$any) (pos '$any))
(def-operator operator
pos () () rbp rpos () t
'(nud . parse-prefix) 'msize-prefix 'dimension-prefix ())
operator)
(defun $postfix (operator &optional (lbp 180) (lpos '$any) (pos '$any))
(def-operator operator pos lbp lpos () () t ()
'(led . parse-postfix) 'msize-postfix 'dimension-postfix ())
operator)
(defun $infix (operator &optional (lbp 180) (rbp 180) (lpos '$any)
(rpos '$any) (pos '$any))
(def-operator operator pos lbp lpos rbp rpos t t
'(led . parse-infix) 'msize-infix 'dimension-infix ())
operator)
(defun $nary (operator &optional (bp 180) (argpos '$any) (pos '$any))
(def-operator operator pos bp argpos bp () t t
'(led . parse-nary) 'msize-nary 'dimension-nary ())
operator)
(defun $matchfix (operator match &optional (argpos '$any) (pos '$any))
(def-operator operator pos () argpos () () () ()
'(nud . parse-matchfix)
'msize-matchfix
'dimension-match match)
operator)
(defun $nofix (operator &optional (pos '$any))
(def-operator operator pos () () () () () ()
'(nud . parse-nofix) 'msize-nofix 'dimension-nofix ())
operator)
;;; ----------------------------------------------------------------------------
(defun def-operator (op pos lbp lpos rbp rpos sp1 sp2
parse-data grind-fn dim-fn match)
(let ((x))
(if (or (and rbp (not (integerp (setq x rbp))))
(and lbp (not (integerp (setq x lbp)))))
(merror "syntax extension: binding powers must be integers; found: ~A"
x))
(when (stringp op)
(cond ((not (every 'alphabetp (coerce op 'list)))
(setq op (define-symbol op)))
(t
(setq op (symbolconc '$ (maybe-invert-string op))))))
(when (not (symbolp op))
(merror "syntax extension: first argument must be a string or a symbol;~
found: ~A"
op))
(op-setup op)
(let ((noun ($nounify op))
(dissym (cdr (exploden op))))
(cond ((not match)
(setq dissym
(append (if sp1 '(#\space)) dissym (if sp2 '(#\space)))))
(t
(if (stringp match) (setq match (define-symbol match)))
(op-setup match)
(putprop op match 'match)
(putprop match 5 'lbp)
(setq dissym (cons dissym (cdr (exploden match))))))
(putprop op pos 'pos)
(putprop op (cdr parse-data) (car parse-data))
(putprop op grind-fn 'grind)
(putprop op dim-fn 'dimension)
(putprop noun dim-fn 'dimension)
(putprop op dissym 'dissym)
(putprop noun dissym 'dissym)
(when rbp
(putprop op rbp 'rbp)
(putprop noun rbp 'rbp))
(when lbp
(putprop op lbp 'lbp)
(putprop noun lbp 'lbp))
(when lpos (putprop op lpos 'lpos))
(when rpos (putprop op rpos 'rpos))
(getopr op))))
(defun op-setup (op)
(declare (special *mopl* $props))
(let ((opr (or (getprop op 'op)
(coerce (makestring1 op) 'string))))
(putprop op opr 'op)
(putopr opr op)
(if (and (operatorp1 op)
(not (member opr (cdr $props) :test #'eq)))
(push opr *mopl*))
(add2lnc opr $props)))
;;; ----------------------------------------------------------------------------
B.7 nformat.lisp
;;; ----------------------------------------------------------------------------
;;; nformat.lisp
;;;
;;; Copyright (C) 2011 Dr. Dieter Kaiser
;;;
;;; This file contains modified code from:
;;;
;;; Copyright (C) 1984, 1987 William Schelter, University of Texas
;;; Copyright (C) 1981, 1982 Massachusetts Institute of Technology
;;;
;;; This program is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2 of the License, or
;;; (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
;;; ----------------------------------------------------------------------------
(in-package :kmaxima)
(defmvar $powerdispflag nil)
(defmvar $ratdispflag nil)
(defmvar $%edispflag nil)
(defmvar $exptdispflag t)
(defmvar $sqrtdispflag t)
(defmvar $negsumdispflag t)
(defun nformat (form)
(cond ((atom form)
(cond ((and (numberp form) (minusp form))
(list '(mminus) (- form)))
(t form)))
((atom (car form)) form)
((eq 'rat (caar form))
(cond ((minusp (cadr form))
(list '(mminus) (list '(rat) (- (cadr form)) (caddr form))))
(t (cons '(rat) (cdr form)))))
((eq 'bigfloat (caar form))
(if (minusp (cadr form))
(list '(mminus) (list (car form) (- (cadr form)) (caddr form)))
(cons (car form) (cdr form))))
((null (cdar form)) form)
((eq 'mplus (caar form)) (nformat-mplus form))
((eq 'mtimes (caar form)) (nformat-mtimes form))
((eq 'mexpt (caar form)) (nformat-mexpt form))
(t form)))
(defun nformat-all (form)
(setq form (nformat form))
(if (atom form)
form
(cons (delete 'simp (copy-list (car form)) :count 1 :test #'eq)
(mapcar #'nformat-all (cdr form)))))
(defun nformat-mplus (form &aux args)
(setq args (mapcar #'nformat (cdr form)))
(cons '(mplus)
(cond ($powerdispflag
args)
((and $negsumdispflag
(null (cdddr form)))
(if (and (not (mminusp (car args)))
(mminusp (cadr args)))
args
(nreverse args)))
(t (nreverse args)))))
(defun nformat-mtimes (form)
(cond ((null (cdr form)) '((mtimes)))
((equal -1 (cadr form))
(list '(mminus) (nformat-mtimes (cdr form))))
(t
(prog (num den minus flag)
(do ((l (cdr form) (cdr l))
(fact))
((null l))
(setq fact (nformat (car l)))
(cond ((atom fact) (setq num (cons fact num)))
((eq 'mminus (caar fact))
(setq minus (not minus)
l (append fact (cdr l))))
((or (eq 'mquotient (caar fact))
(and (not $ratdispflag)
(eq 'rat (caar fact))))
(cond ((not (equal 1 (cadr fact)))
(setq num (cons (cadr fact) num))))
(setq den (cons (caddr fact) den)))
(t (setq num (cons fact num)))))
(setq num (cond ((null num) 1)
((null (cdr num)) (car num))
(t (cons '(mtimes) (nreverse num))))
den (cond ((null den) (setq flag t) nil)
((null (cdr den)) (car den))
(t (cons '(mtimes) (nreverse den)))))
(if (not flag)
(setq num (list '(mquotient) num den)))
(return (if minus (list '(mminus) num) num))))))
(defun nformat-mexpt (form &aux expr)
(cond ((and $sqrtdispflag (alike1 '((rat) 1 2) (caddr form)))
(list '(%sqrt) (cadr form)))
((and $sqrtdispflag (alike1 '((rat) -1 2) (caddr form)))
(list '(mquotient) 1 (list '(%sqrt) (cadr form))))
((and (or (and $%edispflag (eq '$%e (cadr form)))
(and $exptdispflag (not (eq '$%e (cadr form)))))
(not (atom (setq expr (nformat (caddr form)))))
(eq 'mminus (caar expr)))
(list '(mquotient) 1 (if (equal 1 (cadr expr))
(cadr form)
(list '(mexpt) (cadr form) (cadr expr)))))
(t (cons '(mexpt) (cdr form)))))
;;; ----------------------------------------------------------------------------
B.8 grind.lisp
;;; ----------------------------------------------------------------------------
;;; grind.lisp
;;;
;;; Copyright (C) 2011 Dr. Dieter Kaiser
;;;
;;; This file contains modified code from:
;;;
;;; Copyright (C) 1984, 1987 William Schelter, University of Texas
;;; Copyright (C) 1981 Massachusetts Institute of Technology
;;;
;;; This program is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2 of the License, or
;;; (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
;;; ----------------------------------------------------------------------------
(in-package :kmaxima)
(defvar *linel* 79)
(defmvar $linel 79)
(defprop $linel shadowset assign)
(defprop $linel *linel* shadowvar)
;;; ----------------------------------------------------------------------------
(defun strsym (x)
(or (getprop x 'strsym) (getprop x 'dissym)))
;;; ----------------------------------------------------------------------------
(defmvar $stringdispflag nil)
(defmvar $lispdispflag nil)
(defun makestring (x)
(declare (special $aliases))
(let (y)
(cond ((numberp x) (exploden x))
((stringp x)
(setq y (coerce x 'list))
(if $stringdispflag
(cons #\" (nconc y (list #\")))
y))
((not (symbolp x)) (exploden x))
((and (setq y (getprop x 'reversealias))
(not (and (member x $aliases :test #'eq)
(getprop x 'noun))))
(exploden (stripdollar y)))
((not (eq (getop x) x))
(makestring (getop x)))
((null (setq y (exploden x))))
((or (char= #\$ (car y))
(char= #\% (car y)))
(cdr y))
($lispdispflag (cons #\? y))
(t y))))
(defun makestring1 (x)
(let (($stringdispflag nil) ($lispdispflag nil))
(makestring x)))
;;; ----------------------------------------------------------------------------
(defun mstring (x)
(labels ((string1 (x l)
(cond ((atom x) (cons x l))
(t
(do ((x (cdr x) (cdr x)))
((null x) l)
(setq l (string1 (car x) l)))))))
(nreverse (string1 (msize x nil nil 'mparen 'mparen) nil))))
;;; ----------------------------------------------------------------------------
(let ((chrps 0))
(defun mgrind (form out)
(setq chrps 0)
(mprint (msize form nil nil 'mparen 'mparen) out))
(defun mprint (form out)
(labels ((mtyotbsp (n out)
(declare (fixnum n))
(incf chrps n)
(dotimes (i n)
(write-char #\space out)))
(charpos ()
(- *linel* chrps)))
(cond ((characterp form)
(incf chrps)
(write-char form out))
((< (car form) (charpos))
(mapc #'(lambda (l) (mprint l out)) (cdr form)))
(t
(prog ((i chrps))
(mprint (cadr form) out)
(cond ((null (cddr form)) (return nil))
((and (or (atom (cadr form)) (< (caadr form) (charpos)))
(or (> (charpos) (truncate *linel* 2))
(atom (caddr form))
(< (caaddr form) (charpos))))
(setq i chrps)
(mprint (caddr form) out))
(t
(incf i)
(setq chrps 0)
(terpri out)
(mtyotbsp i out)
(mprint (caddr form) out)))
(do ((l (cdddr form) (cdr l)))
((null l))
(cond ((or (atom (car l)) (< (caar l) (charpos))) nil)
(t
(setq chrps 0)
(terpri out)
(mtyotbsp i out)))
(mprint (car l) out)))))))
)
;;; ----------------------------------------------------------------------------
(defvar *lop* nil)
(defvar *rop* nil)
(defun msize (x l r *lop* *rop*)
(setq x (nformat x))
(cond ((atom x) (msize-atom x l r))
((and (atom (car x)) (setq x (cons '(mprogn) x)) nil))
((or (<= (lbp (caar x)) (rbp *lop*))
(> (lbp *rop*) (rbp (caar x))))
(msize-paren x l r))
((member 'array (cdar x) :test #'eq) (msize-array x l r))
((getprop (caar x) 'grind)
(the (values t) (funcall (get (caar x) 'grind) x l r)))
(t (msize-function x l r nil))))
;;; ----------------------------------------------------------------------------
(defun msize-paren (x l r)
(msize x (cons #\( l) (cons #\) r) 'mparen 'mparen))
(defun msize-atom (x l r)
(declare (special $aliases))
(labels ((slash (x)
(do ((l (cdr x) (cdr l)))
((null l))
(if (or (digit-char-p (car l))
(alphabetp (car l)))
nil
(progn
(rplacd l (cons (car l) (cdr l)))
(rplaca l #\\ ) (setq l (cdr l)))))
(if (alphabetp (car x))
x
(cons #\\ x))))
(prog (y)
(cond ((numberp x) (setq y (exploden x)))
((eq x nil) (setq y (exploden (stripdollar '$false))))
((eq x t) (setq y (exploden (stripdollar '$true))))
((stringp x)
(setq y (coerce x 'list))
(do ((l y (cdr l)))
((null l))
(when (member (car l) '(#\" #\\ ) :test #'equal)
(rplacd l (cons (car l) (cdr l)))
(rplaca l #\\ )
(setq l (cdr l))))
(setq y (cons #\" (nconc y (list #\")))))
((and (setq y (getprop x 'reversealias))
(not (and (member x $aliases :test #'eq)
(getprop x 'noun))))
(setq y (exploden (stripdollar y))))
((setq y (getprop x 'noun))
(return (msize-atom y l r)))
((null (setq y (exploden x))))
((char= #\$ (car y)) (setq y (slash (cdr y))))
(t (setq y (cons #\? (slash y)))))
(return (msz y l r)))))
(defun msz (x l r)
(setq x (nreconc l (nconc x r)))
(cons (length x) x))
(defun msize-array (x l r &aux f)
(declare (special $aliases))
(if (eq (caar x) 'mqapply)
(setq f (cadr x)
x (cdr x))
(setq f (caar x)))
(cond ((and (getprop (caar x) 'verb)
(getprop (caar x) 'alias))
(setq l (revappend '(#\' #\' ) l)))
((and (getprop (caar x) 'noun)
(not (member (caar x) (cdr $aliases) :test #'eq))
(not (get (caar x) 'reversealias)))
(setq l (cons #\' l))))
(setq l (msize f l (list #\[ ) *lop* 'mfunction)
r (msize-list (cdr x) nil (cons #\] r)))
(cons (+ (car l) (car r)) (cons l (cdr r))))
(defun msize-function (x l r op)
(declare (special $aliases))
(cond ((not (symbolp (caar x))))
((and (getprop (caar x) 'verb)
(getprop (caar x) 'alias))
(setq l (revappend '(#\' #\' ) l)))
((and (getprop (caar x) 'noun)
(not (member (caar x) (cdr $aliases) :test #'eq))
(not (getprop (caar x) 'reversealias)))
(setq l (cons #\' l))))
(setq l (msize (if op
(getop (caar x))
(caar x))
l
(list #\( ) 'mparen 'mparen)
r (msize-list (cdr x) nil (cons #\) r)))
(cons (+ (car l) (car r)) (cons l (cdr r))))
(defun msize-list (x l r)
(if (null x)
(msz nil l r)
(do ((nl) (w 0))
((null (cdr x))
(setq nl (cons (msize (car x) l r 'mparen 'mparen) nl))
(cons (+ w (caar nl)) (nreverse nl)))
(declare (fixnum w))
(setq nl (cons (msize (car x) l (list #\, ) 'mparen 'mparen) nl)
w (+ w (caar nl))
x (cdr x) l nil))))
;;; ----------------------------------------------------------------------------
(defun msize-prefix (x l r)
(msize (cadr x) (revappend (strsym (caar x)) l) r (caar x) *rop*))
(defun msize-infix (x l r)
(if (not (= (length (cdr x)) 2))
(return-from msize-infix (msize-function x l r t)))
(setq l (msize (cadr x) l nil *lop* (caar x))
r (msize (caddr x) (reverse (strsym (caar x))) r (caar x) *rop*))
(list (+ (car l) (car r)) l r))
(defun msize-postfix (x l r)
(msize (cadr x) l (append (strsym (caar x)) r) *lop* (caar x)))
(defun msize-nofix (x l r)
(msize (caar x) l r (caar x) *rop*))
(defun msize-matchfix (x l r)
(setq l (nreconc l (car (strsym (caar x))))
l (cons (length l) l)
r (append (cdr (strsym (caar x))) r)
x (msize-list (cdr x) nil r))
(cons (+ (car l) (car x)) (cons l (cdr x))))
(defun msize-nary (x l r)
(msznary x l r (strsym (caar x))))
(defun msznary (x l r strsym)
(cond ((null (cddr x)) (msize-function x l r t))
(t
(setq l (msize (cadr x) l nil *lop* (caar x)))
(do ((ol (cddr x) (cdr ol)) (nl (list l)) (w (car l)))
((null (cdr ol))
(setq r (msize (car ol) (reverse strsym) r (caar x) *rop*))
(cons (+ (car r) w) (nreverse (cons r nl))))
(declare (fixnum w))
(setq nl
(cons (msize (car ol)
(reverse strsym) nil (caar x) (caar x))
nl)
w (+ (caar nl) w))))))
;;; ----------------------------------------------------------------------------
(defprop mparen -1 lbp)
(defprop mparen -1 rbp)
(defprop mprogn msize-matchfix grind)
(defprop mprogn ((#\( ) #\) ) strsym)
(defprop mlist msize-matchfix grind)
(defprop mlist ((#\[ ) #\] ) strsym)
;;; ----------------------------------------------------------------------------
(defprop mlabel msize-mlabel grind)
(defun msize-mlabel (x l r)
(declare (special *display-labels-p*))
(cond (*display-labels-p*
(setq l (msize (cadr x) (list #\( ) (list #\) #\ ) nil nil)
r (msize (caddr x) nil r 'mparen 'mparen))
(cons (+ (car l) (car r)) (cons l (cons r nil))))
(t (msize (caddr x) l r 'mparen 'mparen))))
;;; ----------------------------------------------------------------------------
(defprop mtext msize-mtext grind)
(defun msize-mtext (x l r)
(setq x (cdr x))
(if (null x)
(msz nil l r)
(do ((nl) (w 0))
((null (cdr x))
(setq nl (cons (if (atom (car x))
(msz (makestring (car x)) l r)
(msize (car x) l r *lop* *rop*))
nl))
(cons (+ w (caar nl)) (nreverse nl)))
(setq nl (cons (if (atom (car x))
(msz (makestring (car x)) l r)
(msize (car x) l nil *lop* *rop*))
nl)
w (+ w (caar nl))
x (cdr x)
l nil))))
(defprop mqapply msize-mqapply grind)
(defun msize-mqapply (x l r)
(setq l (msize (cadr x) l (list #\( ) *lop* 'mfunction)
r (msize-list (cddr x) nil (cons #\) r)))
(cons (+ (car l) (car r)) (cons l (cdr r))))
(defprop mquote msize-prefix grind)
(defprop msetq msize-infix grind)
(defprop msetq (#\:) strsym)
(defprop msetq 180 lbp)
(defprop msetq 20 rbp)
(defprop mset msize-infix grind)
(defprop mset (#\: #\:) strsym)
(defprop mset 180 lbp)
(defprop mset 20 rbp)
(defprop mdefine msize-mdef grind)
(defprop mdefine (#\: #\=) strsym)
(defprop mdefine 180 lbp)
(defprop mdefine 20 rbp)
(defprop mdefmacro msize-mdef grind)
(defprop mdefmacro (#\: #\: #\=) strsym)
(defprop mdefmacro 180 lbp)
(defprop mdefmacro 20 rbp)
(defun msize-mdef (x l r)
(setq l (msize (cadr x) l (copy-list (strsym (caar x))) *lop* (caar x))
r (msize (caddr x) nil r (caar x) *rop*))
(cond ((not (atom (cadr l)))
(setq x (cons (- (car l) (caadr l)) (cddr l)))
(if (and (not (atom (cadr r)))
(not (atom (caddr r)))
(< (+ (car l) (caadr r) (caaddr r)) *linel*))
(setq x (nconc x (list (cadr r) (caddr r)))
r (cons (car r) (cdddr r))))
(cons (+ (car l) (car r)) (cons (cadr l) (cons x (cdr r)))))
(t
(cons (+ (car l) (car r)) (cons l (ncons r))))))
;;; ----------------------------------------------------------------------------
(defprop mplus msize-mplus grind)
(defprop mplus 100 lbp)
(defprop mplus 100 rbp)
(defun msize-mplus (x l r)
(cond ((null (cddr x))
(if (null (cdr x))
(msize-function x l r t)
(msize (cadr x) (append (list #\+ ) l) r 'mplus *rop*)))
(t
(setq l (msize (cadr x) l nil *lop* 'mplus)
x (cddr x))
(do ((nl (list l)) (w (car l)) (dissym))
((null (cdr x))
(if (mminusp (car x))
(setq l (cadar x)
dissym (list #\- ))
(setq l (car x)
dissym (list #\+ )))
(setq r (msize l dissym r 'mplus *rop*))
(cons (+ (car r) w) (nreverse (cons r nl))))
(declare (fixnum w))
(if (mminusp (car x))
(setq l (cadar x) dissym (list #\- ))
(setq l (car x) dissym (list #\+ )))
(setq nl (cons (msize l dissym nil 'mplus 'mplus) nl)
w (+ (caar nl) w)
x (cdr x))))))
(defprop mminus msize-mminus grind)
(defprop mminus (#\-) strsym)
(defprop mminus 100 rbp)
(defprop mminus 100 lbp)
(defun msize-mminus (x l r)
(cond ((null (cddr x))
(if (null (cdr x))
(msize-function x l r t)
(msize (cadr x) (append (list #\- ) l) r 'mminus *rop*)))
(t
(setq l (msize (cadr x) l nil *lop* 'mminus)
x (cddr x))
(do ((nl (list l)) (w (car l)) (dissym))
((null (cdr x))
(if (mminusp (car x))
(setq l (cadar x)
dissym (list #\+ ))
(setq l (car x)
dissym (list #\- )))
(setq r (msize l dissym r 'mminus *rop*))
(cons (+ (car r) w) (nreverse (cons r nl))))
(declare (fixnum w))
(if (mminusp (car x))
(setq l (cadar x) dissym (list #\+ ))
(setq l (car x) dissym (list #\- )))
(setq nl (cons (msize l dissym nil 'mplus 'mminus) nl)
w (+ (caar nl) w)
x (cdr x))))))
(defprop mtimes msize-mtimes grind)
(defprop mtimes 120 lbp)
(defprop mtimes 120 rbp)
(defun msize-mtimes (x l r)
(msznary x l r '(#\* )))
(defprop mnctimes msize-nary grind)
(defprop mnctimes 130 lbp)
(defprop mnctimes 129 rbp)
(defprop mexpt msize-mexpt grind)
(defprop mexpt 140 lbp)
(defprop mexpt 139 rbp)
(defun msize-mexpt (x l r)
(setq l (msize (cadr x) l nil *lop* 'mexpt)
r (if (mminusp (setq x (nformat (caddr x))))
(msize (cadr x) (reverse '(#\^ #\-)) r 'mexpt *rop*)
(msize x (list #\^) r 'mexpt *rop*)))
(list (+ (car l) (car r)) l r))
(defprop mncexpt msize-infix grind)
(defprop mncexpt (#\^ #\^) strsym)
(defprop mncexpt 140 lbp)
(defprop mncexpt 139 rbp)
(defprop mquotient msize-infix grind)
(defprop mquotient (#\/) strsym)
(defprop mquotient 120 lbp)
(defprop mquotient 120 rbp)
(defprop rat msize-infix grind)
(defprop rat (#\/) strsym)
(defprop rat 120 lbp)
(defprop rat 120 rbp)
(defprop mfactorial msize-postfix grind)
(defprop mfactorial 160 lbp)
;;; ----------------------------------------------------------------------------
(defprop mequal msize-infix grind)
(defprop mequal (#\=) strsym)
(defprop mequal 80 lbp)
(defprop mequal 80 rbp)
(defprop mnotequal msize-infix grind)
(defprop mnotequal 80 lbp)
(defprop mnotequal 80 rbp)
(defprop mgreaterp msize-infix grind)
(defprop mgreaterp 80 lbp)
(defprop mgreaterp 80 rbp)
(defprop mgeqp msize-infix grind)
(defprop mgeqp 80 lbp)
(defprop mgeqp 80 rbp)
(defprop mlessp msize-infix grind)
(defprop mlessp 80 lbp)
(defprop mlessp 80 rbp)
(defprop mleqp msize-infix grind)
(defprop mleqp 80 lbp)
(defprop mleqp 80 rbp)
(defprop mnot msize-prefix grind)
(defprop mnot 70 rbp)
(defprop mand msize-nary grind)
(defprop mand 65 lbp)
(defprop mand 65 rbp)
(defprop mor msize-nary grind)
(defprop mor 60 lbp)
(defprop mor 60 rbp)
;;; ----------------------------------------------------------------------------
(defprop mcond msize-mcond grind)
(defprop mcond 45 lbp)
(defprop mcond 45 rbp)
(defun msize-mcond (x l r)
(labels ((strmcond (x)
(let ((l (reverse (cdr x))))
(if (and (or (eq (car l) nil)
(eq (car l) '$false))
(eq (cadr l) t))
(setq l (reverse (cddr l)))
(setq l (reverse l)))
(append `($if)
(do ((l l (cddr l))
(sym nil '$elseif)
(res nil))
((null (cddr l))
(if (and sym
(not (eq t (car l))))
(append res `(,sym ,(car l) $then ,(cadr l)))
(if (eq t (car l))
(append res `($else ,(cadr l)))
(append res
`(,(car l) $then ,(cadr l))))))
(setq res (append res
(if sym
`(,sym ,(car l)) `(,(car l)))
`($then ,(cadr l)))))))))
(msznary (cons '(mcond) (strmcond x)) l r '(#\space))))
;;; ----------------------------------------------------------------------------
(defprop mdo msize-mdo grind)
(defprop mdo 25 lbp)
(defprop mdo 25 rbp)
(defun msize-mdo (x l r)
(labels ((strmdo (x)
(nconc (cond ((second x) `($for ,(second x))))
(cond ((eql 1 (third x)) nil)
((third x) `($from ,(third x))))
(cond ((eql 1 (fourth x)) nil)
((fourth x) `($step ,(fourth x)))
((fifth x) `($next ,(fifth x))))
(cond ((sixth x) `($thru ,(sixth x))))
(cond ((null (seventh x)) nil)
((and (consp (seventh x))
(eq 'mnot (caar (seventh x))))
`($while ,(cadr (seventh x))))
(t `($unless ,(seventh x))))
`($do ,(eighth x)))))
(msznary (cons '(mdo) (strmdo x)) l r '(#\space))))
;;; ----------------------------------------------------------------------------
(defprop mdoin msize-mdoin grind)
(defprop mdoin 30 lbp)
(defprop mdoin 30 rbp)
(defun msize-mdoin (x l r)
(labels ((strmdoin (x)
(nconc `($for ,(second x) $in ,(third x))
(cond ((null (seventh x)) nil)
((and (consp (seventh x))
(eq 'mnot (caar (seventh x))))
`($while ,(cadr (seventh x))))
(t `($unless ,(seventh x))))
`($do ,(eighth x)))))
(msznary (cons '(mdo) (strmdoin x)) l r '(#\space))))
;;; ----------------------------------------------------------------------------
B.9 display.lisp
;;; ----------------------------------------------------------------------------
;;; display.lisp
;;;
;;; Copyright (C) 2011 Dr. Dieter Kaiser
;;;
;;; This file contains modified code from:
;;;
;;; Copyright (C) 1984, 1987 William Schelter,University of Texas
;;; Copyright (C) 1979 Massachusetts Institute of Technology
;;;
;;; This program is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2 of the License, or
;;; (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
;;; ----------------------------------------------------------------------------
(in-package :kmaxima)
(defvar *debug-dimension* nil)
(defmvar $display2d t)
(defmvar $leftjust nil)
(defmvar $display_format_internal nil)
(defmvar $noundisp nil)
(defmvar $derivabbrev nil)
(defmvar $boxchar "\"")
(defmvar $absboxchar "!")
(defmvar $lmxchar "[")
(defmvar $rmxchar "]")
(defmvar $stardisp nil)
(defprop $stardisp stardisp assign)
(defun stardisp (symbol val)
(declare (ignore symbol))
(putprop 'mtimes (if val '(#\*) '(#\space)) 'dissym))
(defvar *display-labels-p* t)
(defvar *linearray* (make-array 80 :initial-element nil))
(defvar *lines* 1)
(defvar *level* 0)
(defvar *break* 0)
(defvar *size* 2)
(defvar *bkpt* nil)
(defvar *bkptout* 0)
(defvar *bkptwd* 0)
(defvar *bkptdp* 0)
(defvar *bkptht* 1)
(defvar *bkptlevel* 0)
(defvar *width* 0)
(defvar *height* 0)
(defvar *depth* 0)
(defvar *right* 0)
(defvar *maxht* 1)
(defvar *maxdp* 0)
(defvar *oldrow* 0)
(defvar *oldcol* 0)
(defvar *mratp* nil)
(eval-when (:compile-toplevel :load-toplevel :execute)
(defvar ^w nil)
(defvar ttyoff '^w))
;;; ----------------------------------------------------------------------------
(defmacro push-string (str sym)
`(setq ,sym (list* ,@(nreverse (exploden str)) ,sym)))
(defmacro displa-def (op dim-function &rest rest &aux l-dissym r-dissym lbp rbp)
(dolist (x rest)
(cond ((typep x 'string)
(if l-dissym (setq r-dissym x) (setq l-dissym x)))
((integerp x)
(if rbp (setq lbp rbp))
(setq rbp x))
(t (merror "DISPLA-DEF: unrecognized object: ~a" x))))
(when l-dissym
(setq l-dissym (if r-dissym
(cons (exploden l-dissym) (exploden r-dissym))
(exploden l-dissym))))
`(progn
(defprop ,op ,dim-function dimension)
,(when l-dissym `(defprop ,op ,l-dissym dissym))
,(when lbp `(defprop ,op ,lbp lbp))
,(when rbp `(defprop ,op ,rbp rbp))))
;;; ----------------------------------------------------------------------------
(defun mdisplay (form)
(declare (special *linel*))
(when (not #.ttyoff)
(cond ($display2d
(let ((*mratp* (checkrat form))
(*maxht* 1) (*maxdp* 0) (*width* 0)
(*height* 0) (*depth* 0) (*level* 0) (*size* 2)
(*break* 0) (*right* 0) (*lines* 1) (*bkpt* nil)
(*bkptwd* 0) (*bkptht* 1) (*bkptdp* 0) (*bkptout* 0)
(*bkptlevel* 0))
(unwind-protect
(progn
(setq form (dimension form nil 'mparen 'mparen 0 0))
(checkbreak form *width*)
(output form (if (and (not $leftjust) (= 2 *lines*))
(- *linel* (- *width* *bkptout*))
0)))
(fill *linearray* nil))))
(t
(fresh-line *standard-output*)
(mgrind form *standard-output*)
(terpri)))))
;;; ----------------------------------------------------------------------------
(defun checkrat (form)
(declare (ignore form))
nil)
(defun checkfit (w)
(or (not *break*)
(<= (- (+ w *break* *right* 1) *bkptwd*) *linel*)))
(defun checkbreak (result w)
(cond ((not *break*))
((> (- (setq w (+ w *break*)) *bkptout*) *linel*)
(if (or (null *bkpt*)
(eq result *bkpt*))
(merror "display: failed to break up a long expression.~%~
display: change 'linel' slightly and try again."))
(do ((l result (cdr l)))
((eq *bkpt* (cdr l)) (rplacd l nil))
(if (null l)
(merror "display: 'checkbreak' not found.")))
(output *bkpt* 0)
(setq *lines* (1+ *lines*)
*bkpt* result
*bkptout* *bkptwd*
*bkptwd* w
*bkptht* *maxht*
*bkptdp* *maxdp*
*bkptlevel* *level*
*maxht* 1
*maxdp* 0))
((or (null *bkpt*)
(<= *level* *bkptlevel*)
(> (truncate *linel* 2) (- *bkptwd* *bkptout*)))
(setq *bkpt* result
*bkptwd* w
*bkptlevel* *level*
*bkptht* (max *maxht* *bkptht*)
*bkptdp* (max *maxdp* *bkptdp*)
*maxht* 1
*maxdp* 0))))
(defun forcebreak (result w)
(output result 0)
(setq *lines* (+ 2 *lines*)
*bkpt* nil
*bkptout* (+ w *break*)
*maxht* 1
*maxdp* 0))
;;; ----------------------------------------------------------------------------
(defun output (result w)
(if (not (interactive-stream-p *standard-input*))
(fresh-line))
(if (not #.ttyoff)
(output-linear (nreverse result) w)))
(defun output-linear (result w)
(declare (special *bkptdp* *bkptht* *linearray*))
(draw-linear result *bkptdp* w)
(do ((i (1- (+ *bkptht* *bkptdp*)) (1- i)))
((< i 0))
(cond ((null (aref *linearray* i)))
(t (output-linear-one-line i)))))
(defun output-linear-one-line (i)
(declare (special *linearray*))
(labels ((tyotbsp (n)
(do ()
((< n 1))
(write-char #\space)
(decf n))))
(let (line (n 0))
(setq line (aref *linearray* i)
line (nreverse (cdr line))
n (car line))
(setf (aref *linearray* i) nil)
(tyotbsp n)
(loop for v in (cdr line) do (write-char v))
(terpri))))
(defun draw-linear (dmstr *oldrow* *oldcol*)
(declare (special *linearray* *oldrow* *oldcol*))
(do ((line))
((null dmstr))
(cond ((atom (car dmstr))
(setq line (aref *linearray* *oldrow*))
(cond ((null line) (setq line (list *oldcol*)))
(t
(prog (n)
(setq n (car line)
line (cdr line))
(do ()
((<= *oldcol* n))
(push #\space line)
(incf n)))))
(do ()
((or (null dmstr) (not (atom (car dmstr))))
(setf (aref *linearray* *oldrow*) (cons *oldcol* line)))
(incf *oldcol*)
(push (car dmstr) line)
(pop dmstr)))
((integerp (caar dmstr))
(setq *oldcol* (draw-linear (reverse (cddar dmstr))
(+ *oldrow* (cadar dmstr))
(+ *oldcol* (caar dmstr))))
(pop dmstr))
(t
(setq *oldcol* (apply (caar dmstr) (cdar dmstr)))
(pop dmstr))))
*oldcol*)
;;; ----------------------------------------------------------------------------
(defun d-hbar (w &optional (char #\-) &aux nl)
(dotimes (i w)
(push char nl))
(draw-linear nl *oldrow* *oldcol*))
(defun d-vbar (h d &optional (char #\|))
(setq d (- d))
(do ((i (- h 2) (1- i))
(nl `((0 ,(1- h) ,char))))
((< i d) (draw-linear (nreverse nl) *oldrow* *oldcol*))
(push `(-1 ,i ,char) nl)))
(defun d-integralsign (&aux dmstr)
(setq dmstr `((0 2 #\/) (-1 1 #\[) (-1 0 #\I) (-1 -1 #\]) (-1 -2 #\/)))
(draw-linear dmstr *oldrow* *oldcol*))
(defun d-prodsign (&aux dmstr)
(setq dmstr '((0 2 #\\ (d-hbar 3 #\=) #\/)
(-4 0) (d-vbar 2 1 #\!) #\space (d-vbar 2 1 #\!) (1 0)))
(draw-linear dmstr *oldrow* *oldcol*))
(defun d-sumsign (&aux dmstr)
(setq dmstr '((0 2 (d-hbar 4 #\=))
(-4 1 #\\ ) #\> (-2 -1 #\/) (-1 -2 (d-hbar 4 #\=))))
(draw-linear dmstr *oldrow* *oldcol*))
(defun d-matrix (dir h d)
(d-vbar h d (car (coerce (if (eq dir 'right) $rmxchar $lmxchar) 'list))))
(defun d-box (h d w body &aux char dmstr)
(setq char (car (coerce $boxchar 'list)))
(setq dmstr `((0 ,h (d-hbar ,(+ 2 w) ,char))
(,(- (+ w 2)) 0)
(d-vbar ,h ,d ,char)
,@body
(,(- (1+ w)) ,(- (1+ d)) (d-hbar ,(+ w 2) ,char))
(-1 0)
(d-vbar ,h ,d ,char)))
(draw-linear dmstr *oldrow* *oldcol*))
;;; ----------------------------------------------------------------------------
(defun nformat-check (form)
(if (and $display_format_internal
(not (or (atom form) (atom (car form)))))
form
(nformat form)))
;;; ----------------------------------------------------------------------------
(defun dimension (form result *lop* *rop* w *right*)
(let ((*level* (1+ *level*))
(*break* (if (and w *break*) (+ w *break*))))
(when *debug-dimension*
(format t "in DIMENSION: w = ~A *level* = ~A *break* = ~A~%~%"
w *level* *break*)
(format t "maxht = ~A maxdp = ~A~%" *maxht* *maxdp*)
(format t "width = ~A right = ~A~%" *width* *right*)
(format t "height = ~A depth = ~A~%" *height* *depth*)
(format t "size = ~A lines = ~A~%~%" *size* *lines*)
(format t "bkpt = ~A bkptout = ~A~%" *bkpt* *bkptout*)
(format t "bkptwd = ~A bkptht = ~A~%" *bkptwd* *bkptht*)
(format t "bkptdp = ~A bkptlevel = ~A~%~%" *bkptdp* *bkptlevel*))
(setq form (nformat-check form))
(cond ((atom form)
(dimension-atom form result))
((and (atom (car form)) (setq form (cons '(mprogn) form)) nil))
((or (<= (lbp (caar form)) (rbp *lop*))
(> (lbp *rop*) (rbp (caar form))))
(dimension-paren form result))
((member 'array (car form) :test #'eq)
(dimension-array form result))
((getprop (caar form) 'dimension)
(funcall (getprop (caar form) 'dimension) form result))
(t
(dimension-function form result)))))
;;; ----------------------------------------------------------------------------
(defvar atom-context 'dimension-list)
(defun dimension-atom (form result)
(cond ((and (symbolp form)
(getprop form atom-context))
(funcall (getprop form atom-context) form result))
((eq form nil) (dimension-string (makestring '$false) result))
((eq form t) (dimension-string (makestring '$true) result))
((typep form 'string)
(dimension-string (makestring form) result))
(t
(dimension-string (makestring form) result))))
;;; ----------------------------------------------------------------------------
(defun dimension-string (form result &aux crp)
(declare (special *linel* *break* *bkptout* *width* *height* *depth*))
(setq *width* 0
*height* 1
*depth* 0)
(do ((l form (cdr l)))
((null l))
(incf *width*)
(if (char= (car l) #\newline) (setq crp t)))
(cond ((or (and (checkfit *width*) (not crp))
(not *break*))
(nreconc form result))
(t
(setq *width* 0)
(do ((l form)
(w (- *linel* (- *break* *bkptout*))))
((null l) (checkbreak result *width*) result)
(setq form l
l (cdr l))
(cond ((char= (car form) #\newline)
(forcebreak result *width*)
(setq result nil
w (+ *linel* *width*)))
(t
(incf *width*)
(when (and (= w *width*) l)
(forcebreak (cons #\\ result) *width*)
(setq result nil
w (+ *linel* *width*))
(incf *width*))
(setq result (rplacd form result))))))))
;;; ----------------------------------------------------------------------------
(defun dimension-paren (form result)
(setq result
(cons #\) (dimension form
(cons #\( result) 'mparen 'mparen 1 (1+ *right*))))
(incf *width* 2)
result)
;;; ----------------------------------------------------------------------------
(defun dimension-array (x result)
(prog (dummy bas (w 0) (h 0) (d 0) sub)
(if (eq (caar x) 'mqapply)
(setq dummy (cadr x) x (cdr x))
(setq dummy (caar x)))
(cond ((or (not $noundisp)
(not (symbolp (caar x)))))
((and (getprop (caar x) 'verb)
(getprop (caar x) 'alias))
(push-string "''" result)
(setq w 2))
((and (getprop (caar x) 'noun)
(not (member (caar x) (cdr $aliases) :test #'eq))
(not (getprop (caar x) 'reversealias)))
(setq result (cons #\' result)
w 1)))
(setq sub (let ((*lop* 'mparen)
(*rop* 'mparen)
(*break* nil)
(*size* 1))
(dimension-list x nil))
w (+ w *width*)
h *height*
d *depth*)
(setq bas (if (and (not (atom dummy))
(member 'array (car dummy) :test #'eq))
(let ((*break* nil) (*right* 0))
(dimension-paren dummy result))
(let ((atom-context 'dimension-array))
(dimension dummy result *lop* 'mfunction nil 0))))
(cond ((not (checkfit (setq *width* (+ w *width*))))
(return (dimension-function (cons '(subscript) (cons dummy (cdr x)))
result)))
((and (atom (car bas))
(char= #\ (car bas)))
(setq result (cons (cons 0 (cons (- h) sub)) bas)
*depth* (max (+ h d) *depth*)))
(t
(setq result (cons (cons 0 (cons (- (+ *depth* h)) sub)) bas)
*depth* (+ h d *depth*))))
(update-heights *height* *depth*)
(return result)))
;;; ----------------------------------------------------------------------------
(defun dimension-function (form result)
(prog (fun (w 0) (h 0) (d 0))
(cond ((or (not $noundisp) (not (symbolp (caar form)))))
((and (getprop (caar form) 'verb)
(getprop (caar form) 'alias))
(push-string "''" result)
(setq w 2))
((and (getprop (caar form) 'noun)
(not (member (caar form) (cdr $aliases) :test #'eq))
(not (getprop (caar form) 'reversealias)))
(setq result (cons #\' result)
w 1)))
(if (eq (caar form) 'mqapply)
(setq fun (cadr form)
form (cdr form))
(setq fun (caar form)))
(setq result (let ((atom-context 'dimension-function))
(dimension fun result *lop* 'mparen 0 1))
w (+ w *width*)
h *height*
d *depth*)
(cond ((null (cdr form))
(setq result (list* #\) #\( result)
*width* (+ 2 w)))
(t
(setq result (let ((*lop* 'mparen)
(*rop* 'mparen)
(*break* (if *break* (+ 1 w *break*))))
(cons #\) (dimension-list form (cons #\( result))))
*width* (+ 2 w *width*)
*height* (max h *height*)
*depth* (max d *depth*))))
(return result)))
;;; ----------------------------------------------------------------------------
(defun dimension-list (form result)
(prog ((w 0) (h 0) (d 0))
(setq result (dimension (cadr form) result *lop* 'mcomma 0 *right*)
w *width*
h *height*
d *depth*)
(do ((l (cddr form) (cdr l)))
((null l))
(push-string ", " result)
(incf w 2)
(checkbreak result w)
(setq result (dimension (car l) result 'mcomma 'mcomma w *right*)
w (+ w *width*)
h (max h *height*)
d (max d *depth*)))
(setq *width* w
*height* h
*depth* d)
(return result)))
;;; ----------------------------------------------------------------------------
(displa-def mquote dimension-prefix "'")
(displa-def mnot dimension-prefix "not ")
(defun dimension-prefix (form result)
(prog (dissym (symlength 0))
(setq dissym (getprop (caar form) 'dissym)
symlength (length dissym))
(setq result
(dimension (cadr form)
(revappend dissym result)
(caar form) *rop* symlength *right*)
*width* (+ symlength *width*))
(return result)))
;;; ----------------------------------------------------------------------------
(displa-def msetq dimension-infix " : ")
(displa-def mset dimension-infix " :: ")
(displa-def marrow dimension-infix " -> " 80 80)
(displa-def mgreaterp dimension-infix " > ")
(displa-def mgeqp dimension-infix " >= ")
(displa-def mequal dimension-infix " = ")
(displa-def mnotequal dimension-infix " # ")
(displa-def mleqp dimension-infix " <= ")
(displa-def mlessp dimension-infix " < ")
(defun dimension-infix (form result)
(unless (= (length (cdr form)) 2)
(return-from dimension-infix (dimension-function form result)))
(prog (dissym (symlength 0) (w 0) (h 0) (d 0))
(setq dissym (getprop (caar form) 'dissym)
symlength (length dissym)
result (dimension (cadr form) result *lop* (caar form) 0 symlength)
w *width*
h *height*
d *depth*)
(setq result (revappend dissym result))
(checkbreak result (+ symlength w))
(setq result
(dimension (caddr form)
result (caar form) *rop* (+ symlength w) *right*)
*width* (+ w symlength *width*)
*height* (max h *height*)
*depth* (max d *depth*))
(return result)))
;;; ----------------------------------------------------------------------------
(displa-def mfactorial dimension-postfix "!")
(defun dimension-postfix (form result)
(prog (dissym (symlength 0))
(setq dissym (getprop (caar form) 'dissym)
symlength (length dissym))
(setq result
(dimension (cadr form)
result *lop* (caar form) 0 (+ symlength *right*))
*width* (+ symlength *width*))
(return (revappend dissym result))))
;;; ----------------------------------------------------------------------------
(defun dimension-nofix (form result)
(setq form (getprop (caar form) 'dissym)
*width* (length form))
(revappend form result))
;;; ----------------------------------------------------------------------------
(displa-def mprogn dimension-match "(" ")")
(displa-def mlist dimension-match "[" "]")
(displa-def mangle dimension-match "<" ">")
(defun dimension-match (form result)
(prog (dissym (symlength 0))
(setq dissym (getprop (caar form) 'dissym)
symlength (length (car dissym)))
(cond ((null (cdr form))
(setq *width* (+ symlength (length (cdr dissym)))
*height* 1
*depth* 0)
(return (revappend (cdr dissym) (revappend (car dissym) result))))
(t
(setq result
(let ((*lop* 'mparen)
(*rop* 'mparen)
(*break* (if *break* (+ symlength *break*)))
(*right* (+ symlength *right*)))
(dimension-list form (revappend (car dissym) result))))
(setq *width* (+ (length (cdr dissym)) symlength *width*))
(return (revappend (cdr dissym) result))))))
;;; ----------------------------------------------------------------------------
(displa-def mplus dim-mplus)
(defprop munaryplus (#\+ #\space) dissym)
(defun dim-mplus (form result)
(cond ((and (null (cddr form))
(not (member (cadar form) '(trunc exact) :test #'eq)))
(if (null (cdr form))
(dimension-function form result)
(dimension-prefix (cons '(munaryplus) (cdr form)) result)))
(t
(setq result (dimension (cadr form) result *lop* 'mplus 0 0))
(checkbreak result *width*)
(do ((l (cddr form) (cdr l))
(w *width*)
(h *height*)
(d *depth*)
(trunc (member 'trunc (cdar form) :test #'eq))
(dissym))
((null l)
(if trunc
(setq *width* (+ 8 w)
*height* h
*depth* d)
(push-string " + . . ." result))
result)
(if (mminusp (car l))
(setq dissym '(#\space #\- #\space) form (cadar l))
(setq dissym '(#\space #\+ #\space) form (car l)))
(cond ((and (not trunc) (null (cdr l)))
(setq result
(dimension form (append dissym result)
'mplus *rop* (+ 3 w) *right*)
*width* (+ 3 w *width*)
*height* (max h *height*)
*depth* (max d *depth*))
(return result))
(t
(setq result
(dimension form (append dissym result)
'mplus 'mplus (+ 3 w) 0)
w (+ 3 w *width*)
h (max h *height*)
d (max d *depth*))
(checkbreak result w)))))))
;;; ----------------------------------------------------------------------------
(displa-def mminus dim-mminus)
(defprop munaryminus (#\- #\space) dissym)
(def-rbp munaryminus 134)
(def-rbp munaryminus 100)
(defun dim-mminus (form result)
(cond ((and (null (cddr form))
(not (member (cadar form) '(trunc exact) :test #'eq)))
(if (null (cdr form))
(dimension-function form result)
(dimension-prefix (cons '(munaryminus) (cdr form)) result)))
(t
(setq result (dimension (cadr form) result *lop* 'mplus 0 0))
(checkbreak result *width*)
(do ((l (cddr form) (cdr l))
(w *width*)
(h *height*)
(d *depth*)
(trunc (member 'trunc (cdar form) :test #'eq))
(dissym))
((null l)
(if trunc
(setq *width* (+ 8 w)
*height* h
*depth* d)
(push-string " - . . ." result))
result)
(if (mminusp (car l))
(setq dissym '(#\space #\+ #\space) form (cadar l))
(setq dissym '(#\space #\- #\space) form (car l)))
(cond ((and (not trunc) (null (cdr l)))
(setq result
(dimension form (append dissym result)
'mplus *rop* (+ 3 w) *right*)
*width* (+ 3 w *width*)
*height* (max h *height*)
*depth* (max d *depth*))
(return result))
(t
(setq result
(dimension form (append dissym result)
'mplus 'mplus (+ 3 w) 0)
w (+ 3 w *width*)
h (max h *height*)
d (max d *depth*))
(checkbreak result w)))))))
;;; ----------------------------------------------------------------------------
(displa-def rat dim-rat "/")
(defun dim-rat (form result)
(if $ratdispflag
(dimension-nary form result)
(dim-mquotient form result)))
;;; ----------------------------------------------------------------------------
(displa-def mquotient dim-mquotient "/")
(defun dim-mquotient (form result)
(unless (= (length (cdr form)) 2)
(return-from dim-mquotient (dimension-function form result)))
(prog (num (w 0) (h 0) (d 0) den)
(when (and (= 1 *size*) (atom (cadr form)) (atom (caddr form)))
(return (dimension-nary form result)))
(setq num (dimension (cadr form) nil 'mparen 'mparen nil *right*)
w *width*
h *height*
d *depth*)
(unless (checkfit w)
(return (dimension-nary form result)))
(setq den (dimension (caddr form) nil 'mparen 'mparen nil *right*))
(unless (checkfit *width*)
(return (dimension-nary form result)))
(return (dratio result num w h d den *width* *height* *depth*))))
(defvar x1)
(defvar x2)
(eval-when (:compile-toplevel :load-toplevel :execute)
(setq x1 'h1 x2 'd2))
(defun dratio (result num w1 h1 d1 den w2 h2 d2)
(setq *width* (max w1 w2)
*height* (+ 1 h1 d1)
*depth* (+ h2 d2))
(setq #.x1 (truncate (- *width* w1) 2)
#.x2 (truncate (- *width* w2) 2))
(update-heights *height* *depth*)
(push `(,#.x1 ,(1+ d1) . ,num) result)
(push `(,(- #.x2 (+ #.x1 w1)) ,(- h2) . ,den) result)
(push `(,(- 0 #.x2 w2) 0) result)
(push `(d-hbar ,*width*) result)
result)
(defun update-heights (ht* dp*)
(if *break*
(setq *maxht* (max *maxht* ht*)
*maxdp* (max *maxdp* dp*))))
;;; ----------------------------------------------------------------------------
(displa-def mtimes dimension-nary " ")
(displa-def mnctimes dimension-nary " . ")
(displa-def mnctimes dimension-nary " . ")
(displa-def mcomma dimension-nary ", " 10 10)
(defun dimension-nary (form result)
(cond ((null (cddr form))
(dimension-function form result))
(t
(prog (dissym (symlength 0) (w 0) (h 0) (d 0) helper)
(setq dissym (getprop (caar form) 'dissym)
symlength (length dissym)
helper (or (getprop (caar form) 'dimension-nary-helper)
'dimnary)
result (funcall helper
(cadr form)
result *lop* (caar form) (caar form) 0)
w *width*
h *height*
d *depth*)
(do ((l (cddr form) (cdr l)))
(nil)
(checkbreak result w)
(setq result (revappend dissym result)
w (+ symlength w))
(cond ((null (cdr l))
(setq result
(funcall helper
(car l)
result (caar form) (caar form) *rop* w)
*width* (+ w *width*)
*height* (max h *height*)
*depth* (max d *depth*))
(return t))
(t
(setq result
(funcall helper
(car l)
result (caar form) (caar form) (caar form) w)
w (+ w *width*)
h (max h *height*)
d (max d *depth*)))))
(return result)))))
(defun dimnary (form result *lop* op *rop* w)
(declare (ignore op))
(if (and (consp form)
(member (getprop (caar form) 'dimension)
'(dimension-infix dimension-nary dim-mplus)))
(progn
(setq result
(cons #\)
(dimension form
(cons #\( result)
'mparen 'mparen (1+ w) (1+ *right*))))
(incf *width* 2)
result)
(progn
(dimension form result *lop* *rop* w *right*))))
;;; ----------------------------------------------------------------------------
(displa-def mlabel dim-mlabel 0 0)
(defun dim-mlabel (form result)
(prog (dummy (w 0) (h 0) (d 0))
(cond ((eq nil (cadr form))
(setq w 0 h 0 d 0))
(*mratp*
(setq result
(append *mratp*
(if *display-labels-p*
(dimension-paren (cadr form) result)))
w (+ 4 *width*)
h *height*
d *depth*))
(t
(setq result
(cons #\space
(if *display-labels-p*
(dimension-paren (cadr form) result)))
w (1+ *width*)
h *height*
d *depth*)))
(let ((*level* *linel*)) (checkbreak result w))
(setq dummy (list 0 0))
(setq result
(dimension (caddr form) (cons dummy result) 'mlabel *rop* w *right*))
(cond ((and (not $leftjust) (= 0 *bkptout*))
(rplaca dummy (max 0 (- (truncate (- *linel* *width*) 2) w)))
(setq *width* (+ (car dummy) *width*))))
(setq *width* (+ w *width*)
*height* (max h *height*)
*depth* (max d *depth*))
(return result)))
;;; ----------------------------------------------------------------------------
(displa-def mand dimension-nary " and ")
(defprop mand dimnary-boolean dimension-nary-helper)
(displa-def mor dimension-nary " or ")
(defprop mor dimnary-boolean dimension-nary-helper)
(defun dimnary-boolean (form result *lop* op *rop* w)
(declare (ignore op))
(if (and (consp form)
(or (member (getprop (caar form) 'dimension)
'(dimension-infix dimension-nary))
(eq (caar form) 'mnot)))
(dimension-paren form result)
(dimension form result *lop* *rop* w *right*)))
;;; ----------------------------------------------------------------------------
(displa-def mexpt dimension-superscript)
(defun dimension-superscript (form result)
(prog (exp (w 0) (h 0) (d 0) bas)
(setq exp (let ((*size* 1))
(dimension (caddr form) nil 'mparen 'mparen nil 0))
w *width*
h *height*
d *depth*)
(cond ((and (not (atom (cadr form)))
(member 'array (cdaadr form) :test #'eq))
(prog (sub (w2 0) (h2 0) (d2 0))
(setq sub (if (eq 'mqapply (caaadr form))
(cdadr form) (cadr form)))
(setq sub (let ((*lop* 'mparen) (*break* nil) (*size* 1))
(dimension-list sub nil))
w2 *width*
h2 *height*
d2 *depth*)
(setq bas (dimension (mop (cadr form)) result *lop* 'mexpt nil 0))
(when (not (checkfit (+ *width* (max w w2))))
(setq result
(dimension-function (cons '($expt) (cdr form)) result))
(return result))
(setq result (cons (cons 0 (cons (+ *height* d) exp)) bas))
(setq result
(cons (cons (- w) (cons (- (+ *depth* h2)) sub)) result))
(setq result (cons (list (- (max w w2) w2) 0) result)
*width* (+ *width* (max w w2))
*height* (+ h d *height*)
*depth* (+ d2 h2 *depth*)))
(update-heights *height* *depth*)
(return result))
((and (atom (caddr form))
(not (atom (cadr form)))
(not (getprop (caaadr form) 'dimension))
(prog2
(setq bas (nformat-check (cadr form)))
(not (getprop (caar bas) 'dimension))))
(return (dimension-function
(list* '(mqapply)
(list '(mexpt) (mop bas) (caddr form))
(margs bas))
result)))
(t
(setq bas (dimension (cadr form) result *lop* 'mexpt nil 0)
*width* (+ w *width*))
(if (not (checkfit *width*))
(return (dimension-function (cons '($expt) (cdr form)) result)))
(if (eql #\) (car bas))
(setq result (cons (list* 0 (1+ d) exp) bas)
*height* (max (+ 1 h d) *height*))
(setq result (cons (list* 0 (+ *height* d) exp) bas)
*height* (+ h d *height*)))
(update-heights *height* *depth*)
(return result)))))
;;; ----------------------------------------------------------------------------
(displa-def mncexpt dim-mncexpt "^^")
(defun dim-mncexpt (form result)
(dimension-superscript (list '(mncexpt)
(cadr form)
(cons '(mangle) (cddr form)))
result))
;;; ----------------------------------------------------------------------------
(displa-def bigfloat dim-bigfloat)
;;; ----------------------------------------------------------------------------
(displa-def mdefine dim-mdefine " := ")
(displa-def mdefmacro dim-mdefine " ::= ")
(defun dim-mdefine (form result)
(let (($noundisp t)
($stringdispflag t))
(dimension-infix (if (cdddr form)
(list (car form)
(cadr form)
(cons '(mprogn) (cddr form)))
form)
result)))
;;; ----------------------------------------------------------------------------
(displa-def %integrate dim-%integrate 115)
(defun dim-%integrate (form result)
(prog (dummy (w 0)(h 0)(d 0) dummy2)
(cond ((not (or (= (length (cdr form)) 2) (= (length (cdr form)) 4)))
(return-from dim-%integrate (dimension-function form result)))
((null (cdddr form))
(setq dummy `(#\space (d-integralsign) . ,result) w 2 h 3 d 2))
(t
(setq dummy (dimension (cadr (cdddr form)) nil 'mparen 'mparen nil 0)
w *width* h *height* d *depth*)
(setq dummy2 (dimension (cadddr form) nil 'mparen 'mparen nil 0))
(if (not (checkfit (+ 2 (max w *width*))))
(return (dimension-function form result)))
(setq dummy `((0 ,(+ 3 d) . ,dummy)
(d-integralsign) . ,result))
(setq dummy (cons (cons (- w) (cons (- (+ 2 *height*)) dummy2))
dummy)
w (+ 2 (max w *width*)) h (+ 3 h d) d (+ 2 *height* *depth*)
dummy (cons (list (- w 1 *width*) 0) dummy))))
(update-heights h d)
(setq dummy (dimension (cadr form) dummy '%integrate 'mparen w 2)
w (+ w *width*) h (max h *height*) d (max d *depth*))
(push-string " d" dummy)
(setq dummy (dimension (caddr form) dummy 'mparen *rop* (+ 2 w) *right*)
*width* (+ 2 w *width*)
*height* (max h *height*)
*depth* (max d *depth*))
(return dummy)))
;;; ----------------------------------------------------------------------------
(displa-def %derivative dim-%derivative 125)
(defun dim-%derivative (form result)
(prog ()
(cond ((null (cddr form))
(return (dimension-function (cons '(%diff) (cdr form)) result))))
(cond ((null (cdddr form)) (setq form (append form '(1)))))
(cond ((and $derivabbrev
(do ((l (cddr form) (cddr l))) ((null l) t)
(cond ((and (atom (car l))
(integerp (cadr l)) (> (cadr l) 0)))
(t (return nil)))))
(return (dmderivabbrev form result)))
((or (> (rbp *lop*) 130) (> (lbp *rop*) 130)
(and (not (atom (cadr form)))
(or (> (rbp *lop*) 110) (> (lbp *rop*) 110))))
(return (dimension-paren form result)))
(t
(return (dmderivlong form result))))))
(defun dmderivabbrev (form result)
(prog (dummy (w 0))
(do ((l (cddr form) (cddr l)) (var))
((null l) (setq dummy (cdr dummy) w (1- w)))
(setq var (dimension (car l) nil 'mparen 'mparen nil 0))
(do ((i (cadr l) (1- i)))
((= 1 i))
(setq dummy (cons #\space (append var dummy))))
(setq dummy (cons #\space (nconc var dummy))
w (+ w (cadr l) (* (cadr l) *width*))))
(setq result (dimension (cadr form) result *lop* '%deriv 0 *right*))
(setq result (cons (cons 0 (cons (- 0 *depth* 1) dummy)) result)
*width* (+ w *width*) *depth* (max 1 (1+ *depth*)))
(update-heights *height* *depth*)
(return result)))
(defun dmderivlong (form result)
(prog (num (w1 0) (h1 0) (d1 0) den (w2 0)( h2 0) (d2 0))
(setq num (list (cadddr form))
den (cond ((equal 1 (cadddr form))
(dimension (caddr form)
(list #\d) 'mparen 'mparen nil 0))
(t
(dimension-superscript
(cons '(diff)(cddr form)) (list #\d))))
w2 (1+ *width*) h2 *height* d2 *depth*)
(do ((l (cddddr form) (cddr l))) ((null l))
(setq num (cons (cadr l) num)
den (cond ((equal 1 (cadr l))
(dimension (car l) (cons #\d (cons #\space den))
'mparen 'mparen nil 0))
(t
(dimension-superscript
(cons '(diff) l) (cons #\d (cons #\space den)))))
w2 (+ 2 w2 *width*)
h2 (max h2 *height*)
d2 (+ d2 *depth*)))
(setq num (nformat-check (addn num t)))
(cond ((equal 1 num)
(setq num (list #\d)
w1 1
h1 1
d1 0))
(t
(setq num (dimension-superscript (list '(diff) #\d num) nil)
w1 *width*
h1 *height*
d1 *depth*)))
(cond ((atom (setq form (nformat-check (cadr form))))
(setq num (dimension form num '%deriv 'mparen nil 0)
w1 (+ w1 *width*))
(return (dratio result num w1 h1 d1 den w2 h2 d2)))
(t
(setq result (dratio result num w1 h1 d1 den w2 h2 d2)
w1 *width*
h1 *height*
d1 *depth*)
(setq result
(dimension form (cons #\space result) '%deriv *rop* w1 *right*)
*width* (+ 1 w1 *width*)
*height* (max h1 *height*)
*depth* (max d1 *depth*))
(update-heights *height* *depth*)
(return result)))))
;;; ----------------------------------------------------------------------------
(displa-def %at dim-%at 105. 105.)
(defun dim-%at (form result)
(prog (exp eqs (w 0) (h 0) (d 0))
(unless (= (length (cdr form)) 2)
(return-from dim-%at (dimension-function form result)))
(setq exp (dimension (cadr form) result *lop* '%at nil 0)
w *width*
h *height*
d *depth*)
(setq eqs (dimension (cond ((not (eq 'mlist (caar (caddr form))))
(caddr form))
((null (cddr (caddr form)))
(cadr (caddr form)))
(t (cons '(mcomma) (cdaddr form))))
nil 'mparen 'mparen nil 0))
(unless (checkfit (+ 1 w *width*))
(return (dimension-function form result)))
(setq result (cons (cons 0 (cons (- 0 1 d) eqs))
(cons `(d-vbar ,(1+ h)
,(1+ d)
,(car (coerce $absboxchar 'list)))
exp))
*width* (+ 1 w *width*)
*height* (1+ h)
*depth* (+ 1 d *depth*))
(update-heights *height* *depth*)
(return result)))
;;; ----------------------------------------------------------------------------
(displa-def %sum dim-%sum 110)
(displa-def %lsum dim-%lsum 110)
(defun dim-%lsum (form result)
(dsumprod form result '(d-sumsign) 4 3 2))
(defun dim-%sum (form result)
(dsumprod form result '(d-sumsign) 4 3 2))
(displa-def %product dim-%product 115)
(defun dim-%product (form result)
(dsumprod form result '(d-prodsign) 5 3 1))
(defun dsumprod (form result d-form sw sh sd)
(prog (dummy (w 0) (h 0) (d 0) dummy2 (lsum (eq (caar form) '%lsum)))
(setq dummy2 (dimension (caddr form) nil 'mparen 'mequal nil 0)
w *width*
h *height*
d *depth*)
(if lsum
(push-string " in " dummy2)
(push-string " = " dummy2))
(setq dummy2 (dimension (cadddr form) dummy2 'mequal 'mparen nil 0)
w (+ 3 w *width*)
h (max h *height*)
d (max d *depth*))
(or lsum
(setq dummy (dimension (cadr (cdddr form)) nil 'mparen 'mparen nil 0)))
(unless (checkfit (max w *width*))
(return (dimension-function form result)))
(setq dummy2
(cons (cons (- sw) (cons (- (+ sd h)) dummy2)) (cons d-form result)))
(cond ((> *width* sw)
(setq sw 0))
(t
(setq sw (truncate (- sw *width*) 2)
*width* (+ sw *width*))))
(setq dummy (cons (cons (- sw w) (cons (+ sh *depth*) dummy)) dummy2)
w (max w *width*)
d (+ sd h d)
h (+ sh *height* *depth*))
(update-heights h d)
(setq dummy (dimension (cadr form)
(cons (list (1+ (- w *width*)) 0) dummy)
(caar form) *rop* w *right*)
*width* (+ 1 w *width*)
*height* (max h *height*)
*depth* (max d *depth*))
(return dummy)))
;;; ----------------------------------------------------------------------------
(displa-def %limit dim-%limit 110 110)
(defun dim-%limit (form result)
(prog ((w 0) (h 0) (d 0) dummy)
(unless (or (= (length (cdr form)) 3) (= (length (cdr form)) 4))
(return-from dim-%limit (dimension-function form result)))
(setq dummy (dimension (third form) nil 'mparen 'mparen nil 0)
w *width* h *height* d *depth*)
(push-string " -> " dummy)
(setq dummy (dimension (fourth form) dummy 'mparen 'mparen nil 0)
w (+ 4 w *width*)
h (max h *height*)
d (max d *depth*))
(cond ((null (cddddr form)))
((eq '$plus (fifth form))
(push #\+ dummy)
(incf w))
(t
(push #\- dummy)
(incf w)))
(push-string "limit" result)
(setq dummy (cons (list* -5 (- h) dummy) result)
d (+ h d))
(update-heights 1 d)
(setq dummy
(dimension (cadr form)
(cons '(1 0) dummy) '%limit *rop* (1+ w) *right*))
(setq *width* (+ 1 w *width*)
*depth* (max d *depth*))
(return dummy)))
;;; ----------------------------------------------------------------------------
(displa-def mcond dim-mcond)
(displa-def %mcond dim-mcond)
(defun dim-mcond (form result)
(prog ((w 0) (h 0) (d 0))
(push-string "if " result)
(setq result (dimension (cadr form) result 'mcond 'mparen 3 0)
w (+ 3 *width*)
h *height*
d *depth*)
(checkbreak result w)
(push-string " then " result)
(setq result (dimension (caddr form) result 'mcond 'mparen (+ 6 w) 0)
w (+ 6 w *width*)
h (max h *height*)
d (max d *depth*))
(let ((args (cdddr form)))
(loop while (>= (length args) 2) do
(let ((maybe-elseif (car args)) (else-or-then (cadr args)))
(cond
((and (eq maybe-elseif t) (= (length args) 2))
(unless (or (eq '$false else-or-then) (eq nil else-or-then))
(checkbreak result w)
(push-string " else " result)
(setq result
(dimension else-or-then result
'mcond *rop* (+ 6 w) *right*)
w (+ 6 w *width*)
h (max h *height*)
d (max d *depth*))))
(t
(checkbreak result w)
(push-string " elseif " result)
(setq result
(dimension maybe-elseif result
'mcond *rop* (+ 8 w) *right*)
w (+ 8 w *width*)
h (max h *height*)
d (max d *depth*))
(checkbreak result w)
(push-string " then " result)
(setq result
(dimension else-or-then result
'mcond *rop* (+ 6 w) *right*)
w (+ 6 w *width*)
h (max h *height*)
d (max d *depth*)))))
(setq args (cddr args))))
(setq *width* w
*height* h
*depth* d)
(return result)))
;;; ----------------------------------------------------------------------------
(displa-def mdo dim-mdo)
(displa-def %mdo dim-mdo)
(defun dim-mdo (form result)
(prog ((w 0) (h 0) (d 0) brkflag)
(cond ((not (null (cadr form)))
(push-string "for " result)
(setq result
(cons #\space
(dimension (cadr form) result 'mdo 'mparen 4 *right*))
w (+ 4 *width*) h *height* d *depth*
brkflag t)))
(cond ((or (null (caddr form))
(equal 1 (caddr form))))
(t
(push-string "from " result)
(setq result
(cons #\space
(dimension (caddr form) result 'mdo 'mparen (+ 6 w) 0))
w (+ 6 w *width*) h (max h *height*) d (max d *depth*))))
(setq form (cdddr form))
(cond ((equal 1 (car form)))
((not (null (car form)))
(push-string "step " result)
(setq result
(cons #\space
(dimension (car form) result 'mdo 'mparen (+ 6 w) 0))
w (+ 6 w *width*) h (max h *height*) d (max d *depth*)))
((not (null (cadr form)))
(push-string "next " result)
(setq result
(cons #\space
(dimension (cadr form) result 'mdo 'mparen (+ 6 w) 0))
w (+ 6 w *width*) h (max h *height*) d (max d *depth*))))
(cond ((not (null (caddr form)))
(push-string "thru " result)
(setq result
(cons #\space
(dimension (caddr form) result 'mdo 'mparen (+ 6 w) 0))
w (+ 6 w *width*) h (max h *height*) d (max d *depth*)
brkflag t)))
(cond ((not (null (cadddr form)))
(cond ((and (not (atom (cadddr form)))
(eq (caar (cadddr form)) 'mnot))
(push-string "while " result)
(setq result
(cons #\space
(dimension (cadr (cadddr form))
result 'mdo 'mparen (+ 7 w) 0))
w (+ 7 w *width*) h (max h *height*) d (max d *depth*)))
(t
(push-string "unless " result)
(setq result
(cons #\space
(dimension (cadddr form)
result 'mdo 'mparen (+ 8 w) 0))
w (+ 8 w *width*) h (max h *height*)
d (max d *depth*))))))
(if brkflag (checkbreak result w))
(push-string "do " result)
(setq result
(dimension (car (cddddr form)) result 'mdo *rop* (+ 4 w) *right*)
*width* (+ 4 w *width*)
*height* (max h *height*)
*depth* (max d *depth*))
(return result)))
;;; ----------------------------------------------------------------------------
(displa-def mdoin dim-mdoin)
(displa-def %mdoin dim-mdoin)
(defun dim-mdoin (form result)
(prog ((w 0) (h 0) (d 0))
(push-string "for " result)
(setq result (dimension (cadr form) result 'mdo 'mparen 4 0)
w (+ 4 *width*)
h *height*
d *depth*)
(push-string " in " result)
(setq result (dimension (caddr form) result 'mdo 'mparen (+ 4 w) 0)
w (+ 4 w *width*)
h (max h *height*)
d (max d *depth*))
(setq form (cdr (cddddr form)))
(cond ((not (null (car form)))
(push-string " thru " result)
(setq result (dimension (car form) result 'mdo 'mparen (+ 6 w) 0)
w (+ 6 w *width*)
h (max h *height*)
d (max d *depth*))))
(cond ((not (null (cadr form)))
(push-string " unless " result)
(setq result (dimension (cadr form) result 'mdo 'mparen (+ 8 w) 0)
w (+ 8 w *width*)
h (max h *height*)
d (max d *depth*))))
(push-string " do " result)
(setq result (dimension (caddr form) result 'mdo *rop* (+ 4 w) *right*)
*width* (+ 4 w *width*)
*height* (max h *height*)
*depth* (max d *depth*))
(return result)))
;;; ----------------------------------------------------------------------------
(displa-def mabs dim-mabs)
(defun dim-mabs (form result &aux arg bar)
(setq arg (dimension (cadr form) nil 'mparen 'mparen nil 0))
(cond ((or (> (+ 2 *width*) *linel*)
(and (= 1 *height*) (= 0 *depth*)))
(dimension-function form result))
(t
(setq *width* (+ 2 *width*))
(update-heights *height* *depth*)
(setq bar `(d-vbar ,*height*
,*depth* ,(car (coerce $absboxchar 'list))))
(cons bar (nconc arg (cons bar result))))))
;;; ----------------------------------------------------------------------------
(displa-def $matrix dim-$matrix)
(defun dim-$matrix (form result)
(prog (dmstr rstr cstr consp cols)
(setq cols (if (mlistp (cadr form)) (length (cadr form)) 0))
(if (or (null (cdr form))
(memalike '((mlist simp)) (cdr form))
;; Check if the matrix has lists as rows with a equal number of
;; columns.
(dolist (row (cdr form))
(if (or (not (mlistp row))
(not (eql cols (length row))))
(return t))))
;; The matrix is not well formed. Display the matrix in linear mode.
(return (dimension-function form result)))
(do ((l (cdadr form) (cdr l)))
((null l))
(setq dmstr (cons nil dmstr) cstr (cons 0 cstr)))
(do ((r (cdr form) (cdr r)) (h1 0) (d1 0))
((or consp (null r))
(setq *width* 0)
(do ((cs cstr (cdr cs)))
((null cs))
(setq *width* (+ 2 (car cs) *width*)))
(setq h1 (1- (+ h1 d1))
*depth* (truncate h1 2)
*height* (- h1 *depth*)))
(do ((c (cdar r) (cdr c))
(nc dmstr (cdr nc))
(cs cstr (cdr cs)) (dummy) (h2 0) (d2 0))
((null c) (setq d1 (+ d1 h1 h2) h1 (1+ d2)))
(setq dummy (dimension (car c) nil 'mparen 'mparen nil 0)
h2 (max h2 *height*)
d2 (max d2 *depth*))
(cond ((not (checkfit (+ 14 *width*))) (setq consp t) (return nil))
(t (rplaca nc (cons (list* *width* *height* *depth* dummy)
(car nc)))
(rplaca cs (max *width* (car cs))))))
(setq rstr (cons d1 rstr)))
(if (> (+ *height* *depth*) (length *linearray*))
(setq consp t))
(return
(cond ((and (not consp) (checkfit (+ 2 *width*)))
(matout dmstr cstr rstr result))
((and (not consp) (<= *level* 2)) (colout dmstr cstr result))
(t (dimension-function form result))))))
(defun matout (dmstr cstr rstr result)
(push `(d-matrix left ,*height* ,*depth*) result)
(push #\space result)
(do ((d dmstr (cdr d)) (c cstr (cdr c)) (w 0 0))
((null d))
(do ((d (car d) (cdr d)) (r rstr (cdr r))) ((null d))
(rplaca (cddar d) (- *height* (car r)))
(rplaca (cdar d) (- (truncate (- (car c) (caar d)) 2) w))
(setq w (truncate (+ (car c) (caar d)) 2))
(rplaca d (cdar d)))
(setq result (cons (list (+ 2 (- (car c) w)) 0) (nreconc (car d) result))))
(setq *width* (+ 2 *width*))
(update-heights *height* *depth*)
(rplaca (car result) (1- (caar result)))
(push `(d-matrix right ,*height* ,*depth*) result)
result)
(defun colout (dmstr cstr result)
(setq *width* 0
*height* 1
*depth* 0)
(do ((r dmstr (cdr r))
(c cstr (cdr c))
(col 1 (1+ col))
(w 0 0) (h -1 -1) (d 0))
((null r))
(push-string " Col " result)
(setq result (nreconc (exploden col) result))
(push-string " = " result)
(setq *width* (+ 8 (length (exploden col)) *width*))
(do ((r (car r) (cdr r))) ((null r))
(setq h (+ 1 h (cadar r) (caddar r)))
(rplaca (cddar r) (- h (cadar r)))
(rplaca (cdar r) (- (truncate (- (car c) (caar r)) 2) w))
(setq w (truncate (+ (car c) (caar r)) 2))
(rplaca r (cdar r)))
(setq d (truncate h 2) h (- h d))
(push `(d-matrix left ,h ,d) result)
(push #\space result)
(push `(0 ,(- d) . ,(nreverse (car r))) result)
(push `(,(1+ (- (car c) w)) 0) result)
(push `(d-matrix *right* ,h ,d) result)
(setq *width* (+ 4 (car c) *width*)
*height* (max h *height*)
*depth* (max d *depth*))
(update-heights h d)
(checkbreak result *width*))
result)
;;; ----------------------------------------------------------------------------
(displa-def mbox dim-mbox)
(defun dim-mbox (form result &aux dummy)
(setq dummy (dimension (cadr form) nil 'mparen 'mparen nil 0))
(cond ((not (checkfit (+ 2 *width*)))
(dimension-function (cons '($box) (cdr form)) result))
(t
(push `(d-box ,*height* ,*depth* ,*width* ,(nreverse dummy)) result)
(setq *width* (+ 2 *width*)
*height* (1+ *height*)
*depth* (1+ *depth*))
(update-heights *height* *depth*)
result)))
;;; ----------------------------------------------------------------------------
(displa-def mlabox dim-mlabox)
(defun dim-mlabox (form result)
(prog (dummy ch)
(setq dummy (dimension (cadr form) nil 'mparen 'mparen nil 0))
(cond ((not (checkfit (+ 2 *width*)))
(return (dimension-function (cons '($box) (cdr form)) result))))
(setq *width* (+ 2 *width*)
*height* (1+ *height*)
*depth* (1+ *depth*))
(setq ch (car (coerce $boxchar 'list)))
(setq result
(cons (do ((l (mapcar #'(lambda (l) (char (symbol-name l) 0))
(makestring (caddr form))) (cdr l))
(w 0) (nl))
((or (null l) (= *width* w))
(cons 0
(cons (1- *height*)
(cond ((< w *width*)
(cons `(d-hbar ,(- *width* w) ,ch) nl))
(t nl)))))
(setq nl (cons (car l) nl)
w (1+ w)))
result))
(setq result
(nconc dummy
(list* `(d-vbar ,(1- *height*) ,(1- *depth*) ,ch)
(list (- *width*) 0) result)))
(setq result
(cons (list (- 1 *width*) (- *depth*) `(d-hbar ,*width* ,ch))
result))
(setq result
(list* `(d-vbar ,(1- *height*) ,(1- *depth*) ,ch) '(-1 0) result))
(update-heights *height* *depth*)
(return result)))
;;; ----------------------------------------------------------------------------
(displa-def mtext dim-mtext 1 1)
(defprop mtext dimnary-mtext dimension-nary-helper)
(defun dim-mtext (form result)
(if (null (cddr form))
(dimension (cadr form) result *lop* *rop* 0 0)
(dimension-nary form result)))
(defun dimnary-mtext (form result *lop* op *rop* w)
(declare (ignore op))
(dimension form result *lop* *rop* w *right*))
;;; ----------------------------------------------------------------------------
B.10 msystem.lisp
;;; ----------------------------------------------------------------------------
;;; msystem.lisp
;;;
;;; Copyright (C) 2011 Dr. Dieter Kaiser
;;;
;;; This file contains modified code from:
;;;
;;; Copyright (C) 1984, 1987 William Schelter, University of Texas
;;; Copyright (C) 1981, 1982 Massachusetts Institute of Technology
;;;
;;; This program is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2 of the License, or
;;; (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
;;; ----------------------------------------------------------------------------
(in-package :kmaxima)
;;; ----------------------------------------------------------------------------
(defvar *maxima-version* 0.1)
(defun maxima-banner ()
(format t "~&kMaxima ~a~%" *maxima-version*)
(format t "using Lisp ~a ~a~%" (lisp-implementation-type)
(lisp-implementation-version))
(format t "Distributed under the GNU Public License. ~
See the file COPYING.~%")
(format t "Dedicated to the memory of William Schelter.~%"))
;;; ----------------------------------------------------------------------------
(defun bye ()
#+(or cmu scl clisp) (ext:quit)
#+sbcl (sb-ext:quit)
#+allegro (excl:exit)
#+(or mcl openmcl) (ccl:quit)
#+gcl (lisp:quit)
#+ecl (si:quit)
#+lispworks (lispworks:quit))
(defun $quit ()
(throw 'maxima-quit-to-lisp 0))
(defun used-area (&optional unused)
(declare (ignore unused))
(sb-ext:get-bytes-consed))
;;; ----------------------------------------------------------------------------
(defvar *prompt-prefix* "")
(defvar *prompt-suffix* "")
(defmvar $prompt "_")
(defun main-prompt ()
(declare (special *display-labels-p* $inchar $linenum))
(if *display-labels-p*
(let ((*print-circle* nil))
(format nil "~A(~A~D) ~A"
*prompt-prefix*
(print-invert-case (stripdollar $inchar))
$linenum
*prompt-suffix*))
""))
(defun break-prompt ()
(let ((*print-circle* nil))
(format nil "~A~A~A"
*prompt-prefix*
(print-invert-case (stripdollar $prompt))
*prompt-suffix*)))
;;; ----------------------------------------------------------------------------
(defvar *linelabel* nil)
(defmvar $linenum 0)
(defmvar $inchar '$%i)
(defmvar $outchar '$%o)
(defmvar $linechar '$%t)
(defmvar $nolabels nil)
(defmvar $labels (list '(mlist simp)))
(defun createlabel (x num)
(intern (format nil "~a~d" x num)))
(defun checklabel (x)
(not (or $nolabels
(= $linenum 0)
(boundp (createlabel x $linenum)))))
(defun makelabel (x)
(declare (special *linelabel*))
(setq *linelabel* (createlabel x $linenum))
(unless $nolabels
(when (or (null (cdr $labels))
(when (member *linelabel* (cddr $labels) :test #'equal)
(setf $labels
(delete *linelabel* $labels :count 1 :test #'eq))
t)
(not (eq *linelabel* (cadr $labels))))
(setq $labels (cons (car $labels) (cons *linelabel* (cdr $labels))))))
*linelabel*)
(defun getfirstcharlabel (x)
(let ((c (char (symbol-name x) 1)))
(if (char= c #\%)
(char (symbol-name x) 2)
c)))
(defun getlabels (x)
(do ((l (cdr $labels) (cdr l))
(ch (getfirstcharlabel x))
(acc))
((null l) (reverse acc))
(if (char= (getfirstcharlabel (car l)) ch)
(push (car l) acc))))
(defun getlabels2 (n1 n2 &optional (flag nil))
(do ((i n1 (1+ i))
(acc)
(l (if flag
(list $inchar)
(list $inchar $outchar $linechar))))
((> i n2) (reverse acc))
(do ((l l (cdr l))
(z))
((null l))
(if (boundp (setq z (createlabel (first l) i)))
(push z acc)))))
(defun $labels (x)
(cons '(mlist simp) (getlabels x)))
(defun $%th (x)
(prog (l outchar)
(if (or (not (fixnump x)) (= x 0))
(merror "Improper argument to ~:M:~%~M" '$%th x))
(if (> x 0) (setq x (- x)))
(if (cdr $labels)
(setq l (cddr $labels)
outchar (getfirstcharlabel $outchar)))
loop
(if (null l) (merror "Improper call to %th"))
(if (and (char= (getfirstcharlabel (car l)) outchar)
(= (setq x (1+ x)) 0))
(return (meval (car l))))
(setq l (cdr l))
(go loop)))
;;; ----------------------------------------------------------------------------
(defun maxima-toplevel-eval (form)
(simplifya (meval form) nil))
(defun meval (form)
(simplifya (meval1 form) nil))
(defun meval1 (form &aux u)
(cond
((atom form)
(cond ((not (symbolp form))
form)
((not (boundp form))
form)
(t (symbol-value form))))
((consp (car form))
(let ((op (caar form)))
(cond ((mfunctionp op)
(apply op (mevalargs (cdr form))))
((setq u (getprop op 'mspec))
(apply u (cons form nil)))
((macro-function op)
(eval (cons op (cdr form))))
(t
(cons (car form) (mevalargs (cdr form)))))))
(t (eval form))))
(defun mevalargs (args)
(mapcar #'meval args))
;;; ----------------------------------------------------------------------------
(defvar *need-prompt* t)
(defun maxima-toplevel-read (stream eof-p eof)
(let ((mprompt *mread-prompt*)
(*mread-prompt* "")
ch)
(if (and *need-prompt* (> (length mprompt) 0))
(progn
(fresh-line *standard-output*)
(princ mprompt *standard-output*)
(force-output *standard-output*)
(setf *prompt-on-read-hang* nil))
(progn
(setf *prompt-on-read-hang* t)
(setf *read-hang-prompt* mprompt)))
(tagbody
top
(setq ch (read-char stream eof-p eof))
(cond ((or (eql ch #\newline)
(eql ch #\return))
(go top))
((eq ch eof)
(return-from maxima-toplevel-read eof)))
(unread-char ch stream))
(cond
((eql #\? ch)
(read-char stream)
(let ((next (peek-char nil stream nil)))
(cond
((member next '(#\space #\tab #\!))
(let ((line (string-trim '(#\space #\tab #\; #\$ )
(subseq (read-line stream eof-p eof)
1))))
`((displayinput) nil (($describe) ,line $exact))))
((equal next #\?)
(let ((line (string-trim '(#\space #\tab #\; #\$ )
(subseq (read-line stream eof-p eof)
1))))
`((displayinput) nil (($describe) ,line $inexact))))
(t
(mread (make-concatenated-stream (make-string-input-stream "?")
stream)
eof)))))
(t
(let ((result (mread stream eof))
(next-char (read-char-no-hang stream eof-p eof)))
(cond ((or (eql next-char nil)
(equal next-char '(nil)))
(setf *need-prompt* t))
((member next-char '(#\newline #\return))
(setf *need-prompt* t))
(t
(setf *need-prompt* nil)
(unread-char next-char stream)))
result)))))
;;; ----------------------------------------------------------------------------
(defvar *general-display-prefix* "")
(defmvar $showtime nil)
(defun maxima-toplevel-loop (input-stream mode)
(declare (special $% $_ $__))
(when (eql mode :demo)
(format t
"~%At the '~A' prompt, type ';' and <enter> to get next demonstration.~&"
(print-invert-case (stripdollar $prompt))))
(catch 'abort-demo
(do ((form)
(time) (etime) (area)
(eof (list nil))
(i-tag)
(o-tag))
(nil)
(catch 'return-from-debugger
(when (or (not (checklabel $inchar))
(not (checklabel $outchar)))
(incf $linenum))
(setq i-tag (makelabel $inchar))
(let ((*mread-prompt* (if mode nil (main-prompt))))
(setq form (maxima-toplevel-read input-stream nil eof)))
(format t "~a" *general-display-prefix*)
(if (eq form eof) (return '$done))
(setq $__ (caddr form))
(unless $nolabels (set i-tag $__))
(when mode (mdisplay `((mlabel) ,i-tag , $__)))
(setq time (get-internal-run-time)
etime (get-internal-real-time))
(setq area (used-area))
(setq $% (maxima-toplevel-eval $__))
(setq time (/ (float (- (get-internal-run-time) time))
internal-time-units-per-second)
etime (/ (float (- (get-internal-real-time) etime))
internal-time-units-per-second))
(setq o-tag (makelabel $outchar))
(unless $nolabels (set o-tag $%))
(setq $_ $__)
(when $showtime
(format t "Evaluation took ~,4F seconds (~,4F elapsed)" time etime)
(let ((total-bytes (- (used-area) area)))
(cond ((> total-bytes (* 1024 1024))
(format t " using ~,3F MB.~%"
(/ total-bytes (* 1024.0 1024.0))))
((> total-bytes 1024)
(format t " using ~,3F KB.~%" (/ total-bytes 1024.0)))
(t
(format t " using ~:D bytes.~%" total-bytes)))))
(unless $nolabels
(putprop '$% (cons time etime) 'time)
(putprop o-tag (cons time etime) 'time))
(if (eq (caar form) 'displayinput)
(mdisplay `((mlabel) ,o-tag ,$%)))
(when (eq mode ':demo)
(princ (break-prompt))
(force-output)
(let (quitting)
(do ((char)) (nil)
(case (setq char (read-char *terminal-io*))
((#\page)
(fresh-line)
(princ (break-prompt))
(force-output))
((#\?)
(format t
"Pausing. Type a ';' and <enter> to continue demo.~%"))
((#\space #\; #\n #\e #\x #\t))
((#\newline)
(if quitting (throw 'abort-demo nil) (return nil)))
(t (setq quitting t))))))
(when mode
(do ((char)) (())
(setq char (read-char input-stream nil nil))
(when (null char)
(throw 'macsyma-quit nil))
(unless (member char '(#\space #\newline #\return #\tab))
(unread-char char input-stream)
(return nil))))))))
;;; ----------------------------------------------------------------------------
(defvar *maxima-quiet* nil)
(defvar *maxima-epilog* "")
(let ((maxima-started nil))
(defun maxima-toplevel (input-stream mode)
(in-package :kmaxima)
(if maxima-started
(format t "Maxima restarted.~%")
(progn
(if (not *maxima-quiet*) (maxima-banner))
(setq maxima-started t)))
(catch 'maxima-quit-toplevel
(loop
(catch 'maxima-continue
(maxima-toplevel-loop input-stream mode)
(format t *maxima-epilog*)
(bye))))))
;;; ----------------------------------------------------------------------------
(defun cl-user::run ()
(in-package :kmaxima)
(let ((input-stream *standard-input*)
(mode nil))
(catch 'maxima-quit-to-lisp
(loop
(with-simple-restart (kmaxima "Return to kMaxima top level.")
(maxima-toplevel input-stream mode))))))
(import 'cl-user::run)
;;; ----------------------------------------------------------------------------
(defun $writefile (filename)
(let ((msg (dribble filename)))
(format t "~&~A~&" msg)
'$done))
(defun $closefile ()
(let ((msg (dribble)))
(format t "~&~A~&" msg))
'$done)
;;; ----------------------------------------------------------------------------
(defun merror (message &rest args)
(apply #'format `(t ,message ,@args))
(format t "~& -- an error. To debug this try: debugmode(true);~%")
(throw 'maxima-continue 'maxima-error))
;;; ----------------------------------------------------------------------------
(defvar *values* nil)
(defvar *options* nil)
(defmvar $optionset nil)
(defun mset (x y)
(cond ((symbolp x)
(let ((f (getprop x 'assign)))
(if (and f (or (not (eq x y))
(eq f 'neverset)))
(if (eq (funcall f x y) 'munbindp)
(return-from mset nil))))
(cond ((not (boundp x))
(push x *values*))
((and (not (eq x y))
(boundp x)
(not (member x *values*)))
(if $optionset
(format t "assignment: assigning to option ~A~%" x))
(push x *options*)))
(return-from mset (setf (symbol-value x) y)))
(t (merror "assignment: cannot assign to ~A~%" x))))
;;; ----------------------------------------------------------------------------
(defvar *munbindp* nil)
(defun mseterror (var val)
(declare (special *munbindp*))
(if *munbindp*
'munbindp
(merror "assignment: cannot assign ~a to ~a" val var)))
;;; ----------------------------------------------------------------------------
(defun neverset (var val)
(mseterror var val))
(defun boolset (var val)
(if (not (member val '(t nil $false $true)))
(mseterror var val)))
(defun shadowset (var val)
(mset (get var 'shadowvar) val))
(defun shadowboolset (var val)
(if (not (member val '(t nil $false $true)))
(mseterror var val)
(mset (get var 'shadowvar) val)))
;;; ----------------------------------------------------------------------------
(defun $values ()
(cons '(mlist simp) (copy-list *values*)))
(defun $options ()
(cons '(mlist simp) (copy-list *options*)))
;;; ----------------------------------------------------------------------------
(defprop $optionset boolset assign)
(defprop $%pi neverset assign)
(defprop $%i neverset assign)
(defprop $%e neverset assign)
(defprop $%phi neverset assign)
(defprop $%gamma neverset assign)
;;; ----------------------------------------------------------------------------
(defmspec mquote (form)
(cadr form))
(defmspec msetq (l)
(mset (cadr l) (meval (caddr l))))
;;; ----------------------------------------------------------------------------
(defun reset1 (args)
(declare (special *variable-initial-values*))
(labels ((maybe-reset (key val)
(let ((reset nil))
(when (and (boundp key)
(not (alike1 (symbol-value key) val)))
(setq reset key)
(let ((*munbindp* t)
($optionset nil))
(declare (special *munbindp* $optionset))
(meval `((msetq) ,key ((mquote) ,val)))))
reset)))
(let ((actually-reset nil))
(if args
(mapcar
#'(lambda (key)
(multiple-value-bind (val found-p)
(gethash key *variable-initial-values*)
(if found-p
(if (maybe-reset key val)
(push key actually-reset)))))
args)
(maphash
#'(lambda (key val)
(if (maybe-reset key val)
(push key actually-reset)))
*variable-initial-values*))
(cons '(mlist) (nreverse actually-reset)))))
(defmspec $reset (l)
(reset1 (cdr l)))
;;; ----------------------------------------------------------------------------
B.11 simplify.lisp
;;; ----------------------------------------------------------------------------
;;; simplify.lisp
;;;
;;; Copyright (C) 2011 Dr. Dieter Kaiser
;;;
;;; This file contains modified code from:
;;;
;;; Copyright (C) 1984, 1987 William Schelter, University of Texas
;;; Copyright (C) 1981, 1982 Massachusetts Institute of Technology
;;;
;;; This program is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2 of the License, or
;;; (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
;;; ----------------------------------------------------------------------------
(in-package :kmaxima)
(defmvar $simp t)
(defmvar $%enumer nil)
(defmvar $negdistrib t)
(defmvar $float nil)
(defmvar $%emode nil)
(defmvar $numer nil)
(defprop $numer shadowboolset assign)
(defprop $numer $float shadowvar)
(defmvar $domain '$real)
(defmvar $radexpand t)
(defmvar $numer_pbranch t)
(defmvar $expop 0)
(defmvar $expon 0)
(defmvar $listarith t)
(defmvar $doallmxops t)
(defvar *dosimp* nil)
(defvar *errorsw* nil)
(defvar *expandflag* nil)
;;; ----------------------------------------------------------------------------
(setf (get '$%e '$numer)
2.7182818284590452353602874713526624977572470936999595749669676277)
(setf (get '$%pi '$numer)
3.1415926535897932384626433832795028841971693993751058209749445923)
(setf (get '$%phi '$numer)
1.6180339887498948482045868343656381177203091798057628621354486227)
(setf (get '$%gamma '$numer)
0.5772156649015328606065120900824024310421593359399235988057672348)
;;; ----------------------------------------------------------------------------
(setf (get '$%e '$constant) t)
(setf (get '$%pi '$constant) t)
(setf (get '$%gamma '$constant) t)
(setf (get '$%phi '$constant) t)
(setf (get '$%i '$constant) t)
;;; ----------------------------------------------------------------------------
(defmacro take (operator &rest args)
`(simplifya (list ,operator ,@args) t))
;;; ----------------------------------------------------------------------------
(defun oneargcheck (l)
(when (or (null (cdr l))
(cddr l))
(wna-err (caar l))))
(defun twoargcheck (l)
(when (or (null (cddr l))
(cdddr l))
(wna-err (caar l))))
(defun wna-err (op)
(merror "Wrong number of arguments to ~A" op))
;;; ----------------------------------------------------------------------------
(defun alphalessp (x y)
(cond ((numberp x)
(if (numberp y) (< x y) t))
((stringp x)
(cond ((numberp y) nil)
((stringp y)
(if (string< x y) t nil))
(t t)))
((symbolp x)
(cond ((or (numberp y) (stringp y)) nil)
((symbolp y)
(let ((nx (symbol-name x))
(ny (symbol-name y)))
(declare (string nx ny))
(cond ((string< nx ny) t)
((string= nx ny)
(cond ((eq nx ny) nil)
((null (symbol-package x)) nil)
((null (symbol-package y)) nil)
(t
(if (string<
(package-name (symbol-package x))
(package-name (symbol-package y)))
t
nil))))
(t nil))))
((consp y) t)))
((listp x)
(cond ((or (numberp y) (stringp y) (symbolp y)) nil)
((listp y)
(or (alphalessp (car x) (car y))
(and (equal (car x) (car y))
(alphalessp (cdr x) (cdr y)))))
(t nil)))
((or (numberp y) (stringp y) (symbolp y) (consp y)) nil)
(t
(alphalessp (format nil "~s" x) (format nil "~s" y)))))
;;; ----------------------------------------------------------------------------
(defun great (x y)
(cond ((atom x)
(cond ((atom y)
(cond ((numberp x)
(cond ((numberp y)
(setq y (- x y))
(cond ((zerop y) (floatp x))
(t (plusp y))))))
((decl-constant x)
(cond ((decl-constant y) (alphalessp y x))
(t (numberp y))))
((get x '$scalar)
(cond ((get y '$scalar) (alphalessp y x))
(t (mconstantp y))))
((get x '$mainvar)
(cond ((get y '$mainvar) (alphalessp y x))
(t t)))
(t
(or (mconstantp y)
(get y '$scalar)
(and (not (get y '$mainvar))
(alphalessp y x))))))
(t (not (ordfna y x)))))
((atom y) (ordfna x y))
((eq (caar x) 'rat)
(cond ((eq (caar y) 'rat)
(> (* (caddr y) (cadr x)) (* (caddr x) (cadr y))))))
((eq (caar y) 'rat))
((or (member (caar x) '(mtimes mplus mexpt) :test #'eq)
(member (caar y) '(mtimes mplus mexpt) :test #'eq))
(ordfn x y))
((and (bigfloatp x) (bigfloatp y)) (fpgreaterp (cdr x) (cdr y)))
(t
(do ((x1 (margs x) (cdr x1))
(y1 (margs y) (cdr y1)))
(())
(cond ((null x1)
(return (cond (y1 nil)
((not (alike1 (mop x) (mop y)))
(great (mop x) (mop y)))
((member 'array (cdar x) :test #'eq) t))))
((null y1) (return t))
((not (alike1 (car x1) (car y1)))
(return (great (car x1) (car y1)))))))))
(defun ordhack (x)
(if (and (cddr x) (null (cdddr x)))
(great (if (eq (caar x) 'mplus) 0 1) (cadr x))))
(defun ordfna (e a)
(labels ((ordhack (x)
(if (and (cddr x) (null (cdddr x)))
(great (if (eq (caar x) 'mplus) 0 1) (cadr x)))))
(cond ((numberp a)
(or (not (eq (caar e) 'rat))
(> (cadr e) (* (caddr e) a))))
((and (decl-constant a)
(not (member (caar e) '(mplus mtimes mexpt) :test #'eq)))
(not (member (caar e) '(rat bigfloat) :test #'eq)))
((null (margs e)) nil)
((eq (caar e) 'mexpt)
(cond ((and (mconstantp (cadr e))
(or (not (decl-constant a))
(not (mconstantp (caddr e)))))
(or (not (free (caddr e) a)) (great (caddr e) a)))
((eq (cadr e) a) (great (caddr e) 1))
(t (great (cadr e) a))))
((member (caar e) '(mplus mtimes) :test #'eq)
(let ((u (car (last e))))
(cond ((eq u a) (not (ordhack e))) (t (great u a)))))
((prog2
(setq e (car (margs e)))
(and (not (atom e))
(member (caar e) '(mplus mtimes) :test #'eq)))
(let ((u (car (last e)))) (or (eq u a) (great u a))))
((eq e a))
(t (great e a)))))
(defun ordlist (a b cx cy)
(prog (l1 l2 c d)
(setq l1 (length a)
l2 (length b))
loop
(cond ((eql l1 0)
(return (cond ((eql l2 0) (eq cx 'mplus))
((and (eq cx cy) (eql l2 1))
(great (if (eq cx 'mplus) 0 1) (car b))))))
((eql l2 0)
(return (not (ordlist b a cy cx)))))
(setq c (nth (1- l1) a)
d (nth (1- l2) b))
(if (not (alike1 c d)) (return (great c d)))
(setq l1 (1- l1)
l2 (1- l2))
(go loop)))
(defun ordfn (x y)
(labels ((term-list (x)
(if (mplusp x) (cdr x) (list x)))
(factor-list (x)
(if (mtimesp x) (cdr x) (list x)))
(ordlist (a b cx cy)
(prog (l1 l2 c d)
(setq l1 (length a)
l2 (length b))
loop1
(cond ((eql l1 0)
(return (cond ((eql l2 0) (eq cx 'mplus))
((and (eq cx cy) (eql l2 1))
(great (if (eq cx 'mplus) 0 1)
(car b))))))
((eql l2 0)
(return (not (ordlist b a cy cx)))))
(setq c (nth (1- l1) a)
d (nth (1- l2) b))
(if (not (alike1 c d)) (return (great c d)))
(setq l1 (1- l1)
l2 (1- l2))
(go loop1))))
(let ((cx (caar x))
(cy (caar y)))
(cond ((or (eq cx 'mtimes) (eq cy 'mtimes))
(ordlist (factor-list x) (factor-list y) 'mtimes 'mtimes))
((or (eq cx 'mplus) (eq cy 'mplus))
(ordlist (term-list x) (term-list y) 'mplus 'mplus))
((eq cx 'mexpt)
(ordmexpt x y))
((eq cy 'mexpt)
(not (ordmexpt y x)))))))
(defun ordmexpt (x y)
(cond ((eq (caar y) 'mexpt)
(cond ((alike1 (cadr x) (cadr y))
(great (caddr x) (caddr y)))
((mconstantp (cadr x))
(if (mconstantp (cadr y))
(if (or (alike1 (caddr x) (caddr y))
(and (mnumberp (caddr x))
(mnumberp (caddr y))))
(great (cadr x) (cadr y))
(great (caddr x) (caddr y)))
(great x (cadr y))))
((mconstantp (cadr y))
(great (cadr x) y))
((mnumberp (caddr x))
(great (cadr x) (if (mnumberp (caddr y)) (cadr y) y)))
((mnumberp (caddr y)) (great x (cadr y)))
(t
(let ((x1 (mul (caddr x) (take '(%log) (cadr x))))
(y1 (mul (caddr y) (take '(%log) (cadr y)))))
(if (alike1 x1 y1)
(great (cadr x) (cadr y))
(great x1 y1))))))
((alike1 (cadr x) y) (great (caddr x) 1))
((mnumberp (caddr x)) (great (cadr x) y))
(t (great (mul (caddr x) (take '(%log) (cadr x)))
(take '(%log) y)))))
;;; ----------------------------------------------------------------------------
(defun add (&rest terms)
(if (and (cdr terms) (null (cddr terms)))
(apply #'add2 terms)
(apply #'addn `(,terms t))))
(define-compiler-macro add (&rest terms)
(if (and (cdr terms) (null (cddr terms)))
`(add2 ,@terms))
`(addn (list ,@terms) t))
(defun add2 (x y)
(cond ((eql 0 x) y)
((eql 0 y) x)
((and (numberp x) (numberp y)) (+ x y))
(t (simplifya `((mplus) ,x ,y) t))))
(defun addn (terms simp-flag)
(cond ((null terms) 0)
((null (cdr terms)) (simplifya (car terms) simp-flag))
(t (simplifya `((mplus) . ,terms) simp-flag))))
;;; ----------------------------------------------------------------------------
(defun mul (&rest factors)
(if (and (cdr factors) (null (cddr factors)))
(apply #'mul2 factors)
(apply #'muln `(,factors t))))
(define-compiler-macro mul (&rest factors)
(if (and (cdr factors) (null (cddr factors)))
`(mul2 ,@factors))
`(muln (list ,@factors) t))
(defun mul2 (x y)
(cond ((eql 1 x) y)
((eql 1 y) x)
((and (numberp x) (numberp y)) (* x y))
(t (simplifya `((mtimes) ,x ,y) t))))
(defun muln (factors simp-flag)
(cond ((null factors) 1)
((null (cdr factors)) (simplifya (car factors) simp-flag))
(t (simplifya `((mtimes) . ,factors) simp-flag))))
;;; ----------------------------------------------------------------------------
(defun sub (x y)
(cond ((eql 0 y) x)
((eql 0 x) (neg y))
((and (numberp x) (numberp y)) (- x y))
(t (add x (neg y)))))
(defun neg (x)
(declare (special $negdistrib))
(cond ((numberp x) (- x))
(t (let (($negdistrib t))
(simplifya `((mtimes) -1 ,x) t)))))
(defun power (bas pow)
(cond ((eql 1 pow) bas)
(t (simplifya `((mexpt) ,bas ,pow) t))))
(defun inv (x)
(power x -1))
(defun div (x y)
(if (eql 1 x)
(inv y)
(mul x (inv y))))
;;; ----------------------------------------------------------------------------
(defun make-rat (n d)
(cond ((zerop n) 0)
((eql d 1) n)
(t
(let ((u (gcd n d)))
(setq n (truncate n u)
d (truncate d u))
(when (minusp d) (setq n (- n) d (- d)))
(cond ((eql d 1) n)
($float (float (/ n d)))
(t (list '(rat simp) n d)))))))
(defun simp-rat (x y z)
(declare (ignore y z))
(cond ((member 'simp (cdar x) :test #'eq)
(if $float
(rat2float x)
x))
(t (make-rat (cadr x) (caddr x)))))
(defun rat2float (x)
(float (/ (cadr x) (caddr x))))
(defun rat-num (x)
(if (numberp x) x (cadr x)))
(defun rat-den (x)
(if (numberp x) 1 (caddr x)))
;;; ----------------------------------------------------------------------------
(defun addk (x y)
(cond ((eql x 0) y)
((eql y 0) x)
((and (numberp x) (numberp y)) (+ x y))
((or (bigfloatp x) (bigfloatp y)) ($bfloat (list '(mplus) x y)))
(t
(prog (g a b)
(cond ((numberp x)
(cond ((floatp x) (return (+ x (rat2float y))))
(t (setq x (list '(rat) x 1)))))
((numberp y)
(cond ((floatp y) (return (+ y (rat2float x))))
(t (setq y (list '(rat) y 1))))))
(setq g (gcd (caddr x) (caddr y)))
(setq a (truncate (caddr x) g)
b (truncate (caddr y) g))
(return (timeskl (list '(rat) 1 g)
(list '(rat)
(+ (* (cadr x) b)
(* (cadr y) a))
(* a b))))))))
;;; ----------------------------------------------------------------------------
(defun timesk (x y)
(cond ((eql x 1) y)
((eql y 1) x)
((and (numberp x) (numberp y)) (* x y))
((or (bigfloatp x) (bigfloatp y)) ($bfloat (list '(mtimes) x y)))
((floatp x) (* x (rat2float y)))
((floatp y) (* y (rat2float x)))
(t (timeskl x y))))
(defun timeskl (x y)
(prog (u v g)
(setq u (make-rat (rat-num x) (rat-den y)))
(setq v (make-rat (rat-num y) (rat-den x)))
(setq g (cond ((or (eql u 0) (eql v 0)) 0)
((eql v 1) u)
((eql u 1) v)
((and (numberp u) (numberp v)) (* u v))
(t
(list '(rat simp)
(* (rat-num u) (rat-num v))
(* (rat-den u) (rat-den v))))))
(return (cond ((numberp g) g)
((eql (caddr g) 1) (cadr g))
($float (rat2float g))
(t g)))))
;;; ----------------------------------------------------------------------------
(defun exptb (a b)
(cond ((eql a (get '$%e '$numer))
(exp (float b)))
((or (floatp a) (not (minusp b)))
(expt a b))
(t
(setq b (expt a (- b)))
(make-rat 1 b))))
;;; ----------------------------------------------------------------------------
(defun simpcheck (form flag)
(cond (flag form)
(t
(let (($%enumer $numer))
(simplifya form nil)))))
;;; ----------------------------------------------------------------------------
(defun testtneg (x)
(if (and $negdistrib
(eql (cadr x) -1)
(null (cdddr x))
(mplusp (caddr x)))
(addn (mapcar #'(lambda (z) (mul -1 z)) (cdaddr x)) t)
x))
(defun testt (x)
(cond ((mnumberp x) x)
((null (cddr x)) (cadr x))
((eql 1 (cadr x))
(cond ((null (cdddr x))
(caddr x))
(t (rplacd x (cddr x)))))
(t (testtneg x))))
(defun testp (x)
(cond ((atom x) 0)
((null (cddr x)) (cadr x))
((zerop1 (cadr x))
(if (null (cdddr x))
(caddr x)
(rplacd x (cddr x))))
(t x)))
;;; ----------------------------------------------------------------------------
(defun simplifya (x y)
(cond ((not $simp) x)
((atom x)
(cond ((and $%enumer $numer (eq x '$%e))
(setq x (get '$%e '$numer)))
(t x)))
((atom (car x))
(merror "simplifya: Found an illegal kMaxima expression."))
((eq (caar x) 'rat) (simp-rat x 1 nil))
((and (not *dosimp*) (member 'simp (cdar x) :test #'eq)) x)
(t
(let ((w (get (caar x) 'operators)))
(cond ((and w
(not (member 'array (cdar x) :test #'eq)))
(funcall w x 1 y))
(t (simpargs x y)))))))
(defun simpargs (x y)
(if (and (member 'array (cdar x) :test #'eq)
(null (margs x)))
(merror "simplifya: Subscripted variable found with no subscripts."))
(eqtest (if y
x
(let ((flag (member (caar x) '(mlist mequal) :test #'eq)))
(cons (ncons (caar x))
(mapcar #'(lambda (u)
(if flag
(simplifya u nil)
(simpcheck u nil)))
(cdr x)))))
x))
(defun eqtest (x check)
(cond ((or (atom x)
(eq (caar x) 'rat)
(member 'simp (cdar x) :test #'eq))
x)
((and (eq (caar x) (caar check))
(equal (cdr x) (cdr check)))
(cond ((member 'simp (cdar check) :test #'eq)
check)
(t
(cons (cons (caar check)
(if (cdar check)
(cons 'simp (cdar check))
'(simp)))
(cdr check)))))
((or (member 'array (cdar x) :test #'eq)
(and (eq (caar x) (caar check))
(member 'array (cdar check) :test #'eq)))
(rplaca x (cons (caar x) '(simp array))))
(t
(rplaca x (cons (caar x) '(simp))))))
;;; ----------------------------------------------------------------------------
(setf (get 'bigfloat 'operators) 'simp-bigfloat)
(defun simp-bigfloat (x vestigial simp-flag)
(declare (ignore vestigial simp-flag))
(bigfloatm* x))
(setf (get 'bigfloat 'mspec) 'bigfloatm*)
(defun bigfloatm* (bf)
(unless (member 'simp (cdar bf) :test #'eq)
(setq bf (cons (list* (caar bf) 'simp (cdar bf)) (cdr bf))))
(if $float ($float bf) bf))
;;; ----------------------------------------------------------------------------
(setf (get 'mquotient 'operators) 'simp-mquotient)
(defun simp-mquotient (x y z)
(twoargcheck x)
(cond ((and (integerp (cadr x))
(integerp (caddr x))
(not (zerop (caddr x))))
(make-rat (cadr x) (caddr x)))
((and (numberp (cadr x))
(numberp (caddr x))
(not (zerop (caddr x))))
(/ (cadr x) (caddr x)))
(t
(setq y (simplifya (cadr x) z))
(setq x (power (simplifya (caddr x) z) -1))
(if (eql y 1)
x
(mul y x)))))
;;; ----------------------------------------------------------------------------
(setf (get 'mminus 'operators) 'simp-mminus)
(defun simp-mminus (x y z)
(cond ((null (cdr x)) 0)
((null (cddr x))
(mul -1 (simplifya (cadr x) z)))
(t
(sub (simplifya (cadr x) z) (addn (cddr x) z)))))
;;; ----------------------------------------------------------------------------
(defprop $sqrt %sqrt verb)
(defprop $sqrt %sqrt alias)
(defprop %sqrt $sqrt noun)
(defprop %sqrt $sqrt reversealias)
(defprop %sqrt simp-sqrt operators)
(defun $sqrt (z)
(simplifya (list '(%sqrt) z) nil))
(defun simp-sqrt (x ignored z)
(declare (ignore ignored))
(oneargcheck x)
(simplifya (list '(mexpt) (cadr x) '((rat simp) 1 2)) z))
;;; ----------------------------------------------------------------------------
(setf (get 'mplus 'operators) 'simp-mplus)
(defun simp-mplus (x w z)
(prog (res check eqnflag)
(if (null (cdr x)) (return 0))
(setq check x)
start
(setq x (cdr x))
(if (null x) (go end))
(setq w (if z (car x) (simplifya (car x) nil)))
st1
(cond ((atom w) nil)
((eq (caar w) 'mequal)
(setq eqnflag
(if (not eqnflag)
w
(list (car eqnflag)
(add (cadr eqnflag) (cadr w))
(add (caddr eqnflag) (caddr w)))))
(go start)))
(setq res (pls w res))
(go start)
end
(setq res (eqtest (testp res) check))
(return (if eqnflag
(list (car eqnflag)
(add (cadr eqnflag) res)
(add (caddr eqnflag) res))
res))))
;;; ----------------------------------------------------------------------------
(defvar *plusflag* nil)
(defun pls (x out)
(prog (fm *plusflag*)
(if (mtimesp x) (setq x (testtneg x)))
(when (and $numer (atom x) (eq x '$%e))
(setq x (get '$%e '$numer)))
(cond ((null out)
(return
(cons '(mplus)
(cond ((mnumberp x) (ncons x))
((not (mplusp x))
(list 0 (if (atom x) x (copy-list x))))
((mnumberp (cadr x)) (copy-list (cdr x)))
(t (cons 0 (copy-list (cdr x) )))))))
((mnumberp x)
(return (cons '(mplus)
(if (mnumberp (cadr out))
(cons (addk (cadr out) x) (cddr out))
(cons x (cdr out))))))
((not (mplusp x))
(plusin x (cdr out))
(go end)))
(rplaca (cdr out)
(addk (if (mnumberp (cadr out)) (cadr out) 0)
(cond ((mnumberp (cadr x))
(setq x (cdr x))
(car x))
(t 0))))
(setq fm (cdr out))
start
(if (null (setq x (cdr x))) (go end))
(setq fm (plusin (car x) fm))
(go start)
end
(if (not *plusflag*) (return out))
(setq *plusflag* nil)
a
(setq fm (cdr out))
loop
(when (mplusp (cadr fm))
(setq x (cadr fm))
(rplacd fm (cddr fm))
(pls x out)
(go a))
(setq fm (cdr fm))
(if (null (cdr fm)) (return out))
(go loop)))
;;; ----------------------------------------------------------------------------
(defun plusin (x fm)
(prog (x1 x2 flag check v w xnew a n m c)
(setq w 1
v 1)
(cond ((mtimesp x)
(setq check x)
(if (mnumberp (cadr x))
(setq w (cadr x) x (cddr x))
(setq x (cdr x))))
(t (setq x (ncons x))))
(setq x1 (if (null (cdr x)) (car x) (cons '(mtimes) x))
xnew (list* '(mtimes) w x))
start
(cond ((null (cdr fm)))
((and (alike1 x1 (cadr fm))
(null (cdr x)))
(go equ))
((and (or (and (mexptp (setq x2 (cadr fm)))
(setq v 1))
(and (mtimesp x2)
(not (alike1 x1 x2))
(null (cadddr x2))
(integerp (setq v (cadr x2)))
(mexptp (setq x2 (caddr x2)))))
(integerp (setq a (cadr x2)))
(mexptp x1)
(eql a (cadr x1))
(integerp (sub (caddr x2) (caddr x1))))
(setq n (if (and (mplusp (caddr x2))
(mnumberp (cadr (caddr x2))))
(cadr (caddr x2))
(if (mnumberp (caddr x2))
(caddr x2)
0)))
(setq m (if (and (mplusp (caddr x1))
(mnumberp (cadr (caddr x1))))
(cadr (caddr x1))
(if (mnumberp (caddr x1))
(caddr x1)
0)))
(setq c (sub (caddr x2) n))
(cond ((integerp n)
(setq x1 (mul (addk (timesk v (exptb a n))
(timesk w (exptb a m)))
(power a c)))
(go equt2))
(t
(multiple-value-bind (n1 d1)
(truncate (rat-num n) (rat-den n))
(multiple-value-bind (n2 d2)
(truncate (rat-num m) (rat-den m))
(cond ((eql d1 d2))
((minusp d2)
(setq n1 (add n1 (div (sub d1 d2) (rat-den n))))
(setq d1 d2))
((minusp d1)
(setq n2 (add n2 (div (sub d2 d1) (rat-den n)))))
(t (merror "Internal error in simplus.")))
(setq x1 (mul (addk (timesk v (exptb a n1))
(timesk w (exptb a n2)))
(power a
(add c (div d1 (rat-den n))))))
(go equt2))))))
((mtimesp (cadr fm))
(cond ((alike1 x1 (cadr fm))
(go equt))
((and (mnumberp (cadadr fm)) (alike x (cddadr fm)))
(setq flag t)
(go equt))
((great xnew (cadr fm)) (go gr))))
((great x1 (cadr fm)) (go gr)))
(setq xnew (eqtest (testt xnew) (or check '((foo)))))
(return (cdr (rplacd fm (cons xnew (cdr fm)))))
gr
(setq fm (cdr fm))
(go start)
equ
(rplaca (cdr fm)
(if (eql w -1)
(list* '(mtimes simp) 0 x)
(if (mtimesp (setq x1 (muln (cons (addk 1 w) x) t)))
(testtneg x1)
x1)))
del
(cond ((not (mtimesp (cadr fm)))
(go check))
((eql 1 (cadadr fm))
(rplacd (cadr fm) (cddadr fm))
(return (cdr fm)))
((not (zerop1 (cadadr fm)))
(return (cdr fm)))
((and (or (not $listarith) (not $doallmxops))
(mxorlistp (caddr (cadr fm))))
(return (rplacd fm
(cons (constmx 0 (caddr (cadr fm))) (cddr fm))))))
(when (mnumberp (car fm))
(rplaca fm (addk (car fm) (cadadr fm))))
(return (rplacd fm (cddr fm)))
equt
(setq x1 (muln (cons (addk w (if flag (cadadr fm) 1)) x) t))
(setq x1 (list '(mplus) x1))
equt2
(rplaca (cdr fm)
(if (zerop1 x1)
(list* '(mtimes) x1 x)
(if (mtimesp x1) (testtneg x1) x1)))
(if (not (mtimesp (cadr fm))) (go check))
(when (and flag
(eql 1 (cadadr fm))
(null (cdddr (cadr fm))))
(rplaca (cdr fm) (caddr (cadr fm)))
(go check))
(go del)
check
(if (mplusp (cadr fm))
(setq *plusflag* t))
(return (cdr fm))))
;;; ----------------------------------------------------------------------------
(setf (get 'mtimes 'operators) 'simp-mtimes)
(defun simp-mtimes (x w z)
(declare (special *expandflag*))
(prog (res check eqnflag)
(if (null (cdr x)) (return 1))
(setq check x)
start
(setq x (cdr x))
(cond ((zerop1 res) (return res))
((null x) (go end)))
(setq w (if z (car x) (simplifya (car x) nil)))
st1
(cond ((atom w) nil)
((eq (caar w) 'mequal)
(setq eqnflag
(if (not eqnflag)
w
(list (car eqnflag)
(mul (cadr eqnflag) (cadr w))
(mul (caddr eqnflag) (caddr w)))))
(go start)))
(setq res (tms w 1 res))
(go start)
end
(if (mtimesp res) (setq res (testt res)))
(cond ((or (atom res)
(not (member (caar res) '(mexpt mtimes) :test #'eq))
(and (zerop $expop) (zerop $expon))
*expandflag*))
((eq (caar res) 'mtimes) (setq res (expandtimes res)))
((and (mplusp (cadr res))
(fixnump (caddr res))
(not (or (> (caddr res) $expop)
(> (- (caddr res)) $expon))))
(setq res (expandexpt (cadr res) (caddr res)))))
(if res (setq res (eqtest res check)))
(return (cond (eqnflag
(if (null res) (setq res 1))
(list (car eqnflag)
(mul (cadr eqnflag) res)
(mul (caddr eqnflag) res)))
(t res)))))
(defvar *rulesw* nil)
(defun tms (factor power product &aux tem)
(let ((*rulesw* nil)
(z nil))
(when (mplusp product) (setq product (list '(mtimes simp) product)))
(cond ((zerop1 factor)
(cond ((minusp1 power)
(if *errorsw*
(throw 'errorsw t)
(merror "Division by 0")))
(t factor)))
((and (null product)
(or (and (mtimesp factor) (eql power 1))
(and (setq product (list '(mtimes) 1)) nil)))
(setq tem (append '((mtimes))
(if (mnumberp (cadr factor)) nil '(1))
(cdr factor) nil))
(format t "in TMS: tem = ~A~%" tem)
(if (= (length tem) 1)
(setq tem (copy-list tem))
tem))
((mtimesp factor)
(do ((factor-list (cdr factor) (cdr factor-list)))
((or (null factor-list) (zerop1 product)) product)
(setq z (timesin (car factor-list) (cdr product) power))
(when *rulesw*
(setq *rulesw* nil)
(setq product (tms-format-product z)))))
(t
(setq z (timesin factor (cdr product) power))
(if *rulesw*
(tms-format-product z)
product)))))
(defun tms-format-product (x)
(cond ((zerop1 x) x)
((mnumberp x) (list '(mtimes) x))
((not (mtimesp x)) (list '(mtimes) 1 x))
((not (mnumberp (cadr x))) (cons '(mtimes) (cons 1 (cdr x))))
(t x)))
#+nil
(defun exponent-of (m base)
(unless (and (integerp base)
(not (eql (abs base) 1)))
(return-from exponent-of nil))
(cond ((great 1 m)
(let ((expo (exponent-of (inv m) base)))
(when expo (- expo))))
((ratnump m)
(exponent-of (/ (second m) (third m)) base))
(t
(let ((expo 0))
(when (integerp m)
(loop
(multiple-value-bind (q r)
(floor m base)
(cond ((zerop r)
(setf m q)
(incf expo))
(t (return nil))))))
(if (zerop expo)
nil
expo)))))
(defun exponent-of (m base)
(let ((expo 0))
(loop
(multiple-value-bind (q r)
(floor m base)
(cond ((zerop r)
(setf m q)
(incf expo))
(t (return nil)))))
(if (zerop expo) nil expo)))
(defvar *timesinp* nil)
(defun timesin (x y w)
(prog (fm temp z check u expo)
(if (mexptp x) (setq check x))
top
(cond ((eql w 1)
(setq temp x))
(t
(setq temp (cons '(mexpt) (if check
(list (cadr x) (mul (caddr x) w))
(list x w))))
(if (and (not *timesinp*)
(not (eq x '$%i)))
(let ((*timesinp* t))
(setq temp (simplifya temp t))))))
(setq x (if (mexptp temp)
(cdr temp)
(list temp 1)))
(setq w (cadr x)
fm y)
start
(cond ((null (cdr fm))
(go less))
((or (and (mnumberp temp)
(not (or (integerp temp)
(ratnump temp))))
(and (integerp temp)
(eql temp -1)))
(go less))
((mexptp (cadr fm))
(cond ((alike1 (car x) (cadadr fm))
(cond ((zerop1 (setq w (add (caddr (cadr fm)) w)))
(go del))
((and (mnumberp w)
(or (mnumberp (car x))
(eq (car x) '$%i)))
(rplacd fm (cddr fm))
(cond ((mnumberp (setq x (if (mnumberp (car x))
(exptrl (car x) w)
(power (car x) w))))
(return (rplaca y (timesk (car y) x))))
((mtimesp x)
(go times))
(t
(setq temp x
x (if (mexptp x) (cdr x) (list x 1)))
(setq w (cadr x)
fm y)
(go start))))
((mconstantp (car x))
(go const))
((onep1 w)
(cond ((mtimesp (car x))
(rplacd fm (cddr fm))
(setq *rulesw* t)
(return (muln (nconc y (cdar x)) t)))
(t (return (rplaca (cdr fm) (car x))))))
(t
(go spcheck))))
((and (onep1 w)
(or (ratnump (car x))
(and (integerp (car x))
(not (eql 1 (car x))))))
(let ((num (rat-num (car x)))
(den (rat-den (car x)))
(bas (second (cadr fm))))
(cond ((and (integerp bas)
(not (eql 1 (abs bas)))
(setq expo (exponent-of (abs num) bas)))
(setq x (mul (car y)
(div (mul num (exptrl bas (- expo)))
den))))
((and (integerp bas)
(not (eql 1 (abs bas)))
(setq expo (exponent-of den bas)))
(setq expo (- expo))
(setq x (mul (car y)
(div num
(mul den (exptrl bas expo))))))
(t
(setq fm (cdr fm))
(go start)))
(setq temp (power bas (add (third (cadr fm)) expo)))
(setf y (rplaca y 1))
(rplacd fm (cddr fm))
(rplacd fm (cons temp (cdr fm)))
(setq temp x
x (list x 1)
w 1
fm y)
(go start)))
((and (not (atom (car x)))
(eq (caar (car x)) 'mabs)
(eql (cadr x) 1)
(integerp (caddr (cadr fm)))
(< (caddr (cadr fm)) -1)
(alike1 (cadr (car x)) (cadr (cadr fm)))
(not (member ($csign (cadr (car x)))
'($complex imaginary))))
(setq temp (power (cadr (cadr fm))
(add (caddr (cadr fm)) 2)))
(rplacd fm (cddr fm))
(if (not (eql temp 1))
(rplacd fm (cons temp (cdr fm))))
(setq x (list (car x) -1))
(setq temp (power (car x) (cadr x)))
(setq w (cadr x))
(go start))
((and (not (atom (car x)))
(eq (caar (car x)) 'mabs)
(eql (cadr x) -1)
(integerp (caddr (cadr fm)))
(> (caddr (cadr fm)) 1)
(alike1 (cadr (car x)) (cadr (cadr fm)))
(not (member ($csign (cadr (car x)))
'($complex imaginary))))
(setq temp (power (cadr (cadr fm))
(add (caddr (cadr fm)) -2)))
(rplacd fm (cddr fm))
(if (not (eql temp 1))
(rplacd fm (cons temp (cdr fm))))
(setq x (list (car x) 1))
(setq temp (power (car x) (cadr x)))
(setq w (cadr x))
(go start))
((and (not (atom (cadr fm)))
(not (atom (cadr (cadr fm))))
(eq (caaadr (cadr fm)) 'mabs)
(eql (caddr (cadr fm)) -1)
(integerp (cadr x))
(> (cadr x) 1)
(alike1 (cadadr (cadr fm)) (car x))
(not (member ($csign (cadadr (cadr fm)))
'($complex imaginary))))
(setq temp (cadr (cadr fm)))
(rplacd fm (cddr fm))
(rplacd fm (cons temp (cdr fm)))
(setq x (list (car x) (add (cadr x) -2)))
(setq temp (power (car x) (cadr x)))
(setq w (cadr x))
(go start))
((or (mconstantp (car x))
(mconstantp (cadadr fm)))
(if (great temp (cadr fm))
(go gr)))
((great (car x) (cadadr fm))
(go gr)))
(go less))
((alike1 (car x) (cadr fm))
(go equ))
((mnumberp temp)
(setq fm (cdr fm))
(go start))
((and (not (atom (cadr fm)))
(eq (caar (cadr fm)) 'mabs)
(integerp (cadr x))
(< (cadr x) -1)
(alike1 (cadr (cadr fm)) (car x))
(not (member ($csign (cadr (cadr fm)))
'($complex imaginary))))
(setq temp (power (cadr fm) -1))
(rplacd fm (cddr fm))
(rplacd fm (cons temp (cdr fm)))
(setq x (list (car x) (add (cadr x) 2)))
(setq temp (power (car x) (cadr x)))
(setq w (cadr x))
(go start))
((mconstantp (car x))
(when (great temp (cadr fm))
(go gr)))
((great (car x) (cadr fm))
(go gr)))
less
(cond ((mnumberp temp)
(return (rplaca y (timesk (car y) temp))))
((and (eq (car x) '$%i)
(fixnump w))
(go %i))
((and (eq (car x) '$%e)
$numer
(integerp w))
(return (rplaca y (timesk (car y) (exp (float w))))))
((and (onep1 w)
(not (decl-constant (car x))))
(go less1))
((and (mexptp temp)
(not (onep1 (car y)))
(or (integerp (car y))
(ratnump (car y))))
(let ((num (rat-num (car y)))
(den (rat-den (car y)))
(bas (car x)))
(cond ((and (integerp bas)
(not (eql 1 (abs bas)))
(setq expo (exponent-of (abs num) bas)))
(setq temp (power bas (add (cadr x) expo)))
(setq x (div (div num (exptrl bas expo)) den)))
((and (integerp bas)
(not (eql 1 (abs bas)))
(setq expo (exponent-of den bas)))
(setq expo (- expo))
(setq temp (power bas (add (cadr x) expo)))
(setq x (div num (div den (exptrl bas (- expo))))))
(t
(return (cdr (rplacd fm (cons temp (cdr fm)))))))
(setf y (rplaca y 1))
(rplacd fm (cons temp (cdr fm)))
(setq temp x
x (list x 1)
w 1
fm y)
(go start)))
((and (mconstantp (car x))
(do ((l (cdr fm) (cdr l)))
((null (cdr l)))
(when (and (mexptp (cadr l))
(alike1 (car x) (cadadr l)))
(setq fm l)
(return t))))
(go start))
((or (and (mnumberp (car x))
(mnumberp w))
(and $%emode
(eq (car x) '$%e)
(among '$%i w)
(among '$%pi w)
(setq u (%especial w))))
(setq x (cond (u)
((alike (cdr check) x)
check)
(t
(exptrl (car x) w))))
(cond ((mnumberp x)
(return (rplaca y (timesk (car y) x))))
((mtimesp x)
(go times))
((mexptp x)
(return (cdr (rplacd fm (cons x (cdr fm))))))
(t
(setq temp x
x (list x 1)
w 1
fm y)
(go start))))
((onep1 w)
(go less1))
(t
(setq temp (list '(mexpt) (car x) w))
(setq temp (eqtest temp (or check '((foo)))))
(return (cdr (rplacd fm (cons temp (cdr fm)))))))
less1
(return (cdr (rplacd fm (cons (car x) (cdr fm)))))
gr
(setq fm (cdr fm))
(go start)
equ
(cond ((and (eq (car x) '$%i) (eql w 1))
(rplacd fm (cddr fm))
(return (rplaca y (timesk -1 (car y)))))
((zerop1 (setq w (add 1 w)))
(go del))
((and (mnumberp (car x)) (mnumberp w))
(return (rplaca (cdr fm) (exptrl (car x) w))))
((mconstantp (car x))
(go const)))
spcheck
(setq z (list '(mexpt) (car x) w))
(cond ((alike1 (setq x (simplifya z t)) z)
(return (rplaca (cdr fm) x)))
(t
(rplacd fm (cddr fm))
(setq *rulesw* t)
(return (muln (cons x y) t))))
const
(rplacd fm (cddr fm))
(setq x (car x) check nil)
(go top)
times
(setq z (tms x 1 (setq temp (cons '(mtimes) y))))
(return (cond ((eq z temp)
(cdr z))
(t
(setq *rulesw* t) z)))
del
(return (rplacd fm (cddr fm)))
%i
(if (minusp (setq w (rem w 4)))
(incf w 4))
(return (cond ((zerop w)
fm)
((= w 2)
(rplaca y (timesk -1 (car y))))
((= w 3)
(rplaca y (timesk -1 (car y)))
(rplacd fm (cons '$%i (cdr fm))))
(t
(rplacd fm (cons '$%i (cdr fm))))))))
;;; ----------------------------------------------------------------------------
(setf (get 'mexpt 'operators) 'simp-mexpt)
(defun simp-mexpt (x y z)
(prog (gr pot check res *rulesw* w mlpgr mlppot)
(setq check x)
(if z
(setq gr (cadr x)
pot (caddr x))
(progn
(twoargcheck x)
(setq gr (simplifya (cadr x) nil))
(setq pot (let (($%enumer $numer)) (simplifya (caddr x) nil)))))
cont
(cond ((onep1 pot) (go atgr))
((or (zerop1 pot) (onep1 gr)) (return (exptrl gr pot)))
((zerop1 gr)
(cond ((mnumberp pot)
(if (minusp1 pot)
(merror "expt: Undefined: 0 to a negative exponent.")
(return (cond ((or (floatp gr) (floatp pot)) 0.0)
(t 0)))))
((or (member (setq z ($csign pot)) '($neg $nz))
(and *zexptsimp? (eq ($asksign pot) '$neg)))
(cond ((not *errorsw*)
(merror "expt: undefined: 0 to a negative exponent."))
(t (throw 'errorsw t))))
((and (member z '($complex $imaginary))
(member (setq z ($sign ($realpart pot)))
'($neg $nz $zero)))
(cond ((not *errorsw*)
(merror "expt: undefined: 0 to a complex exponent."))
(t (throw 'errorsw t))))
((and *zexptsimp? (eq ($asksign pot) '$zero))
(cond ((not *errorsw*)
(merror "expt: undefined: 0^0"))
(t (throw 'errorsw t))))
((not (member z '($pos $pz)))
(cond ((not (free pot '$%i))
(cond ((not *errorsw*)
(merror "expt: undefined: 0 to a complex exponent."))
(t (throw 'errorsw t))))
(t
(return (zerores gr pot)))))
(t (return (zerores gr pot)))))
((and (mnumberp gr)
(mnumberp pot)
(or (not (ratnump gr)) (not (ratnump pot))))
(return (eqtest (exptrl gr pot) check)))
((eq gr '$%i)
(return (%itopot pot)))
((and (realp gr) (minusp gr) (mevenp pot))
(setq gr (- gr))
(go cont))
((and (realp gr) (minusp gr) (moddp pot))
(return (mul2 -1 (power (- gr) pot))))
((and (eql gr -1) (mintegerp pot) (mminusp pot))
(setq pot (neg pot))
(go cont))
((and (eql gr -1)
(mintegerp pot)
(mtimesp pot)
(= (length pot) 3)
(fixnump (cadr pot))
(oddp (cadr pot))
(mintegerp (caddr pot)))
(setq pot (caddr pot))
(go cont))
((atom gr) (go atgr))
((and (eq (caar gr) 'mabs)
(evnump pot)
(or (and (eq $domain '$real) (not (decl-complexp (cadr gr))))
(and (eq $domain '$complex) (decl-realp (cadr gr)))))
(return (power (cadr gr) pot)))
((and (eq (caar gr) 'mabs)
(integerp pot)
(oddp pot)
(not (eql pot -1))
(or (and (eq $domain '$real) (not (decl-complexp (cadr gr))))
(and (eq $domain '$complex) (decl-realp (cadr gr)))))
(if (plusp pot)
(return (mul (power (cadr gr) (add pot -1))
gr))
(return (mul (power (cadr gr) (add pot 1))
(inv gr)))))
((eq (caar gr) 'mequal)
(return (eqtest (list (ncons (caar gr))
(power (cadr gr) pot)
(power (caddr gr) pot))
gr)))
((symbolp pot) (go opp))
((eq (caar gr) 'mexpt) (go e1))
((and (eq (caar gr) '%sum)
$sumexpand
(integerp pot)
(signp g pot)
(< pot $maxposex))
(return (do ((i (1- pot) (1- i))
(an gr (simplifya (list '(mtimes) an gr) t)))
((signp e i) an))))
((eql pot -1)
(return (eqtest (testt (tms gr pot nil)) check)))
((fixnump pot)
(return (eqtest (cond ((and (mplusp gr)
(not (or (> pot $expop)
(> (- pot) $expon))))
(expandexpt gr pot))
(t (simplifya (tms gr pot nil) t)))
check))))
opp
(cond ((eq (caar gr) 'mexpt) (go e1))
((eq (caar gr) 'rat)
(return (mul2 (power (cadr gr) pot)
(power (caddr gr) (mul2 -1 pot)))))
((not (eq (caar gr) 'mtimes)) (go up))
((or (eq $radexpand '$all) (and $radexpand (simplexpon pot)))
(setq res (list 1))
(go start))
((and (or (not (numberp (cadr gr)))
(eql (cadr gr) -1))
(eql -1 ($num gr))
(not (member ($csign gr) '($complex $imaginary)))
(and (eq $domain '$real) $radexpand))
(if (eq ($csign (setq w ($denom gr))) '$neg)
(return (inv (power (neg w) pot)))
(return (div (power -1 pot)
(power w pot)))))
((or (eq $domain '$complex) (not $radexpand)) (go up)))
(return (do ((l (cdr gr) (cdr l)) (res (ncons 1)) (rad))
((null l)
(cond ((equal res '(1))
(eqtest (list '(mexpt) gr pot) check))
((null rad)
(testt (cons '(mtimes simp) res)))
(t
(setq rad (power*
(cons '(mtimes) (nreverse rad)) pot))
(cond ((not (onep1 rad))
(setq rad
(testt (tms rad 1 (cons '(mtimes) res))))
(cond (*rulesw*
(setq *rulesw* nil res (cdr rad))))))
(eqtest (testt (cons '(mtimes) res)) check))))
(setq z ($csign (car l)))
(if (member z '($complex $imaginary))
(setq z '$pnz))
(setq w (cond ((member z '($neg $nz) :test #'eq)
(setq rad (cons -1 rad))
(mult -1 (car l)))
(t (car l))))
(cond ((onep1 w))
((alike1 w gr) (return (list '(mexpt simp) gr pot)))
((member z '($pn $pnz) :test #'eq)
(setq rad (cons w rad)))
(t
(setq w (testt (tms (simplifya (list '(mexpt) w pot) t)
1 (cons '(mtimes) res))))))
(cond (*rulesw* (setq *rulesw* nil res (cdr w))))))
start
(cond ((and (cdr res) (onep1 (car res)) (ratnump (cadr res)))
(setq res (cdr res))))
(cond ((null (setq gr (cdr gr)))
(return (eqtest (testt (cons '(mtimes) res)) check)))
((mexptp (car gr))
(setq y (list (caar gr) (cadar gr) (mult (caddar gr) pot))))
((eq (car gr) '$%i)
(setq y (%itopot pot)))
((mnumberp (car gr))
(setq y (list '(mexpt) (car gr) pot)))
(t (setq y (list '(mexpt simp) (car gr) pot))))
(setq w (testt (tms (simplifya y t) 1 (cons '(mtimes) res))))
(cond (*rulesw* (setq *rulesw* nil res (cdr w))))
(go start)
atgr
(cond ((zerop1 pot)
(return (exptrl gr pot)))
((onep1 pot)
(let ((y (getprop gr '$numer)))
(if (and y
(floatp y)
(or $numer
(not (eql pot 1))))
(return y)
(return (exptrl gr pot)))))
((eq gr '$%e)
(when $%emode
(when (and (not (member 'simp (car x) :test #'eq))
(complex-number-p pot 'bigfloat-or-number-p))
(let ((x ($realpart pot))
(y ($imagpart pot)))
(cond ((and (bigfloatp x) (like 0 y))
(return ($bfloat `((mexpt simp) $%e ,pot))))
((or (bigfloatp x) (bigfloatp y))
(let ((z (add ($bfloat x) (mul '$%i ($bfloat y)))))
(setq z ($rectform `((mexpt simp) $%e ,z)))
(return ($bfloat z))))))))
(cond ((and $logsimp (among '%log pot)) (return (%etolog pot)))
((and $demoivre (setq z (demoivre pot))) (return z))
((and $%emode
(among '$%i pot)
(among '$%pi pot)
(setq z (%especial pot)))
(return z))
(($taylorp (third x))
(return ($taylor x)))))
(t
(let ((y (getprop gr '$numer)))
(and y
(floatp y)
(or (floatp pot)
(and (bigfloatp pot)
(member gr *builtin-numeric-constants*)
(setq y ($bfloat gr)))
(and $numer (integerp pot)))
(return (exptrl y pot))))))
up
(return (eqtest (list '(mexpt) gr pot) check))
matrix
(cond ((zerop1 pot)
(cond ((mxorlistp1 gr) (return (constmx (addk 1 pot) gr)))
(t (return (exptrl gr pot)))))
((onep1 pot) (return gr))
((or $doallmxops $doscmxops $domxexpt)
(cond ((or (and mlpgr
(or (not ($listp gr)) $listarith)
(scalar-or-constant-p pot $assumescalar))
(and $domxexpt
mlppot
(or (not ($listp pot)) $listarith)
(scalar-or-constant-p gr $assumescalar)))
(return (simplifya (outermap1 'mexpt gr pot) t)))
(t (go up))))
((and $domxmxops (member pot '(-1 -1.0) :test #'equal))
(return (simplifya (outermap1 'mexpt gr pot) t)))
(t (go up)))
e1
(cond ((or (eq $radexpand '$all)
(simplexpon pot)
(and (eq $domain '$complex)
(not (member ($csign (caddr gr)) '($complex $imaginary)))
(or (member ($csign (cadr gr)) '($pos $pz $zero))
(and (mnumberp (caddr gr))
(eq ($sign (sub 1 (take '(mabs) (caddr gr))))
'$pos))))
(and (eq $domain '$real)
(member ($csign (cadr gr)) '($pos $pz $zero)))
(and (eql (caddr gr) -1)
(or (and $radexpand
(eq $domain '$real))
(and (eq ($csign (cadr gr)) '$complex)
(mconstantp (cadr gr)))))
(and $ratsimpexpons
(eql (caddr gr) -1))
(and $radexpand
(eq $domain '$real)
(odnump (caddr gr))))
(setq pot (mul pot (caddr gr))
gr (cadr gr)))
((and (eq $domain '$real)
(free gr '$%i)
$radexpand
(not (decl-complexp (cadr gr)))
(evnump (caddr gr)))
(setq pot (mul pot (caddr gr))
gr (radmabs (cadr gr))))
((and $radexpand
(eq $domain '$real)
(mminusp (caddr gr)))
(setq pot (neg pot)
gr (power (cadr gr) (neg (caddr gr)))))
(t (go up)))
(go cont)))
;;; ----------------------------------------------------------------------------
(defun simplexpon (e)
(or (mintegerp e)
(and (eq $domain '$real)
(ratnump e) (oddp (caddr e)))))
;;; ----------------------------------------------------------------------------
(defun %itopot (pot)
(if (fixnump pot)
(let ((i (boole boole-and pot 3)))
(cond ((eql i 0) 1)
((eql i 1) '$%i)
((eql i 2) -1)
(t (mul -1 '$%i))))
(power -1 (mul pot (inv 2)))))
;;; ----------------------------------------------------------------------------
(defun zerores (r1 r2)
(cond ((or (floatp r1) (floatp r2)) 0.0)
(t 0)))
;;; ----------------------------------------------------------------------------
(defvar exptrlsw nil)
(defun exptrl (r1 r2)
(cond ((eql r2 1) r1)
((eql r2 1.0)
(cond ((mnumberp r1) (addk 0.0 r1))
(t (list '(mexpt simp) r1 1.0))))
((zerop1 r1)
(cond ((or (zerop1 r2)
(minusp1 r2))
(if *errorsw*
(throw 'errorsw t)
(merror "expt: undefined: ~a" (list '(mexpt) r1 r2))))
(t (zerores r1 r2))))
((or (zerop1 r2) (onep1 r1))
(cond ((or (floatp r1) (floatp r2)) 1.0)
(t 1)))
((and (numberp r1) (integerp r2)) (exptb r1 r2))
((and (numberp r1) (floatp r2) (eql r2 (float (floor r2))))
(exptb (float r1) (floor r2)))
((or $numer
(and (floatp r2)
(or $numer_pbranch
(plusp (rat-num r1)))))
(let (y)
(cond ((minusp (setq r1 (addk 0.0 r1)))
(cond ((or $numer_pbranch
(eq $domain '$complex))
(setq r2 (addk 0.0 r2))
(cond ((eql (float (setq y (* 2.0 r2)))
(float (floor y)))
(if (plusp r2)
(mul (%itopot (floor y))
(exptb (sqrt (- r1)) (floor y)))
(mul (%itopot (floor y))
(inv (exptb (sqrt (- r1))
(- (floor y)))))))
(t
(setq y (expt r1 r2))
(if (complexp y)
(add (realpart y)
(mul '$%i (imagpart y)))
y))))
(t
(mul (power -1 r2) (exptrl (- r1) r2)))))
((eql (setq r2 (addk 0.0 r2)) (float (floor r2)))
(exptb r1 (floor r2)))
((and (eql (setq y (* 2.0 r2)) (float (floor y)))
(not (eql r1 (get '$%e '$numer))))
(exptb (sqrt r1) (floor y)))
(t (exp (* r2 (log r1)))))))
((floatp r2) (list '(mexpt simp) r1 r2))
((integerp r2)
(cond ((minusp r2)
(exptrl (cond ((eql (abs (cadr r1)) 1)
(* (cadr r1) (caddr r1)))
((minusp (cadr r1))
(list '(rat simp) (- (caddr r1)) (- (cadr r1))))
(t (list '(rat simp) (caddr r1) (cadr r1))))
(- r2)))
(t
(list '(rat simp)
(exptb (cadr r1) r2)
(exptb (caddr r1) r2)))))
((and (floatp r1)
(alike1 r2 '((rat) 1 2)))
(if (minusp r1)
(list '(mtimes simp) (sqrt (- r1)) '$%i)
(sqrt r1)))
((and (floatp r1)
(alike1 r2 '((rat) -1 2)))
(if (minusp r1)
(list '(mtimes simp) (/ -1.0 (sqrt (- r1))) '$%i)
(/ (sqrt r1))))
((floatp r1)
(if (plusp r1)
(exptrl r1 (rat2float r2))
(mul (exptrl -1 r2)
(exptrl (- r1) r2))))
(exptrlsw (list '(mexpt simp) r1 r2))
(t
(let ((exptrlsw t))
(mul (exptrl r1 (truncate (cadr r2) (caddr r2)))
(let ((y (let ($keepfloat $ratprint)
(simpnrt r1 (caddr r2))))
(z (rem (cadr r2) (caddr r2))))
(if (mexptp y)
(list (car y) (cadr y) (mul (caddr y) z))
(power y z))))))))
;;; ----------------------------------------------------------------------------
(defun flatten (x)
(labels ((rec (x acc)
(cond ((null x) acc)
((atom x) (cons x acc))
(t (rec (car x) (rec (cdr x) acc))))))
(rec x nil)))
(defun inv-power (a b)
(do ((q 1 (1+ q))
(x 0))
((> x b) nil)
(if (eql (setq x (expt a q)) b)
(return q))))
(defun iroot (a n)
(if (< (integer-length a) n)
(list 1 (1- a))
(do ((x (expt 2 (1+ (truncate (integer-length a) n)))
(- x (truncate (+ n1 bk) n)))
(n1 (1- n))
(xn)
(bk))
(nil)
(cond ((<= (setq bk (- x (truncate a (setq xn (expt x n1))))) 0)
(return (list x (- a (* x xn)))))))))
(defvar *in* nil)
(defvar *out* nil)
(defun simpnrt (a n)
(prog (*in* *out* factors)
(if (minusp a)
(setq *in* (list -1)
a (get-small-factors (- a)))
(setq *in* (list 1)
a (get-small-factors a)))
(if (eql 1 (car a))
(setq a (flatten (cadr a)))
(setq a (flatten (cons (list (car a) 1) (cadr a)))))
(simpnrt1 a n)
(setq *out* (if *out* (muln *out* nil) 1))
(setq *in* (cond (*in*
(setq *in* (muln *in* nil))
(nrthk *in* n))
(t 1)))
(return (mul *in* *out*))))
(defun simpnrt1 (x n)
(do ((x x (cddr x))
(y))
((null x))
(cond ((not (eql 1 (setq y (gcd (cadr x) n))))
(push (power (power (car x) (truncate (cadr x) y))
(inv (truncate n y)))
*out*))
((and (eql 1 (cadr x))
(integerp (car x))
(plusp (car x))
(eql 0 (cadr (setq y (iroot (car x) n)))))
(push (car y) *out*))
(t
(unless (> n (abs (cadr x)))
(push (power (car x) (truncate (cadr x) n)) *out*))
(push (power (car x) (rem (cadr x) n)) *in*)))))
(defun nrthk (a n)
(cond ((eql a 1) 1)
((eql a -1)
(cond ((eql n 2) '$%i)
((eq $domain '$real)
(if (evenp n)
(power -1 (inv n))
-1))
(t
(power -1 (inv n)))))
((and $radexpand
(minusp a))
(mul (let ((exptrlsw nil)) (power (mul -1 a) (inv n)))
(nrthk -1 n)))
(t
(power a (inv n)))))
;;; ----------------------------------------------------------------------------
B.12 float.lisp
;;; ----------------------------------------------------------------------------
;;; float.lisp
;;;
;;; Copyright (C) 2011 Dr. Dieter Kaiser
;;;
;;; This file contains modified code from:
;;;
;;; Copyright (C) 1984, 1987 William Schelter,University of Texas
;;; Copyright (C) 1982 Massachusetts Institute of Technology
;;;
;;; This program is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2 of the License, or
;;; (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
;;; ----------------------------------------------------------------------------
(in-package :kmaxima)
(eval-when (:compile-toplevel :load-toplevel :execute)
(defconstant +machine-fixnum-precision+
(integer-length most-positive-fixnum))
(defconstant +machine-mantissa-precision+ (float-digits 1.0)))
;;; ----------------------------------------------------------------------------
(defmvar $float2bf t)
(defmvar $bftorat nil)
(defmvar $bftrunc t)
(defmvar $fpprintprec 0)
(defmvar $maxfpprintprec (ceiling (log (expt 2 (float-digits 1.0)) 10.0)))
(defmvar $fpprec $maxfpprintprec)
(defmvar bigfloatzero '((bigfloat simp 56) 0 0))
(defmvar bigfloatone '((bigfloat simp 56) #.(expt 2 55) 1))
(defmvar bfhalf '((bigfloat simp 56) #.(expt 2 55) 0))
(defmvar bfmhalf '((bigfloat simp 56) #.(- (expt 2 55)) 0))
(defmvar $ratprint t)
(defmvar $keepfloat nil)
(defmvar $ratepsilon 2.0d-15)
;;; ----------------------------------------------------------------------------
(defvar fpprec)
(defvar *m)
(defvar *cancelled)
(defvar *decfp* nil)
;;; ----------------------------------------------------------------------------
(defprop %cot %tan recip)
(defprop %tan %cot recip)
(defprop %csc %sin recip)
(defprop %sin %csc recip)
(defprop %sec %cos recip)
(defprop %cos %sec recip)
(defprop %coth %tanh recip)
(defprop %tanh %coth recip)
(defprop %csch %sinh recip)
(defprop %sinh %csch recip)
(defprop %sech %cosh recip)
(defprop %sech %cosh recip)
;;; ----------------------------------------------------------------------------
(defun hipart (x n)
(if (bignump n)
(abs x)
(haipart x n)))
(defun haipart (x n)
(let ((x (abs x)))
(if (< n 0)
(if (< (integer-length x) (- n))
x
(logand x (1- (ash 1 (- n)))))
(ash x (min (- n (integer-length x)) 0)))))
;;; ----------------------------------------------------------------------------
(defprop $fpprec fpprec1 assign)
(defun fpprec1 (assign-var q)
(declare (ignore assign-var))
(if (or (not (fixnump q))
(< q 1))
(merror "fpprec: value must be a positive integer; found: ~M" q)
(progn
(setq fpprec (+ 2 (integer-length (expt 10 q)))
bigfloatone ($bfloat 1)
bigfloatzero ($bfloat 0)
bfhalf (list (car bigfloatone) (cadr bigfloatone) 0)
bfmhalf (list (car bigfloatone) (- (cadr bigfloatone)) 0))
q)))
;;; ----------------------------------------------------------------------------
(defun bcons (x)
`((bigfloat simp ,fpprec) . ,x))
(defun check-bigfloat (x)
(prog ()
(cond ((not (bigfloatp x)) (return nil))
((= fpprec (caddar x))
(return x))
((> fpprec (caddar x))
(setq x (bcons (list (fpshift (cadr x) (- fpprec (caddar x)))
(caddr x)))))
(t
(setq x (bcons (list (fpround (cadr x))
(+ (caddr x) *m fpprec (- (caddar x))))))))
(return (if (eql (cadr x) 0) (bcons (list 0 0)) x))))
(defun intofp (x)
(cond ((floatp x) (float2fp x))
((eql x 0) '(0 0))
((eq x '$%pi) (fppi))
((eq x '$%e) (fpe))
((eq x '$%gamma) (fpgamma))
((eq x '$%phi)
(cdr ($bfloat '((mtimes simp)
((rat simp) 1 2)
((mplus simp) 1
((mexpt simp) 5 ((rat simp) 1 2)))))))
(t (list (fpround x) (+ *m fpprec)))))
(defun fpround (x &aux (*print-base* 10) *print-radix*)
(prog (adjust)
(cond
((null *decfp*)
(setq *m (- (integer-length x) fpprec))
(cond ((= *m 0)
(setq *cancelled 0)
(return x))
(t
(setq adjust (fpshift 1 (1- *m)))
(when (minusp x) (setq adjust (- adjust)))
(incf x adjust)
(setq *m (- (integer-length x) fpprec))
(setq *cancelled (abs *m))
(cond ((zerop (hipart x (- *m)))
(return (fpshift (fpshift x (- -1 *m)) 1)))
(t (return (fpshift x (- *m))))))))
(t
(setq *m (- (length (exploden (abs x))) fpprec))
(setq adjust (fpshift 1 (1- *m)))
(when (minusp x) (setq adjust (- adjust)))
(setq adjust (* 5 adjust))
(setq *m (- (length (exploden (abs (setq x (+ x adjust))))) fpprec))
(return (fpshift x (- *m)))))))
(defun fpshift (x n)
(cond ((null *decfp*)
(cond ((and (minusp n) (minusp x))
(- (ash (- x) n)))
(t (ash x n))))
((> n 0)
(* x (expt 10 n)))
((< n 0)
(truncate x (expt 10 (- n))))
(t x)))
(defun fpintpart (x)
(let ((m (- fpprec (cadr x))))
(if (> m 0)
(truncate (car x) (expt 2 m))
(* (car x) (expt 2 (- m))))))
(defun fpend (x)
(cond ((eql (car x) 0) (bcons x))
((numberp (car x))
(bcons (list (fpround (car x)) (+ -8 *m (cadr x)))))
(t x)))
(defun fparcsimp (x)
(if (and (mplusp x)
(null (cdddr x))
(mtimesp (caddr x))
(null (cdddr (caddr x)))
(bigfloatp (cadr (caddr x)))
(eq (caddr (caddr x)) '$%i)
(< (caddr (cadr (caddr x))) (+ (- fpprec) 2)))
(cadr x)
x))
;;; ----------------------------------------------------------------------------
(defun bigfloat2rat (x)
(declare (special $ratprint))
(setq x (check-bigfloat x))
(let (($float2bf t)
(rat nil)
(y nil)
(sign nil))
(setq rat (cond ((minusp (cadr x))
(setq sign t
y (fpration1 (cons (car x) (fpabs (cdr x)))))
(rplaca y (* -1 (car y))))
(t (fpration1 x))))
(when $ratprint
(princ "`rat' replaced ")
(when sign (princ "-"))
(princ (coerce (fpformat (cons (car x) (fpabs (cdr x)))) 'string))
(princ " by ")
(princ (car rat))
(write-char #\/)
(princ (cdr rat))
(princ " = ")
(setq x ($bfloat (list '(rat simp) (car rat) (cdr rat))))
(when sign (princ "-"))
(princ (coerce (fpformat (cons (car x) (fpabs (cdr x)))) 'string))
(terpri))
rat))
(defun fpration1 (x)
(let ((fprateps (cdr ($bfloat (if $bftorat
(list '(rat simp) 1
(exptrl 2 (1- fpprec)))
$ratepsilon)))))
(or (and (equal x bigfloatzero)
(cons 0 1))
(prog (y a)
(return
(do ((xx x (setq y
(invertbigfloat
(bcons (fpsub (cdr xx)
(cdr ($bfloat a)))))))
(num (setq a (fpentier x))
(+ (* (setq a (fpentier y)) num) onum))
(den 1 (+ (* a den) oden))
(onum 1 num)
(oden 0 den))
((and (not (zerop den))
(not (fpgreaterp
(fpabs (fpdiv (fpsub (cdr x)
(fpdiv (cdr ($bfloat num))
(cdr ($bfloat den))))
(cdr x)))
fprateps)))
(cons num den))))))))
(defun float-nan-p (x)
(and (floatp x)
(not (= x x))))
(defun float-inf-p (x)
(labels ((extreme-float-values (x)
(case (type-of x)
(short-float
(values most-negative-short-float
most-positive-short-float))
(single-float
(values most-negative-single-float
most-positive-single-float))
(double-float
(values most-negative-double-float
most-positive-double-float))
(long-float
(values most-negative-long-float
most-positive-long-float))))
(beyond-extreme-values (x)
(multiple-value-bind (most-negative most-positive)
(extreme-float-values x)
(cond ((< x 0) (< x most-negative))
((> x 0) (> x most-positive))
(t nil)))))
(and (floatp x)
(not (float-nan-p x))
(beyond-extreme-values x))))
(defun float2fp (x)
(when (float-nan-p x)
(merror
"bfloat: attempted conversion of floating point NaN (not-a-number).~%"))
(when (float-inf-p x)
(merror "bfloat: attempted conversion of floating-point infinity.~%"))
(unless $float2bf
(format t "bfloat: converting float ~S to bigfloat.~%" x))
(if (zerop x)
(list 0 0)
(multiple-value-bind (frac exp sign)
(integer-decode-float x)
(let ((scale (- fpprec (integer-length frac))))
(list (ash (* sign frac) scale)
(+ fpprec (- exp scale)))))))
(defun fp2float (x)
(let ((precision (caddar x))
(mantissa (cadr x))
(exponent (caddr x))
(fpprec +machine-mantissa-precision+)
(*m 0))
(setq mantissa
(/ (fpround mantissa) (expt 2.0 +machine-mantissa-precision+)))
(let ((e (+ exponent (- precision) *m +machine-mantissa-precision+)))
(if (>= e 1025)
(merror "float: floating point overflow converting ~:M" x)
(scale-float mantissa e)))))
(defun rat2fp (x)
(let* ((signed-num (first x))
(plusp (plusp signed-num))
(num (if plusp signed-num (- signed-num)))
(den (second x))
(digits fpprec)
(scale 0))
(declare (fixnum digits scale))
(let ((den-twos (1- (integer-length (logxor den (1- den))))))
(declare (fixnum den-twos))
(decf scale den-twos)
(setq den (ash den (- den-twos))))
(let* ((num-len (integer-length num))
(den-len (integer-length den))
(delta (- den-len num-len))
(shift (1+ (the fixnum (+ delta digits))))
(shifted-num (ash num shift)))
(declare (fixnum delta shift))
(decf scale delta)
(labels ((float-and-scale (bits)
(let* ((bits (ash bits -1))
(len (integer-length bits)))
(cond ((> len digits)
(assert (= len (the fixnum (1+ digits))))
(multiple-value-bind (f0)
(floatit (ash bits -1))
(list (first f0) (+ (second f0)
(1+ scale)))))
(t
(multiple-value-bind (f0)
(floatit bits)
(list (first f0) (+ (second f0) scale)))))))
(floatit (bits)
(let ((sign (if plusp 1 -1)))
(list (* sign bits) 0))))
(loop
(multiple-value-bind (fraction-and-guard rem)
(truncate shifted-num den)
(let ((extra (- (integer-length fraction-and-guard) digits)))
(declare (fixnum extra))
(cond ((/= extra 1)
(assert (> extra 1)))
((oddp fraction-and-guard)
(return
(if (zerop rem)
(float-and-scale
(if (zerop (logand fraction-and-guard 2))
fraction-and-guard
(1+ fraction-and-guard)))
(float-and-scale (1+ fraction-and-guard)))))
(t
(return (float-and-scale fraction-and-guard)))))
(setq shifted-num (ash shifted-num -1))
(incf scale)))))))
;;; ----------------------------------------------------------------------------
(defun $bfloat (x)
(declare (special $ratprint))
(let (y)
(cond ((check-bigfloat x))
((or (numberp x)
(member x '($%e $%pi $%gamma $%phi) :test #'eq))
(bcons (intofp x)))
((or (atom x)
(member 'array (cdar x) :test #'eq))
(if (eq x '$%phi)
($bfloat '((mtimes simp)
((rat simp) 1 2)
((mplus simp) 1 ((mexpt simp) 5 ((rat simp) 1 2)))))
x))
((eq (caar x) 'rat)
(bcons (rat2fp (cdr x))))
((eq (caar x) 'mexpt)
(if (eq (cadr x) '$%e)
(fpexp* ($bfloat (caddr x)))
(exptbigfloat ($bfloat (cadr x)) (caddr x))))
((eq (caar x) 'mncexpt)
(list '(mncexpt) ($bfloat (cadr x)) (caddr x)))
((setq y (getprop (caar x) 'floatprog))
(funcall y (mapcar #'$bfloat (cdr x))))
(t (recur-apply #'$bfloat x)))))
;;; ----------------------------------------------------------------------------
(defprop mplus addbigfloat floatprog)
(defun addbigfloat (args)
(let ((fans (intofp 0))
nfans)
(do ((l args (cdr l)))
((null l)
(cond ((null nfans) (bcons fans))
((zerop (car fans)) (addn nfans nil))
(t (addn (cons (bcons fans) nfans) nil))))
(cond ((bigfloatp (car l))
(setq fans (fpadd (cdr (check-bigfloat (car l))) fans)))
(t
(setq nfans (cons (car l) nfans)))))))
(defun fpadd (a b)
(prog (*m expo man sticky)
(setq *cancelled 0)
(cond ((eql (car a) 0) (return b))
((eql (car b) 0) (return a)))
(setq expo (- (cadr a) (cadr b)))
(setq man (cond ((eql expo 0)
(setq sticky 0)
(fpshift (+ (car a) (car b)) 2))
((> expo 0)
(setq sticky (hipart (car b) (- 1 expo)))
(setq sticky (cond ((zerop sticky) 0)
((< (car b) 0) -1)
(t 1)))
(+ (fpshift (car a) 2)
(fpshift (car b) (- 2 expo))))
(t
(setq sticky (hipart (car a) (1+ expo)))
(setq sticky (cond ((zerop sticky) 0)
((< (car a) 0) -1)
(t 1)))
(+ (fpshift (car b) 2)
(fpshift (car a) (+ 2 expo))))))
(setq man (+ man sticky))
(return (cond ((eql man 0) '(0 0))
(t
(setq man (fpround man))
(setq expo (+ -2 *m (max (cadr a) (cadr b))))
(list man expo))))))
;;; ----------------------------------------------------------------------------
(defprop mtimes timesbigfloat floatprog)
(defun timesbigfloat (args)
(let ((fans (fpone))
nfans)
(do ((l args (cdr l)))
((null l)
(if (null nfans)
(bcons fans)
(muln (cons (bcons fans) nfans) nil)))
(if (bigfloatp (car l))
(setq fans (fpmul (cdr (check-bigfloat (car l))) fans))
(setq nfans (cons (car l) nfans))))))
(defun fpmul (a b)
(if (or (zerop (car a)) (zerop (car b)))
(intofp 0)
(list (fpround (* (car a) (car b)))
(+ *m (cadr a) (cadr b) (- fpprec)))))
;;; ----------------------------------------------------------------------------
(defun fpexp* (arg)
(fpend (let ((fpprec (+ 8 fpprec)))
(if (bigfloatp arg)
(fpexp (cdr (check-bigfloat arg)))
(list '(mexpt) '$%e arg)))))
(defun fpexp (x)
(if (< (car x) 0)
(fpdiv (fpone) (fpexp (fpminus x)))
(let ((n (fpintpart x)))
(cond ((< n 2)
(fpexp1 x))
(t
(fpmul (fpexp1 (fpsub x (intofp n)))
(cdr (check-bigfloat
(let ((fpprec (+ fpprec (integer-length n) -1))
(n n))
(bcons (fpexpt (fpe) n)))))))))))
(defun fpexp1 (x)
(do ((n 1 (1+ n))
(ans (fpone))
(term (fpone))
oans)
((equal ans oans) ans)
(setq term (fpdiv (fpmul x term) (intofp n)))
(setq oans ans)
(setq ans (fpadd ans term))))
;;; ----------------------------------------------------------------------------
(defun exptbigfloat (p n)
(declare (special $numer $float $keepfloat $ratprint))
(cond ((eql n 1) p)
((eql n 0) ($bfloat 1))
((not (bigfloatp p)) (list '(mexpt) p n))
((eql (cadr p) 0) ($bfloat 0))
((and (< (cadr p) 0)
(ratnump n))
(mul (let ($numer $float $keepfloat $ratprint)
(power -1 n))
(exptbigfloat (bcons (fpminus (cdr p))) n)))
((and (< (cadr p) 0)
(not (integerp n)))
(cond ((or (eql n 0.5) (equal n bfhalf))
(exptbigfloat p '((rat simp) 1 2)))
((or (eql n -0.5) (equal n bfmhalf))
(exptbigfloat p '((rat simp) -1 2)))
((bigfloatp (setq n ($bfloat n)))
(cond ((equal n ($bfloat (fpentier n)))
(exptbigfloat p (fpentier n)))
(t
(setq p (exptbigfloat (bcons (fpminus (cdr p))) n)
n ($bfloat `((mtimes) $%pi ,n)))
(add ($bfloat `((mtimes) ,p ,(fpsin* n nil)))
`((mtimes simp)
,($bfloat `((mtimes) ,p ,(fpsin* n t)))
$%i)))))
(t (list '(mexpt) p n))))
((and (ratnump n)
(< (caddr n) 10))
(bcons (fpexpt (fproot p (caddr n)) (cadr n))))
((not (integerp n))
(setq n ($bfloat n))
(cond ((not (bigfloatp n)) (list '(mexpt) p n))
(t
(let ((extrabits (max 1 (+ (caddr n)
(integer-length (caddr p))))))
(setq p
(let ((fpprec (+ extrabits fpprec)))
(fpexp (fpmul (cdr (check-bigfloat n))
(fplog (cdr (check-bigfloat p)))))))
(setq p
(list (fpround (car p))
(+ (- extrabits) *m (cadr p))))
(bcons p)))))
((< n 0) (invertbigfloat (exptbigfloat p (- n))))
(t (bcons (fpexpt (cdr p) n)))))
(defun fpexpt (p nn)
(cond ((zerop nn) (fpone))
((eql nn 1) p)
((< nn 0) (fpdiv (fpone) (fpexpt p (- nn))))
(t
(prog (u)
(if (oddp nn)
(setq u p)
(setq u (fpone)))
(do ((ii (truncate nn 2) (truncate ii 2)))
((zerop ii))
(setq p (fpmul p p))
(when (oddp ii) (setq u (fpmul u p))))
(return u)))))
;;; ----------------------------------------------------------------------------
(defun fpsub (a b)
(fpadd a (fpminus b)))
;;; ----------------------------------------------------------------------------
(defun fpminus (x)
(if (eql (car x) 0)
x
(list (- (car x)) (cadr x))))
;;; ----------------------------------------------------------------------------
(defun invertbigfloat (a)
(if (bigfloatp a)
(bcons (fpdiv (fpone) (cdr (check-bigfloat a))))
(simplifya (list '(mexpt) a -1) nil)))
(defun fpdiv (a b)
(cond ((eql (car b) 0)
(merror "pquotient: attempted quotient by zero."))
((eql (car a) 0) (intofp 0))
(t
(list (fpround (truncate (fpshift (car a) (+ 3 fpprec)) (car b)))
(+ -3 (- (cadr a) (cadr b)) *m)))))
;;; ----------------------------------------------------------------------------
(defun fpgreaterp (a b)
(fpposp (fpsub a b)))
(defun fplessp (a b)
(fpposp (fpsub b a)))
(defun fpposp (x)
(> (car x) 0))
;;; ----------------------------------------------------------------------------
(defun fpmin (arg1 &rest args)
(let ((min arg1))
(mapc #'(lambda (u) (if (fplessp u min) (setq min u))) args)
min))
(defun fpmax (arg1 &rest args)
(let ((max arg1))
(mapc #'(lambda (u) (if (fpgreaterp u max) (setq max u))) args)
max))
;;; ----------------------------------------------------------------------------
(defun fpone ()
(cond (*decfp* (intofp 1))
((= fpprec (caddar bigfloatone)) (cdr bigfloatone))
(t (intofp 1))))
;;; ----------------------------------------------------------------------------
(let ((table (make-hash-table)))
(defun fpe ()
(labels ((compe (prec)
(let (s h (n 1) d (k (isqrt prec)))
(setq h (ash 1 prec))
(setq s h)
(do ((i k (+ i k)))
((zerop h))
(setq d (do ((j 1 (1+ j)) (p i))
((> j (1- k)) (* p n))
(setq p (* p (- i j)))) )
(setq n (do ((j (- k 2) (1- j)) (p 1))
((< j 0) p)
(setq p (1+ (* p (- i j))))))
(setq h (truncate (* h n) d))
(setq s (+ s h)))
s))
(fpe1 ()
(bcons (list (fpround (compe (+ fpprec 12))) (+ -12 *m)))))
(let ((value (gethash fpprec table)))
(if value
value
(setf (gethash fpprec table) (cdr (fpe1))))))))
;;; ----------------------------------------------------------------------------
(let ((table (make-hash-table)))
(defun fppi ()
(labels ((fprt18231 ()
(let ((a 1823176476672000))
(setq a (ash a (* 2 fpprec)))
(destructuring-bind (mantissa expo)
(intofp (isqrt a))
(list mantissa (- expo fpprec)))))
(comppi (prec)
(let (s h n d)
(setq s (ash 13591409 prec))
(setq h (neg (truncate (ash 67047785160 prec)
262537412640768000)))
(setq s (+ s h))
(do ((i 2 (1+ i)))
((zerop h))
(setq n (* 12
(- (* 6 i) 5)
(- (* 6 i) 4)
(- (* 2 i) 1)
(- (* 6 i) 1)
(+ (* i 545140134) 13591409)))
(setq d (* (- (* 3 i) 2)
(expt i 3)
(- (* i 545140134) 531548725)
262537412640768000))
(setq h (neg (truncate (* h n) d)))
(setq s (+ s h)))
s))
(fppi1 ()
(bcons (fpdiv (fprt18231)
(list (fpround (comppi (+ fpprec 12)))
(+ -12 *m))))))
(let ((value (gethash fpprec table)))
(if value
value
(setf (gethash fpprec table) (cdr (fppi1))))))))
;;; ----------------------------------------------------------------------------
(let ((table (make-hash-table)))
(defun fpgamma ()
(labels ((compgamma (prec)
(let* ((fpprec prec)
(big-n (floor (* 1/4 prec (log 2.0))))
(big-n-sq (intofp (* big-n big-n)))
(beta 3.591121476668622136649223)
(limit (floor (* beta big-n)))
(one (fpone))
(term (intofp 1))
(harmonic (intofp 0))
(a-sum (intofp 0))
(b-sum (intofp 1)))
(do ((n 1 (1+ n)))
((> n limit))
(let ((bf-n (intofp n)))
(setf term (fpdiv (fpmul term big-n-sq)
(fpmul bf-n bf-n)))
(setf harmonic (fpadd harmonic (fpdiv one bf-n)))
(setf a-sum (fpadd a-sum (fpmul term harmonic)))
(setf b-sum (fpadd b-sum term))))
(fpadd (fpdiv a-sum b-sum)
(fpminus (fplog (intofp big-n))))))
(fpgamma1 ()
(bcons (list (fpround (first (compgamma (+ fpprec 8)))) 0))))
(let ((value (gethash fpprec table)))
(if value
value
(setf (gethash fpprec table) (cdr (fpgamma1))))))))
;;; ----------------------------------------------------------------------------
(let ((table (make-hash-table)))
(defun fplog2 ()
(labels ((fast-atanh (k)
(let* ((term (fpdiv (intofp 1) (intofp k)))
(fact (fpmul term term))
(oldsum (intofp 0))
(sum term))
(loop for m from 3 by 2
until (equal oldsum sum)
do
(setf oldsum sum)
(setf term (fpmul term fact))
(setf sum (fpadd sum (fpdiv term (intofp m)))))
sum))
(comp-log2 ()
(let ((result
(let ((fpprec (+ fpprec 8)))
(fpadd (fpsub (fpmul (intofp 18) (fast-atanh 26))
(fpmul (intofp 2) (fast-atanh 4801)))
(fpmul (intofp 8) (fast-atanh 8749))))))
(list (fpround (car result))
(+ -8 *m)))))
(let ((value (gethash fpprec table)))
(if value
value
(setf (gethash fpprec table) (comp-log2)))))))
;;; ----------------------------------------------------------------------------
(defun fpentier (x)
(let ((fpprec (caddar x)))
(fpintpart (cdr x))))
;;; ----------------------------------------------------------------------------
(defprop mabs mabsbigfloat floatprog)
(defun mabsbigfloat (arg)
(if (bigfloatp (setq arg (car arg)))
(bcons (fpabs (cdr (check-bigfloat arg))))
(list '(mabs) arg)))
(defun fpabs (x)
(if (>= (car x) 0)
x
(cons (- (car x)) (cdr x))))
;;; ----------------------------------------------------------------------------
(defun big-float-sqrt (x &optional y)
(if y
(multiple-value-bind (u v)
(complex-sqrt x y)
(add (bcons u) (mul '$%i (bcons v))))
(let ((fp-x (cdr (check-bigfloat x))))
(if (fplessp fp-x (intofp 0))
(mul '$%i (bcons (fproot (bcons (fpminus fp-x)) 2)))
(bcons (fproot x 2))))))
(defun complex-sqrt (xx yy)
(let* ((x (cdr (check-bigfloat xx)))
(y (cdr (check-bigfloat yy)))
(rho (fpadd (fpmul x x)
(fpmul y y))))
(setf rho (fpadd (fpabs x) (fproot (bcons rho) 2)))
(setf rho (fpadd rho rho))
(setf rho (fpdiv (fproot (bcons rho) 2) (intofp 2)))
(let ((eta rho)
(nu y))
(when (fpgreaterp rho (intofp 0))
(setf nu (fpdiv (fpdiv nu rho) (intofp 2)))
(when (fplessp x (intofp 0))
(setf eta (fpabs nu))
(setf nu (if (minusp (car y))
(fpminus rho)
rho))))
(values eta nu))))
(defun fproot (a n)
(if (eq (cadr a) 0)
(intofp 0)
(progn
(let* ((ofprec fpprec)
(fpprec (+ fpprec 2))
(bk (fpexpt
(intofp 2)
(1+ (truncate
(cadr (setq a (cdr (check-bigfloat a)))) n)))))
(do ((x bk (fpsub
x
(setq bk
(fpdiv
(fpsub x (fpdiv a (fpexpt x n1)))
n))))
(n1 (1- n))
(n (intofp n)))
((or (equal bk '(0 0))
(> (- (cadr x) (cadr bk)) ofprec))
(setq a x))))
(list (fpround (car a)) (+ -2 *m (cadr a))))))
;;; ----------------------------------------------------------------------------
(defun big-float-log (x &optional y)
(if y
(multiple-value-bind (u v)
(complex-log x y)
(add (bcons u) (mul '$%i (bcons v))))
(flet ((%log (x)
(cdr
(let* ((extra 8)
(fpprec (+ fpprec extra))
(log-frac
(fplog (list (ash (car x) extra) 0)))
(log-exp (fpmul (intofp (second x)) (fplog2)))
(result (bcons (fpadd log-frac log-exp))))
(let ((fpprec (- fpprec extra)))
(check-bigfloat result))))))
(let ((fp-x (cdr (check-bigfloat x))))
(if (fplessp fp-x (intofp 0))
(add (bcons (%log (fpminus fp-x)))
(mul '$%i (bcons (fppi))))
(bcons (%log fp-x)))))))
(defun complex-log (x y)
(let* ((x (cdr (check-bigfloat x)))
(y (cdr (check-bigfloat y)))
(t1 (let (($float2bf t)) (float2fp 1.2)))
(t2 (intofp 3))
(rho (fpadd (fpmul x x) (fpmul y y)))
(abs-x (fpabs x))
(abs-y (fpabs y))
(beta (fpmax abs-x abs-y))
(theta (fpmin abs-x abs-y)))
(values (if (or (fpgreaterp t1 beta)
(fplessp rho t2))
(fpdiv
(fplog1p (fpadd (fpmul (fpsub beta (fpone))
(fpadd beta (fpone)))
(fpmul theta theta)))
(intofp 2))
(fpdiv (fplog rho) (intofp 2)))
(fpatan2 y x))))
(defprop %log logbigfloat floatprog)
(defun logbigfloat (a)
(cond ((bigfloatp (car a))
(big-float-log ($bfloat (car a))))
(t
(list '(%log) (car a)))))
(defun fplog (x)
(prog (over two ans oldans term e sum)
(unless (> (car x) 0)
(merror "fplog: argument must be positive; found: ~M" (car x)))
(setq e (fpe)
over (fpdiv (fpone) e)
ans 0)
(do ()
(nil)
(cond ((equal x e) (setq x nil) (return nil))
((and (fplessp x e) (fplessp over x))
(return nil))
((fplessp x over)
(setq x (fpmul x e))
(decf ans))
(t
(incf ans)
(setq x (fpdiv x e)))))
(when (null x) (return (intofp (1+ ans))))
(setq x (fpsub x (fpone))
ans (intofp ans))
(setq x
(fpexpt (setq term (fpdiv x (fpadd x (setq two (intofp 2)))))
2))
(setq sum (intofp 0))
(do ((n 1 (+ n 2)))
((equal sum oldans))
(setq oldans sum)
(setq sum (fpadd sum (fpdiv term (intofp n))))
(setq term (fpmul term x)))
(return (fpadd ans (fpmul two sum)))))
(defun fplog1p (x)
(cond ((fpgreaterp (fpabs x) (fpone))
(fplog (fpadd x (fpone))))
(t
(let* ((sum (intofp 0))
(term (fpdiv x (fpadd x (intofp 2))))
(f (fpmul term term))
(oldans nil))
(do ((n 1 (+ n 2)))
((equal sum oldans))
(setq oldans sum)
(setq sum (fpadd sum (fpdiv term (intofp n))))
(setq term (fpmul term f)))
(fpmul sum (intofp 2))))))
;;; ----------------------------------------------------------------------------
(defprop %sin sinbigfloat floatprog)
(defun sinbigfloat (x)
(fpsin* (car x) t))
(defun fpsin* (a fl)
(fpend (let ((fpprec (+ 8 fpprec)))
(cond ((bigfloatp a) (fpsin (cdr (check-bigfloat a)) fl))
(fl (list '(%sin) a))
(t (list '(%cos) a))))))
(defun fpsin (x fl)
(prog (piby2 r sign res k *cancelled)
(setq sign (cond (fl (> (car x) 0))
(t))
x (fpabs x))
(when (eql (car x) 0)
(return (if fl (intofp 0) (intofp 1))))
(return
(cdr
(check-bigfloat
(let ((fpprec (max fpprec (+ fpprec (cadr x))))
(xt (bcons x))
(*cancelled 0)
(oldprec fpprec))
(prog (x)
loop
(setq x (cdr (check-bigfloat xt)))
(setq piby2 (fpdiv (fppi) (intofp 2)))
(setq r (fpintpart (fpdiv x piby2)))
(setq x (fpadd x (fpmul (intofp (- r)) piby2)))
(setq k *cancelled)
(fpadd x (fpminus piby2))
(setq *cancelled (max k *cancelled))
(cond ((not (> oldprec (- fpprec *cancelled)))
(setq r (rem r 4))
(setq res
(cond (fl
(cond ((= r 0) (fpsin1 x))
((= r 1) (fpcos1 x))
((= r 2) (fpminus (fpsin1 x)))
((= r 3) (fpminus (fpcos1 x)))))
(t
(cond ((= r 0) (fpcos1 x))
((= r 1) (fpminus (fpsin1 x)))
((= r 2) (fpminus (fpcos1 x)))
((= r 3) (fpsin1 x))))))
(return (bcons (if sign res (fpminus res)))))
(t
(incf fpprec *cancelled)
(go loop))))))))))
(defun fpcos1 (x)
(fpsincos1 x nil))
(defun fpsin1(x)
(fpsincos1 x t))
(defun fpsincos1 (x fl)
(prog (ans term oans x2)
(setq ans (if fl x (intofp 1))
x2 (fpminus(fpmul x x)))
(setq term ans)
(do ((n (if fl 3 2) (+ n 2)))
((equal ans oans))
(setq term (fpmul term (fpdiv x2 (intofp (* n (1- n))))))
(setq oans ans
ans (fpadd ans term)))
(return ans)))
;;; ----------------------------------------------------------------------------
(defprop %cos cosbigfloat floatprog)
(defun cosbigfloat (x)
(fpsin* (car x) nil))
;;; ----------------------------------------------------------------------------
(defprop %tan tanbigfloat floatprog)
(defun tanbigfloat (a)
(fpend (let ((fpprec (+ 8 fpprec)))
(cond ((bigfloatp (setq a (car a)))
(setq a (cdr (check-bigfloat a)))
(fpdiv (fpsin a t) (fpsin a nil)))
(t (list '(%tan) a))))))
;;; ----------------------------------------------------------------------------
(defun big-float-asin (x &optional y)
(if y
(multiple-value-bind (u v)
(complex-asin x y)
(add u (mul '$%i v)))
(fpasin x)))
(defun complex-asin (x y)
(let ((x (cdr (check-bigfloat x)))
(y (cdr (check-bigfloat y))))
(multiple-value-bind (re-sqrt-1-z im-sqrt-1-z)
(complex-sqrt (bcons (fpsub (intofp 1) x))
(bcons (fpminus y)))
(multiple-value-bind (re-sqrt-1+z im-sqrt-1+z)
(complex-sqrt (bcons (fpadd (intofp 1) x))
(bcons y))
(values (bcons (let ((d (fpsub (fpmul re-sqrt-1-z re-sqrt-1+z)
(fpmul im-sqrt-1-z im-sqrt-1+z))))
(cond ((eql (car d) 0)
(if (fplessp x '(0 0))
(fpminus (fpdiv (fppi) (intofp 2)))
(fpdiv (fppi) (intofp 2))))
(t (fpatan (fpdiv x d))))))
(fpasin (bcons (fpsub (fpmul re-sqrt-1-z im-sqrt-1+z)
(fpmul im-sqrt-1-z re-sqrt-1+z)))))))))
(defun fpasin (x)
($bfloat (fpasin-core x)))
(defun fpasin-core (x)
(let ((fp-x (cdr (check-bigfloat x))))
(cond ((minusp (car fp-x))
(mul -1 (fpasin (bcons (fpminus fp-x)))))
((fplessp fp-x (cdr bfhalf))
(bcons (fpatan (fpdiv fp-x
(fproot (bcons (fpmul (fpsub (fpone) fp-x)
(fpadd (fpone) fp-x)))
2)))))
((fpgreaterp fp-x (fpone))
(let ((arg (fpadd fp-x
(fproot (bcons (fpmul (fpsub fp-x (fpone))
(fpadd fp-x (fpone))))
2))))
(add (div '$%pi 2)
(mul -1 '$%i (bcons (fplog arg))))))
(t
(add (div '$%pi 2)
(mul -1
(bcons
(fpatan
(fpdiv (fproot (bcons (fpmul (fpsub (fpone) fp-x)
(fpadd (fpone) fp-x)))
2)
fp-x)))))))))
;;; ----------------------------------------------------------------------------
(defun big-float-acos (x &optional y)
(if y
(multiple-value-bind (u v)
(complex-acos x y)
(add u (mul '$%i v)))
(fpacos x)))
(defun complex-acos (x y)
(let ((x (cdr (check-bigfloat x)))
(y (cdr (check-bigfloat y))))
(multiple-value-bind (re-sqrt-1-z im-sqrt-1-z)
(complex-sqrt (bcons (fpsub (intofp 1) x))
(bcons (fpminus y)))
(multiple-value-bind (re-sqrt-1+z im-sqrt-1+z)
(complex-sqrt (bcons (fpadd (intofp 1) x))
(bcons y))
(values (bcons (fpmul (intofp 2)
(fpatan (fpdiv re-sqrt-1-z re-sqrt-1+z))))
(fpasinh (bcons (fpsub (fpmul re-sqrt-1+z im-sqrt-1-z)
(fpmul im-sqrt-1+z re-sqrt-1-z)))))))))
(defun fpacos (x)
($bfloat (add (div '$%pi 2) (mul -1 (fpasin-core x)))))
;;; ----------------------------------------------------------------------------
(defprop %atan atanbigfloat floatprog)
(defun atanbigfloat (x)
(fpatan* (car x) (cdr x)))
(defun fpatan* (a y)
(fpend (let ((fpprec (+ 8 fpprec)))
(if (null y)
(if (bigfloatp a)
(fpatan (cdr (check-bigfloat a)))
(list '(%atan) a))
(fpatan2 (cdr (check-bigfloat a))
(cdr (check-bigfloat (car y))))))))
(defun fpatan (x)
(prog (term x2 ans oans one two tmp)
(setq one (intofp 1) two (intofp 2))
(cond ((fpgreaterp (fpabs x) one)
(setq tmp (fpdiv (fppi) two))
(setq ans (fpsub tmp (fpatan (fpdiv one x))))
(return (cond ((fplessp x (intofp 0))
(fpsub ans (fppi)))
(t ans))))
((fpgreaterp (fpabs x) (fpdiv one two))
(setq tmp (fpdiv x (fpadd (fpmul x x) one)))
(setq x2 (fpmul x tmp) term (setq ans one))
(do ((n 0 (1+ n)))
((equal ans oans))
(setq term
(fpmul term
(fpmul x2
(fpdiv (intofp (+ 2 (* 2 n)))
(intofp (+ (* 2 n) 3))))))
(setq oans ans
ans (fpadd term ans)))
(setq ans (fpmul tmp ans)))
(t
(setq ans x
x2 (fpminus (fpmul x x)) term x)
(do ((n 3 (+ n 2)))
((equal ans oans))
(setq term (fpmul term x2))
(setq oans ans
ans (fpadd ans (fpdiv term (intofp n)))))))
(return ans)))
(defun fpatan2 (y x)
(cond ((eql (car x) 0)
(cond ((equal (car y) 0)
(merror "atan2: atan2(0, 0) is undefined."))
((minusp (car y))
(fpdiv (fppi) (intofp -2)))
(t
(fpdiv (fppi) (intofp 2)))))
((> (car x) 0)
(fpatan (fpdiv y x)))
((> (car y) 0)
(fpadd (fppi) (fpatan (fpdiv y x))))
(t
(fpsub (fpatan (fpdiv y x)) (fppi)))))
;;; ----------------------------------------------------------------------------
(defun big-float-sinh (x &optional y)
(unless y
(fpsinh x)))
(defun fpsinh (x)
(cond ((eql 0 (cadr x))
(check-bigfloat x))
((fpposp (cdr x))
(let ((d (fpexpm1 (cdr (check-bigfloat x)))))
(bcons (fpdiv (fpadd d (fpdiv d (fpadd d (fpone))))
(intofp 2)))))
(t
(bcons
(fpminus
(cdr (fpsinh (bcons (fpminus (cdr (check-bigfloat x)))))))))))
(defun fpexpm1 (x)
(cond ((fpgreaterp (fpabs x) (fpone))
(fpsub (fpexp x) (fpone)))
(t
(let ((ans x)
(oans nil)
(term x))
(do ((n 2 (1+ n)))
((equal ans oans))
(setf term (fpdiv (fpmul x term) (intofp n)))
(setf oans ans)
(setf ans (fpadd ans term)))
ans))))
;;; ----------------------------------------------------------------------------
(defun big-float-tanh (x &optional y)
(if y
(multiple-value-bind (u v)
(complex-tanh x y)
(add u (mul '$%i v)))
(fptanh x)))
(defun complex-tanh (x y)
(let* ((tv (cdr (tanbigfloat (list y))))
(beta (fpadd (fpone) (fpmul tv tv)))
(s (cdr (fpsinh x)))
(s^2 (fpmul s s))
(rho (fproot (bcons (fpadd (fpone) s^2)) 2))
(den (fpadd (fpone) (fpmul beta s^2))))
(values (bcons (fpdiv (fpmul beta (fpmul rho s)) den))
(bcons (fpdiv tv den)))))
(defun fptanh (x)
(let* ((two (intofp 2))
(fp (cdr (check-bigfloat x)))
(d (fpexpm1 (fpmul fp two))))
(bcons (fpdiv d (fpadd d two)))))
;;; ----------------------------------------------------------------------------
(defun big-float-asinh (x &optional y)
(if y
(multiple-value-bind (u v)
(complex-asinh x y)
(add u (mul '$%i v)))
(fpasinh x)))
(defun complex-asinh (x y)
(multiple-value-bind (u v)
(complex-asin (mul -1 y) x)
(values v (bcons (fpminus (cdr u))))))
(defun fpasinh (x)
(let* ((fp-x (cdr (check-bigfloat x)))
(absx (fpabs fp-x))
(one (fpone))
(two (intofp 2))
(minus (minusp (car fp-x)))
result)
(cond ((fpgreaterp absx two)
(setf result
(fplog
(fpadd (fpmul absx two)
(fpdiv one
(fpadd absx
(fproot (bcons (fpadd one
(fpmul absx
absx)))
2)))))))
(t
(let ((x*x (fpmul absx absx)))
(setq result
(fplog1p
(fpadd absx
(fpdiv x*x
(fpadd one
(fproot (bcons (fpadd one x*x))
2)))))))))
(if minus
(bcons (fpminus result))
(bcons result))))
;;; ----------------------------------------------------------------------------
(defun big-float-atanh (x &optional y)
(if y
(multiple-value-bind (u v)
(complex-atanh x y)
(add u (mul '$%i v)))
(fpatanh x)))
(defun complex-atanh (x y)
(let* ((fpx (cdr (check-bigfloat x)))
(fpy (cdr (check-bigfloat y)))
(beta (if (minusp (car fpx))
(fpminus (fpone))
(fpone)))
(x-lt-minus-1 (fplessp (fpadd fpx (fpone)) '(0 0)))
(x-gt-plus-1 (fpgreaterp fpy (fpone)))
(y-equals-0 (equal y '((bigfloat) 0 0)))
(x (fpmul beta fpx))
(y (fpmul beta (fpminus fpy)))
(rho (intofp 0))
(t1 (fpadd (fpabs y) rho))
(t1^2 (fpmul t1 t1))
(1-x (fpsub (fpone) x))
(eta (fpdiv (fplog1p (fpdiv (fpmul (intofp 4) x)
(fpadd (fpmul 1-x 1-x) t1^2)))
(intofp 4)))
(nu (if y-equals-0
(fpminus
(if x-lt-minus-1
(cdr ($bfloat '((mquotient) $%pi 2)))
(if x-gt-plus-1
(cdr ($bfloat '((mminus) ((mquotient) $%pi 2))))
(merror "COMPLEX-ATANH: HOW DID I GET HERE?"))))
(fpmul (cdr bfhalf)
(fpatan2 (fpmul (intofp 2) y)
(fpsub (fpmul 1-x (fpadd (fpone) x))
t1^2))))))
(values (bcons (fpmul beta eta))
(bcons (fpminus (fpmul beta nu))))))
(defun fpatanh (x)
(let* ((fp-x (cdr (check-bigfloat x))))
(cond ((fplessp fp-x (intofp 0))
(mul -1 (fpatanh (bcons (fpminus fp-x)))))
((fpgreaterp fp-x (fpone))
(multiple-value-bind (u v)
(complex-atanh x (bcons (intofp 0)))
(add u (mul '$%i v))))
((fpgreaterp fp-x (cdr bfhalf))
(bcons (fpmul (cdr bfhalf)
(fplog1p (fpdiv (fpmul (intofp 2) fp-x)
(fpsub (fpone) fp-x))))))
(t
(let ((2x (fpmul (intofp 2) fp-x)))
(bcons (fpmul (cdr bfhalf)
(fplog1p (fpadd 2x
(fpdiv (fpmul 2x fp-x)
(fpsub (fpone)
fp-x)))))))))))
;;; ----------------------------------------------------------------------------
(defprop bigfloat msize-bigfloat grind)
(defun msize-bigfloat (x l r)
(msz (fpformat x) l r))
(defun dim-bigfloat (form result)
(declare (special $lispdispflag))
(let (($lispdispflag nil))
(dimension-string (fpformat form) result)))
(defun fpformat (l)
(if (not (member 'simp (cdar l) :test #'eq))
(setq l (cons (cons (caar l) (cons 'simp (cdar l))) (cdr l))))
(cond ((eql (cadr l) 0)
(if (not (eql (caddr l) 0))
(merror "fpformat: detected an incorrect form of 0.0b0: ~M, ~M~%"
(cadr l) (caddr l)))
(list #\0 #\. #\0 #\b #\0))
(t
(let ((extradigs (floor (1+ (/ (integer-length (caddr l))
#.(/ (log 10.0) (log 2.0))))))
(*m 1)
(*cancelled 0))
(setq l
(let ((*decfp* t)
(fpprec (+ extradigs (decimalsin (- (caddar l) 2))))
(of (caddar l))
(l (cdr l))
(expon nil))
(setq expon (- (cadr l) of))
(setq l (if (minusp expon)
(fpdiv (intofp (car l))
(fpintexpt 2 (- expon) of))
(fpmul (intofp (car l))
(fpintexpt 2 expon of))))
(incf fpprec (- extradigs))
(list (fpround (car l)) (+ (- extradigs) *m (cadr l))))))
(let ((*print-base* 10)
*print-radix*
(l1 nil))
(setq l1 (if (not $bftrunc)
(coerce (print-invert-case (car l)) 'list)
(do ((l (nreverse
(coerce (print-invert-case (car l)) 'list))
(cdr l)))
((not (eql #\0 (car l))) (nreverse l)))))
(nconc (ncons (car l1))
(ncons #\. )
(or (and (cdr l1)
(cond ((or (zerop $fpprintprec)
(not (< $fpprintprec $fpprec))
(null (cddr l1)))
(cdr l1))
(t
(setq l1 (cdr l1))
(do ((i $fpprintprec (1- i))
(l2))
((or (< i 2) (null l1))
(cond ((not $bftrunc) (nreverse l2))
(t
(do ((l3 l2 (cdr l3)))
((not (eql #\0 (car l3)))
(nreverse l3))))))
(setq l2 (cons (car l1) l2)
l1 (cdr l1))))))
(ncons #\0))
(ncons #\b)
(coerce (print-invert-case (1- (cadr l))) 'list))))))
(defun decimalsin (x)
(do ((i (truncate (* 59 x) 196) (1+ i)))
(nil)
(when (> (integer-length (expt 10 i)) x)
(return (1- i)))))
(defun fpintexpt (int nn fixprec)
(setq fixprec (truncate fixprec (1- (integer-length int))))
(let ((bas (intofp (expt int (min nn fixprec)))))
(if (> nn fixprec)
(fpmul (intofp (expt int (rem nn fixprec)))
(fpexpt bas (truncate nn fixprec)))
bas)))
;;; ----------------------------------------------------------------------------
(eval-when (:load-toplevel :execute)
(fpprec1 nil $fpprec))
;;; ----------------------------------------------------------------------------
B.13 mload.lisp
;;; ----------------------------------------------------------------------------
;;; mload.lisp
;;;
;;; Copyright (C) 2011 Dr. Dieter Kaiser
;;;
;;; This file contains modified code from:
;;;
;;; Copyright (C) 1984, 1987 William Schelter, University of Texas
;;; Copyright (C) 1982 Massachusetts Institute of Technology
;;;
;;; This program is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2 of the License, or
;;; (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
;;; ----------------------------------------------------------------------------
(in-package :kmaxima)
(defmvar $file_search_lisp '((mlist simp)))
(defmvar $file_search_maxima '((mlist simp)))
(defmvar $file_search_demo '((mlist simp)))
(defmvar $file_search_tests
'((mlist simp)
"/home/dieter/Lisp/kMaxima/kmaxima/tests/###.{mac,mc}"))
(defmvar $testsuite_files nil)
(defparameter *maxima-testsdir* "/home/dieter/Lisp/kMaxima/kmaxima/tests")
;;; ----------------------------------------------------------------------------
(defun split-string (string bag &optional (start 0) &aux all pos v l)
(declare (fixnum start) (type string string))
(loop for i from start below (length string)
do
(setq pos (position (setq v (aref string i)) bag))
(setq start (+ start 1))
(cond ((null pos) (push v all))
(t (if all (loop-finish))))
finally
(if all
(return-from split-string
(cons (make-array (setq l (length all))
:fill-pointer l
:adjustable t
:initial-contents (nreverse all)
:element-type
' #.(array-element-type "ab"))
(split-string string bag start))))))
(defun alter-pathname (pathname &rest options)
(apply 'make-pathname :defaults (pathname pathname) options))
;;; ----------------------------------------------------------------------------
(defun list-variable-bindings (expr &optional str &aux tem)
(loop for v in (cdr ($listofvars expr))
when (member v $values :test #'equal)
collecting (setq tem `((mequal) ,v ,(meval* v)))
and
do (cond (str (format str ",")(mgrind tem str)))))
;;; ----------------------------------------------------------------------------
(defun $filename_merge (&rest file-specs)
(when (or (null file-specs)
(cddr file-specs))
(wna-err '$filename_merge))
(setq file-specs (mapcar #'macsyma-namestring-sub file-specs))
(pathname (if (null (cdr file-specs))
(car file-specs)
(merge-pathnames (cadr file-specs) (car file-specs)))))
(defun macsyma-namestring-sub (user-object)
(if (pathnamep user-object)
user-object
(let* ((system-object
(cond ((and (atom user-object)
(not (symbolp user-object)))
user-object)
((atom user-object)
(print-invert-case (fullstrip1 user-object)))
((mlistp user-object)
(fullstrip (cdr user-object)))
(t
(merror "filename_merge: unexpected argument: ~A"
user-object))))
(namestring-try (errset-namestring system-object)))
(if namestring-try
(car namestring-try)
(merror "filename_merge: unexpected argument: ~:M"
user-object)))))
(defun errset-namestring (x)
(let ((*errset* nil))
(errset (pathname x) nil)))
;;; ----------------------------------------------------------------------------
(defun $file_search (name &optional paths)
(if (and (symbolp name)
(member (char (symbol-name name) 0) '(#\$) ))
(setq name (subseq (print-invert-case name) 1)))
(if (symbolp name)
(setf name (string name)))
(if (probe-file name)
(return-from $file_search name))
(unless paths
(setq paths
(cons '(mlist simp)
(append (cdr $file_search_lisp)
(cdr $file_search_maxima)
(cdr $file_search_demo)))))
(unless (mlistp paths)
(merror "file_search: The argument `paths' must be a list."))
(file-search (string name) (cdr paths)))
(defun file-search (name template)
(cond ((probe-file name))
((and (not (null template))
(atom template))
(let ((lis (loop for w in (split-string template "{}")
when (null (position #\, w))
collect w
else
collect (split-string w ","))))
(file-search1 name "" lis)))
(t
(let ((temp nil))
(loop for v in template
when (setq temp (file-search name v))
do (return temp))))))
(defun file-search1 (name begin lis)
(cond ((null lis)
(let ((file (namestring ($filename_merge begin name))))
(if (probe-file file) file nil)))
((atom (car lis))
(file-search1 name
(if begin
(concatenate 'string begin (car lis))
(car lis))
(cdr lis)))
(t
(loop for v in (car lis) with tem
when (setq tem
(file-search1 name begin (cons v (cdr lis))))
do (return tem)))))
;;; ----------------------------------------------------------------------------
(defun lispify-maxima-keyword-options (options &optional valid-keywords)
(unless (listp options)
(merror "run_testsuite: Invalid Maxima keyword options: ~A" options))
(when (every #'(lambda (o)
(let ((ok (and (listp o)
(= (length o) 3)
(eq (caar o) 'mequal))))
(unless ok
(merror
"run_testsuite: Badly formed keyword option: ~M"
o))
ok))
options)
(mapcan #'(lambda (o)
(destructuring-bind (mequal opt val)
o
(declare (ignore mequal))
(if (or (null valid-keywords)
(member opt valid-keywords))
(flet ((keywordify (x)
(intern (subseq (symbol-name x) 1) :keyword)))
(list (keywordify opt) val))
(merror "run_testsuite: Unrecognized keyword: ~M"
opt))))
options)))
(defun $run_testsuite (&rest options)
(apply #'run-testsuite
(lispify-maxima-keyword-options options
'($display_all
$display_known_bugs
$tests $time))))
(defun run-testsuite (&key display_known_bugs display_all tests time)
(declare (special $file_search_tests))
(let ((test-file)
(expected-failures))
(unless (member display_known_bugs '(t nil))
(merror "run_testsuite: display_known_bugs must be true or false;~
found: ~A"
display_known_bugs))
(unless (member display_all '(t nil))
(merror "run_testsuite: display_all must be true or false; found: ~A"
display_all))
(unless (member time '(t nil $all))
(merror "run_testsuite: time must be true, false, or all; found: ~M"
time))
(setq *collect-errors* nil)
(unless $testsuite_files
(load (concatenate 'string *maxima-testsdir* "/" "testsuite.lisp")))
(let ((error-break-file)
(testresult)
(tests-to-run (intersect-tests tests))
(test-count 0)
(total-count 0)
(error-count 0))
(time
(loop with errs = '() for testentry in tests-to-run
do
(if (atom testentry)
(progn
(setf test-file testentry)
(setf expected-failures nil))
(progn
(setf test-file (second testentry))
(setf expected-failures (cddr testentry))))
(format t "Running tests in ~a: "
(if (symbolp test-file)
(subseq (print-invert-case test-file) 1)
test-file))
(or (errset
(progn
(multiple-value-setq (testresult test-count)
(test-batch ($file_search test-file $file_search_tests)
expected-failures
:show-expected display_known_bugs
:show-all display_all
:showtime time))
(setf testresult (rest testresult))
(incf total-count test-count)
(when testresult
(incf error-count (length (cdr testresult)))
(setq errs (append errs (list testresult))))))
(progn
(setq error-break-file (format nil "~a" test-file))
(setq errs
(append errs
(list (list error-break-file
"error break"))))
(format t "~%Caused an error break: ~a~%" test-file)))
finally
(cond ((null errs)
(format t
"~%~%No unexpected errors found out of ~:D tests.~%"
total-count))
(t
(format t "~%Error summary:~%")
(mapcar #'(lambda (x)
(let ((s (if (> (length (rest x)) 1) "s" "")))
(format t
"Error~a found in ~a, problem~a:~%~a~%"
s (first x) s (sort (rest x) #'<))))
errs)
(format t "~&~:D test~P failed out of ~:D total tests.~%"
error-count error-count total-count)))))))
'$done)
(defun intersect-tests (tests)
(flet ((remove-dollarsign (x)
(if (symbolp x)
(subseq (print-invert-case x) 1)
x)))
(mapcar #'remove-dollarsign
(cond (tests
(let ((results nil))
(dolist (test (mapcar #'remove-dollarsign (cdr tests)))
(when (find test (cdr $testsuite_files)
:key #'(lambda (x)
(print-invert-case (if (listp x)
(second x)
x)))
:test #'string= )
(push test results)))
(nreverse results)))
(t
(cdr $testsuite_files))))))
(defun test-batch (filename expected-errors
&key (out *standard-output*)
(show-expected nil)
(show-all nil) (showtime nil))
(let ((result)
(next-result)
(next)
(error-log)
(all-differences nil)
($ratprint nil)
(strm)
(*mread-prompt* "")
(expr)
(num-problems 0)
(tmp-output)
(save-output)
(i 0)
(start-run-time 0) (end-run-time 0)
(start-real-time 0) (end-real-time 0)
(test-start-run-time 0) (test-end-run-time 0)
(test-start-real-time 0) (test-end-real-time 0))
(cond (*collect-errors*
(setq error-log
(if (streamp *collect-errors*)
*collect-errors*
(handler-case
(open (alter-pathname filename :type "ERR")
:direction
:output
:if-exists
:supersede)
#-gcl (file-error () nil)
#+gcl (cl::error () nil))))
(when error-log
(format t "~%batch: write error log to ~a" error-log)
(format error-log
"~%/* Maxima error log from tests in ~A"
filename)
(format error-log " */~2%"))))
(unwind-protect
(progn
(setq strm (open filename :direction :input))
(setq start-real-time (get-internal-real-time))
(setq start-run-time (get-internal-run-time))
(while (not (eq 'eof (setq expr (mread strm 'eof))))
(incf num-problems)
(incf i)
(setf tmp-output (make-string-output-stream))
(setf save-output *standard-output*)
(setf *standard-output* tmp-output)
(unwind-protect
(progn
(setq test-start-run-time (get-internal-run-time))
(setq test-start-real-time (get-internal-real-time))
(setq result
(maxima-toplevel-eval `(($errcatch) ,(third expr))))
(setq result (if (alike1 result '((mlist)))
'error-catch
(second result)))
(setq test-end-run-time (get-internal-run-time))
(setq test-end-real-time (get-internal-real-time))
(setq $% result))
(setf *standard-output* save-output))
(setq next (mread strm 'eof))
(if (eq next 'eof)
(merror "batch: missing expected result in test script."))
(setq next-result (third next))
(let* ((correct (batch-equal-check next-result result))
(expected-error (member i expected-errors))
(pass (or correct expected-error)))
(when (or show-all (not pass) (and correct expected-error)
(and expected-error show-expected))
(format out
"~%********************** Problem ~A ***************"
i)
(format out "~%Input:~%")
(mdisplay (third expr))
(format out "~%~%Result:~%")
(format out "~a" (get-output-stream-string tmp-output))
(mdisplay $%)
(when (eq showtime '$all)
(format out "~%Time: ~,3F sec (~,3F elapsed)"
(float (/ (- test-end-run-time test-start-run-time)
internal-time-units-per-second))
(float (/ (- test-end-run-time test-start-run-time)
internal-time-units-per-second)))))
(cond ((and correct expected-error)
(format t
"~%... Which was correct, but was expected ~
to be wrong due to a known bug in~% Maxima.~%"))
(correct
(if show-all (format t "~%... Which was correct.~%")))
((and (not correct) expected-error)
(if (or show-all show-expected)
(progn
(format t
"~%This is a known error in Maxima. ~
The correct result is:~%")
(mdisplay next-result))))
(t
(format t "~%This differed from the expected result:~%")
(push i all-differences)
(mdisplay next-result)
(cond ((and *collect-errors* error-log)
(format error-log "/* Problem ~A */~%" i)
(mgrind (third expr) error-log)
(list-variable-bindings (third expr) error-log)
(format error-log ";~%")
(format error-log "/* Erroneous Result?:~%")
(mgrind result error-log) (format error-log " */ ")
(terpri error-log)
(format error-log "/* Expected result: */~%")
(mgrind next-result error-log)
(format error-log ";~%~%"))))))))
(close strm))
(setq end-run-time (get-internal-run-time))
(setq end-real-time (get-internal-real-time))
(cond (error-log
(or (streamp *collect-errors*)
(close error-log))))
(let
((expected-errors-trailer
(if (or (null expected-errors) (= (length expected-errors) 0))
""
(format nil
" (not counting ~a expected errors)"
(length expected-errors))))
(time (if showtime
(format nil " using ~,3F seconds (~,3F elapsed).~%"
(float (/ (- end-run-time start-run-time)
internal-time-units-per-second))
(float (/ (- end-real-time start-real-time)
internal-time-units-per-second)))
"")))
(cond ((null all-differences)
(format t "~a/~a tests passed~a~%~A"
num-problems num-problems
expected-errors-trailer
time)
(values '((mlist)) num-problems))
(t
(format t
"~%~a/~a tests passed~a~%~A"
(- num-problems (length all-differences))
num-problems expected-errors-trailer
time)
(let ((s (if (> (length all-differences) 1) "s" "")))
(format t
"~%The following ~A problem~A failed: ~A~%"
(length all-differences)
s
(reverse all-differences)))
(values `((mlist) ,filename ,@(reverse all-differences))
num-problems))))))
;;; ----------------------------------------------------------------------------
(defun batch-equal-check (expected result)
(let ((answer (catch 'macsyma-quit (simple-equal-p expected result))))
(if (eql answer 'maxima-error) nil answer)))
(defun simple-equal-p (f g)
(approx-alike (simplifya f nil) (simplifya g nil)))
(defun approx-alike (f g)
(cond ((floatp f)
(and (floatp g)
($float_approx_equal f g)))
((bigfloatp f)
(and (bigfloatp g)
($bfloat_approx_equal f g)))
((atom f) (and (atom g) (equal f g)))
((moperatorp f 'lambda)
(and (moperatorp g 'lambda)
(approx-alike-list (mapcar #'(lambda (s) (simplifya s nil))
(margs f))
(mapcar #'(lambda (s) (simplifya s nil))
(margs g)))))
((arrayp f)
(and (arrayp g) (approx-alike ($listarray f) ($listarray g))))
((hash-table-p f)
(and (hash-table-p g) (approx-alike ($listarray f) ($listarray g))))
((moperatorp f 'mquote)
(approx-alike (second f) g))
((and (consp f)
(consp (car f))
(consp g)
(consp (car g))
(or (approx-alike (mop f) (mop g))
(and (symbolp (mop f)) (symbolp (mop g))
(approx-alike ($nounify (mop f)) ($nounify (mop g)))))
(approx-alike-list (margs f) (margs g))))
(t nil)))
(defun approx-alike-list (p q)
(cond ((null p) (null q))
((null q) (null p))
(t
(and (approx-alike (first p) (first q))
(approx-alike-list (rest p) (rest q))))))
(defconstant flonum-epsilon double-float-epsilon)
(defmvar $float_approx_equal_tolerance (* 16 flonum-epsilon))
(defun $float_approx_equal (a b)
(setq a (if (floatp a) a ($float a)))
(setq b (if (floatp b) b ($float b)))
(and (floatp a)
(floatp b)
(<= (abs (- a b))
(* $float_approx_equal_tolerance
(min (expt 2
(- (second (multiple-value-list (decode-float a)))
1))
(expt 2
(- (second (multiple-value-list (decode-float b)))
1)))))))
(defun $bfloat_approx_equal (a b)
(setq a (if (bigfloatp a) a ($bfloat a)))
(setq b (if (bigfloatp b) b ($bfloat b)))
(let ((m) (bits))
(and (bigfloatp a)
(bigfloatp b)
(setq bits (min (third (first a)) (third (first b))))
(setq m (mul 32
(expt 2 (- bits))
(min (expt 2 (- (car (last a)) 1))
(expt 2 (- (car (last b)) 1)))))
(setq m (if (rationalp m)
(div (numerator m) (denominator m))
m))
(setq m (fpsub (cdr ($bfloat m))
(fpabs (fpsub (cdr a) (cdr b)))))
(or (eql (car m) 0)
(fpposp m)))))
;;; ----------------------------------------------------------------------------
This document was generated by Dieter Kaiser on Dezember, 13 2011 using texi2html 1.76