;; -*- Mode:Common-Lisp;Package:mma; Base:10 -*-o
;; Mathematica(tm)-like evaluator
;; copyright (c) 1990 Richard J. Fateman; pieces by Tak Yan, Derek Lai
;; hacked more 2/2011 to make it work in GCL, not complete. Need to put
;; two-case symbols within | |.
(eval-when (compile) (load "mma"))
(in-package :mma)
;;(provide 'math-eval)(require "ucons1")(require 'math-parser "parser")
;;(require "stack1") (require "disp1")(require "pf")(require "simp1")(require "rat1")(require "match")
(in-package :mma)
(eval-when (load) (export '(tl mread1))
;;**********
#+excl(import '(excl::errorset)) ;; your system may differ....
;;**********
)
(defvar COUNT 1 "line number for top-level. (same as (meval |$Line|))")
(declaim (special env *expand* *numer*)) ;; environment
;; funnyvars is a hash table containing variables which, when set,
;; cause function to be executed
(defvar funnyvars (make-hash-table :test #'eq :size 8))
(defvar emptyht (make-hash-table))
(defun tl () ;; top level
(let*
( (*package* (find-package :mma)) h hs hin
(timesofar 0)
(timeunit (/ 1.0 internal-time-units-per-second))
(env (make-stack :size 50));environment for matching binding
)
(declare (special env *package*))
(if (= COUNT 1)
(format t
"Mock-Mma (for GCL-Maxima) 3.0 (February 6, 2011) [With pre-loaded data]
Possibly Copyright 1990-2011 U.C.Berkeley
-- Terminal graphics initialized -- ~%"))
(loop
(setq timesofar (get-internal-run-time))
(format t "~%In[~s] := " COUNT) ;; actually In and Out are variables too.
;; get the input
(setq hin (handler-case (mma::p) (error(x)(format t "~%syntax error ~s" x)(clear-input t) '|Null|)))
;; evaluate it
(setq h (handler-case (meval hin)(error(x) (clrs) ;clear stack frames
(format t "~%evaluation error ~s" x)`(|Hold| , hin))))
(|SetQQ| (ulist '|In| COUNT) hin)
(setq timesofar (- (get-internal-run-time) timesofar))
;; this is not the same as mathematica but I find it more convenient
;; this way. We've also implementing "Timing", if you prefer.
(if (eq '|True| (meval '|$Showtime|))
(format t "~%time = ~3,$ secs." (* timesofar timeunit)))
(cond ((or (eql h '|Exit|)
#+GCL (eql h 'EXIT) ;; so I can get out of tl in GCL without readtable-case set properly
(and (listp h)(eq (car h) '|Quit|))) ;;Quit[]
(format t"~%Exited to Lisp~%")
(return t))
(t
(|SetQQ| (ulist '|Out| COUNT) h)
(cond((eq h '|Null|) nil)
;; don't print nil-valued answers
(t
(setq hs (list '|Set| (ulist '|Out| COUNT) h))
(disp (BuildFormat hs))))))
(|Set| '|$Line| (setq COUNT (1+ COUNT))))))
;; this definition replaces the program in the parser file
(defun mread1()
(cond((member (pc)'( #\space #\tab #\page) :test #'eql)
(rc)(mread1))
((digit-char-p (mma::pc));; next character is a digit 0-9
(mma::collect-integer
(mma::char-to-int(read-char stream)) 10)) ;radix 10 default
;; for every alphabetic symbol, set up a hash table
(t (chash #-gcl(or(read-preserving-whitespace stream nil 'e-o-l) '|False|)
#+gcl (recase(or(read-preserving-whitespace stream nil 'e-o-l) '|False|)))
;; nil reads as False
)))
;; enter a variable in the symbol table by making a hash
;; table as its value.
(defvar symtab (make-hash-table :test #'eq :size 150))
#|
We currently make each symbol table entry out of a hash table.
It's plausible to change this to use defstruct ... then
make every declared "symbol-table-entry" a structure
with (at least) the following data
(a) value for the symbol e.g. a=3 in the value cell
(b) value for expressions with the symbol as head. e.g. a[45]=x+1
we might have different "arities" e.g. a[45] has arity 1,
a[3,4] has arity=2, etc. [we don't use this now]
(c) value for the collected attributes of the symbol.
e.g. Attributes[a] ={Orderless, Protected, Listable}
(d) value for each of the attributes to make access fast with using member-test
on collected value [we don't use this now]
(e) value for function definition "built-in" e.g. numeric cosine
(f) value for user-defined function rules e.g. a[x_]:= ...
we could again use some "arity" discrimination if we expect
function definitions of different numbers of arguments. [we don't use this
now]
(g) string for symbol printing (e.g. " + " for Plus). Except that
so far the Lisp symbol-name for Plus is Plus, so we don't need this.
(h) formatting information. right now the List symbol-table entry e.g.
for Plus has the Plus formatter program stored
(i) left/right operator precedence information; display stores this as above
(k) derivative and integral info, as above
(j) messages/ documentation
(k) package? context?
If we were to revise all this we could be more specific
about possible types for the fields,
e.g. for some of these.. (c): list; (d) bit-vector;
(e) lisp-function-value; (f) list? array? (g) string; (h) program,
(k) pattern or program
|#
(defun chash(m)
(let ((*package* (find-package :mma)))
(cond
((not(symbolp m))m)
;; ((null m)nil) do we need to check for nil or t? Maybe not.
(t (cond((gethash m symtab)) ;either it's there or
(t(setf (gethash m symtab)
(make-hash-table :test #'equal :size 4)); we make a hashtable
))))
m))
;; the following stuff is make-shift.
(defun |Head| (h)(typecase h
(cons (car h))
(ratio '|Rational|)
(complex '|Complex|)
(integer '|Integer|)
;((fixnum bignum integer) '|Integer|)
;((double-float single-float) '|Real|)
(float '|Real|)
;;((rat) 'rat) ;; mockmma rat function form, e.g. Rat[x+1].
;; file descriptors? characters? graphics? arrays?
(string '|String| )
(symbol '|Symbol| )
(array '|Array|)
(rat '|Rat|) ;; special rational form
(otherwise (type-of h) )
))
;; Assignment statements treat the lhs with partial evaluation.
;; For a non-atomic Head, evaluate all the arguments, but not
;; the head. Presumably this should check attributes of the Head
;; like |HoldAll|, |Hold|First, etc. We don't do that yet,
;; 12/2010
;; but probably must do |Hold|Rest at least for RuleDelayed so Rubi can work.
;; and Release, Release|Hold|.
;; To the extent possible, I have avoiding thinking about Mma's bogus version of
;; Quote and Eval for as long as I can. for decades?
;; we evaluate the lhs partially and then the rhs.
;; we'd like to have a Quote operator, but the repeated evaluation rule
;; makes it almost impossible to work unless we check for it specially..
;; alternatively, we can set *evalonce* to t, and (vastly)
;; change the semantics. Sometimes this vast change is no change at all....
;; We evaluate args, depending on the hold-specs of the head
;; The Mathematica semantics avoids repeated evaluation by putting a time stamp
;; on each object, as well as dependencies. If the object is newer than any
;; thing it depends on, then it is already "evaluated". Otherwise it
;; has to be re-evaluated and re-time-stamped. We don't do this right now,
;; but we might have to. Mathematica is a little vague and dependencies are
;; not listed explicitly (we think), but approached approximately, e.g.
;; expression x+y+z depends on stuff on some pages (which include the
;; residences of x,y,z. But they might all be on one page. And there
;; may be other things on those pages that change, so x+y+z might be
;; unnecessarily re-evaluated. In our scheme everything is re-evaluated,
;; almost inevitably way too much.
(defun mevalargs( ha l) ;; attributes of head
;;(format t "~%mevalargs env=~s" (describe env))
(unsequence
(cond ((member '|HoldAll| ha :test 'eq)l)
((member '|HoldFirst| ha :test 'eq)
(ucons (car l)(mapcar #'meval (cdr l))))
((member '|HoldRest| ha :test 'eq) (ucons (meval (car l))(cdr l)))
(t (format t "~%in mevalargs l=~s, res=~s" l (umapcar #'meval l))
(umapcar #'meval l)))))
(defun unsequence(k) ;; change ( a b (|Sequence| c d) e) to (a b c d e)
(cond ((null k) nil)
((and (consp (car k))(eq (caar k) '|Sequence|))
(append (cdar k)(unsequence (cdr k))))
(t (setf (cdr k)(unsequence (cdr k))) k)))
;; note that the name of this function conflicts with that
;; of the lisp function set, unless
;; (a) capitalization is observed OR
;; (b) the package system is protecting it..
#+ignore
(defun |Set| (lhs rhs &aux h fun);; lhs=rhs
;; the value associated with the lhs will be stored
;; in the symbol table symtab, with the key h,
;; which is either the head of the lhs,
;; or the lhs itself. That is f=45 is stored in the
;; hash table for f, under the indicator "f"
;; and f[0]=7 is stored in the hash table for f, under
;; the indicator (0).
(cond ((symbolp lhs)(setq h lhs)) ;; simple case, x=stuff
(t (setq h (car lhs)) ;; not so simple, x[i,j]= stuff, evaluate i,j
(setq lhs (mevalargs (|Attributes|(|Head| h))(cdr lhs)))))
;;(format t "Set ~s to ~s, h=~s~%" lhs rhs h)
;; this stores the material in the hash table.
;; QUESTION: M'ma doesn't do this, but we could, by storing
;; stuff on a local environment... f[x_,y_]:=Block[{},x=y+1];
;; what if (gethash h symtab) is a matrix, and this is a valid matrix
;; setting? Then we should try to store the value in the array.
;; This is insufficient error checking but...
(cond
;;else THIS happens, for a global variable. We need to fix for local var
;; on stack.
(t ;;(print 'xxxxx)
;;(chash h)
(setf (gethash lhs (gethash h symtab)) rhs)
;; (setq rhs (meval rhs)) ;; hold it, rhs is already evaluated
))
;; Next, check for special variables which, when set, cause other
;; things to happen. E.g. Precision= number means, in the
;; bigfloat system, (bigfloat-init number) gets executed.
(if (setq h (gethash h funnyvars ))(funcall h rhs))
rhs)
(defun |Set| (lhs rhs);; lhs=rhs
;; the value associated with the lhs will be stored
;; in the symbol table symtab, with the key h,
;; which is either the head of the lhs,
;; or the lhs itself. That is f=45 is stored in the
;; hash table for f, under the indicator "f"
;; and f[0]=7 is stored in the hash table for f, under
;; the indicator (0).
(declare (special symtab funnyvars))
(let ((h nil)(fun nil))
(cond ((symbolp lhs);; common case, "x=stuff"
;; 3 possibilities, x is bound on stack or or a funny-var or is global
;; (format t "~%setting symbol ~s" lhs)
(multiple-value-bind (val found)(sfind env lhs)
;; (format t "~%mvb result for symbol ~s is ~s ~s " lhs val found)
(cond (found ;found on stack.
(schange env lhs rhs)) ;;change it there.
((setf fun (gethash lhs funnyvars)) ;one of the vars needing special work
;; (format t "~%~s is in funnyvars"~s)
(funcall fun rhs))
(t ;;global case. Not found on stack
;; (format t "~%symtab is ~s" symtab)
(setf h (gethash lhs symtab)) ;odd. should be there from parser.
;; (format t "~%hashtable for ~s is ~s" lhs h)
(cond((null h)(chash lhs) (setf h (gethash lhs symtab))))
;; set h to the hash table for "x"
(setf (gethash lhs h) rhs))))) ; put value on key "x" in "x" hashtable
;; not not so simple an assignment, e.g., x[i,j]= stuff,
((consp lhs)
(setq h (gethash (car lhs) symtab)) ;symtab for x
(cond((null h)(chash (car lhs)) (setf h (gethash (car lhs) symtab))))
;; (format t "~% Set has non-atom lhs ~s" lhs)
;; (format t "~%hashtable for ~s is ~s" (car lhs) h)
(setq lhs (mevalargs (|Attributes|(car lhs))(cdr lhs))) ; evaluate i,j
(setf (gethash lhs h) rhs))
(t (error "illegal assignment target ~s" lhs)))
rhs)) ;return value
;;(format t "Set ~s to ~s, h=~s~%" lhs rhs h)
;; this stores the material in the hash table.
;; QUESTION: M'ma doesn't do this, but we could, by storing
;; stuff on a local environment... f[x_,y_]:=Block[{},x=y+1];
;; what if (gethash h symtab) is a matrix, and this is a valid matrix
;; setting? Then we should try to store the value in the array.
;; Next, check for special variables which, when set, cause other
;; things to happen. E.g. Precision= number means, in the
;; bigfloat system, (bigfloat-init number) gets executed.
;; there is another file (nmatrix) that defines a matrix type..
;; this should be tied in to the matrix stuff from franz, perhaps.
;; also, we have to decide which bigfloat to use... mpfun or rjf's
;; old bfstuff.
;; or MPFR. 12/2010
(defun matrix-p(x) (declare (ignore x))nil) ;;; for now, this will have to do.
(defun |SetQQ|(lhs rhs &aux h);; lhs=rhs, but don't mevaluate either.
(setq h(cond ((atom lhs) lhs)
(t (prog1 (car lhs) (setq lhs (cdr lhs))))))
(setf (gethash lhs (gethash h symtab))rhs)
(if (setq h (gethash h funnyvars ))(funcall h rhs))
rhs)
(defun |Clear|(&rest xl)
(map nil #'clear1 xl)
'|Null|)
(defun clear1(h)
;; RuleHT --clear out rule optimization hash table that seems to have bugs.
;; labels -- resets counter
(declare (special COUNT optimruleht ))
(cond ((eql h '|Labels|) (setf COUNT 0) (|Set|'|$Line| 0))
((eql h '|RuleHT|)
(setf optimruleht (make-hash-table :test 'eq)))
(t (let ((mm (gethash h symtab)))
(if mm (remhash h symtab) nil))))
nil)
;; this hash table has the optimized version of the pretty rules in it
(defparameter optimruleht (make-hash-table :test 'eq))
(defun |SetDelayed|(lhs rhs) ;; this is the function definition f[x_] := ...
(let* ((visible (ulist '|SetDelayed| lhs rhs))
(hidden (bindfix(fixopts visible))))
(setdelayed1 hidden)
(setf (gethash visible optimruleht) hidden) ;; store the optim rule/def here
'|Null|))
(defun setdelayed1(thedef)
(let* ((lhs (ucons (caadr thedef)
(umapcar #'meval (cdadr thedef)))) ;; see note re eval below
(hh (|Head| lhs)) ;; lets hope the Head is a symbol
(spot (gethash hh symtab)))
; (format t "~%lhs=~s" lhs)
;; should we evaluate the formal arguments? we need to do something, e.g.
;; f[Sqrt[x_]] should be changed to f[x_^(1/2)]
;; this could be merely simplification, not evaluation .. ugh.
;; (setf lhs (ucons (car lhs)(mevalargs nil (cdr lhs))))
;;(args (mevalargs (|Attributes|(|Head| hh)) (cdr lhs-in)))
;(args (cdr lhs-in)) ;; these should not be evaluated; they are like formal params, no?
;; push all but the 'SetDelayed on the list of definitional forms.
(if (null spot)(setf spot (setf (gethash hh symtab) (make-hash-table :test #'equal :size 4)))) ; not needed except bug?
(cond ((null (gethash '|SetDelayed| spot))
(setf (gethash '|SetDelayed| spot) (ulist (ucons lhs (cddr thedef)))))
(t (push (ucons lhs (cddr thedef)) (gethash '|SetDelayed| spot))))))
;; this assumes the value of a mathematica symbol is its lisp value
;; if it is simply a constant or non-hash-table. That means that
;; a lisp dynamically bound variable could be used to block access
;; to the globally bound variable of the same name. Better not
;; use local-variable names like Sin or Cos unless you mean to
;; inhibit access to the global names.
(defun meval-atom(h)
(declare (special env))
(if (constantp h) h
(multiple-value-bind
(val found)
(sfind env h)
(if found val ;; return val
;; if we find it here on the env stack.
;; otherwise
;; val is a symbol, same as h see if it has a value
(let ((r (gethash val symtab)))
(and (hash-table-p r)
(gethash val r val))))))) ;even if val is nil
;; look up the value of e on e's hashtable, key e
;; look up the value of e[10] on e's hashtable, key (10)
(defun msymbol-value (h)
(cond
((atom h) (meval-atom h))
(t (let ((tabentry (gethash (|Head| h) symtab)))
(if tabentry (gethash (cdr h) tabentry h)
h)))))
#+ignore ;; this guy may be useful, though, for evaluating until no change.. Buggy though.
(defun msymbol-function(h)
;; hm, how much work should we do here?
;; it could be that h is just h, and has no binding of any sort.
(let ((saved h))
(loop
(setf h (cond
;; if we think we should look on the stack for it, then we do this.
;; if the value is yet another name, what then? Do we use that
;; name or continue looking??
((multiple-value-bind
(val found)
(sfind env h)
(if found val nil))) ;; if the function is found on stack, it is val
;; we go on to the next clause if the function is not found
;; on the stack.
((multiple-value-bind
(val found)
(gethash h symtab)
(if found (return-from msymbol-function (gethash '|SetDelayed| val h))
;; if not found return h
h)))))
(if (equal h saved) (return h)))))
;; this guy looks on the stack; returns if there. looks on global symtab; returns if there.
;; no loop. works, if that's what you want
(defun msymbol-function(h)
;; hm, how much work should we do here?
;; it could be that h is just h, and has no binding of any sort.
;; it returns either a non-function or a (global) SetDelayed list or rules
(setf h (cond
;; if we think we should look on the stack for it, then we do this.
;; if the value is yet another name, what then? Do we use that
;; name or continue looking??
((multiple-value-bind
(val found)
(sfind env h)
(if found val nil))) ;; if the function is found on stack, it is val
;; we go on to the next clause if the function is not found
;; on the stack.
((multiple-value-bind
(val found)
(gethash h symtab)
(if found (return-from msymbol-function (gethash '|SetDelayed| val h))
;; if not found return h
h)))))
h)
;;always go for global ...
#+ignore
(defun msymbol-function(h)
;; hm, how much work should we do here?
(multiple-value-bind
(val found)
(gethash h symtab)
(if found (return-from msymbol-function (gethash '|SetDelayed| val h))
;; if not found return h
h)))
;; is this going to have the right scope?
;;
;;----end of makeshift definitions
(defun mapply (hraw args expr env);; note that args= (cdr expr)
(let* ((fun nil)
(h (meval-to-function hraw))
(msymq (gethash h symtab))) ; is a mma symbol?
;; there are 2 kinds of applications here.
;; (Function ...) which is just held.
;; (w ...) where w is (Function ...)
;; (format t "~% h=~s hraw=~s args=~s" h hraw args)
(cond ((eql h '|Function|)
(return-from mapply (ucons '|Function| (funfix (cdr expr)))))
((and (consp h)(eql (car h) '|Function|))
;; this next line should grab the attributes of this Function, if any
;; (format t "~%before args to function ~s are ~s, with env=~s" h args env)
;; (setf args (mevalargs (cdddr h) args)) will be done in mappfun
;; (format t "~%after args to function ~s are ~s" h args)
(return-from mapply (mappfun h args expr env))))
;; (format t "~%before args.. ~s are ~s, with env=~s" h args env)
;;get info on evaluating arguments and do it to args
(setf args (mevalargs (|Attributes| h) args))
(cond
;; I don't believe the comment below...
((constantp h)
;; (format t "~%h=~s" h)
h) ;; allows any lisp function, almost, to slip through
;; check for constant values pre-stored
((not (symbolp h)) (setq expr(ucons h args)))
((and ;(not msymq)
(symbolp h)(fboundp h))
;(format t "~% applying a lisp function ~s to args ~s " h args )
(setq expr (apply h args )))
;;((not msymq)(setq expr (ucons h args)))
;; maybe put in a check for array here? Not now.
;; next check for user-defined function
((consp (setq fun (msymbol-function h)))
;;(setq args (mevalargs h args)) ;; not always ..
(format t "~%applying a user function ~s to args ~s" fun args)
(setq expr(rulesetapply h fun args)))
;; next check for built-in LISP function
;; (clearly not something that Mathematica does)
(t (format t "~% eval fell through ~s ~s" h args)
(setq expr(ucons h args))))
(format t "~% mapply result: expr=~s" expr)
expr))
;;(declaim (special phead)) ;; not needed?
(defun rulesetapply(phead rules args)
;; get attributes of phead and manipulate args
(setq args (mevalargs (Attributes(|Head| phead)) args))
(let*
((origfn phead)
(expr (ucons phead args)))
;; (if isflat nil (setq phead '|Sequence|))
(do ((rr rules (cdr rr)))
((null rr) ;; no more rules to try -- return original
expr)
(let* ((thisrule (car rr))
(condit #'truth)
(lhs (car thisrule))
(rhs (cadr thisrule))
(testr nil))
;; Note: if the rule was
;; f[a_,b_]:= g[a,b] /; a>b, the parsed result is
;; (SetDelayed (f ..) (Condition (g a b) (Greater a b)))
;; see if there is a Condition on the rhs of the rule
;; e.g. (Condition (foo a b) (Greater a b))
;; deal with the possibility of a Condition coming in.
(cond ((and (consp rhs)(eq (car rhs) '|Condition|))
(setf testr (caddr rhs))
;; (format t "~%try to match ~s with condition ~s" lhs testr)
(setf condit #'(lambda() ;(format t "~% evaluating condit ~s" testr)
(meval testr))) ;eg testr = (Comparison a Greater b)
(setf rhs (cadr rhs))))
;rhs = (foo a b)
;;(format t "~%lhs= ~s ~%rhs= ~s expr=~s ~%condition =~s" lhs rhs expr condit)
(if (not (eql (|Head| expr) origfn))(return-from rulesetapply expr)) ;no more rules here are relevant
;; test for matching
;; REDONE 2/2011 RJF,
;;(spushframe env phead)
(cond ((match lhs expr condit) ;; matching works
(setf expr(meval rhs)) ;; something like this..
(spopframe env) ;; pop off the match frame
(return-from rulesetapply expr)) ;; end of match, don't try more rules in do loop
(t (spopframe env)))
))))
;;(defun falsenull(h)(or (null h)(eq h '|False|))) ;; test for mockmma False or maybe nil
;;(defun notfalse(h) (not (falsenull h))) ;; anything not False or nil
;; Major evaluation function for an expression
;; see Mathematica book p 568
;;(defun meval-to-function(x) x) ;; don't evaluate function name ?
(defun meval-to-function(x) (meval x))
(defvar *evalonce* t) ;; should be t to make quote (etc etc) work
(defun meval (e)
(let ((saved e)(hd nil) (ha nil))
(if(atom e)(return-from meval (meval-atom e)))
(if (eq (setf ha (msymbol-value e))e) ;didn't find a value
nil (return-from meval ha)) ; DID find a value.
;; check off other constant expressions that don't evaluate.
;; perhaps Messages?
;;((patternobjectp e) e) .. What about Patterns?
;; (mapply (car foo)(cdr foo) foo env) ==> foo with no conses...
(setf e (cons (meval-to-function (|Head| e))(cdr e)))
;; (return-from meval (mapply (car e) (cdr e) e env)) ))
(setf e (mapply (car e) (cdr e) e env))
;; note the 3rd arg to mapply, just in case you want to
;; return the expression as the result without any change.
;; next step --
;;
;; do we keep evaluating until there is no change???
(setf hd (|Head| e))
(setf ha (|Attributes| hd))
;; (format t" ~%ha=~s hd=~s e=~s" ha hd e)
(cond (*evalonce* e)
((eql hd '|Function|) (funfix (cdr e)) e) ;; compute new body
((and (member '|Listable| ha) (some #'|ListQ| (cdr e)))
;; uh, (h a,b,..(List c d) ..) becomes
;; (List (h a b ..c..) (h a b .. d..) ).
(listify e))
((equal e saved) e)
((eql hd '|Hold|) e)
(t (meval e)))
))
(defun listify(e)
(let ((listlength nil)(tt 0))
(loop for i in (cdr e) do
;; scan for length
(cond ((|ListQ| i)
(setf tt (length (cdr i)))
(if listlength (cond ((= tt listlength) nil )
(t (format t "~%objects of unequal length cannot be combined ~s" e)
(signal 'error)))
;; no listlength yet. set it
(setf listlength tt)))))
;(print listlength)
;; now make a list of length listlength
(ucons '|List| (loop for i from 1 to listlength collect
(ucons (car e) (loop for j in (cdr e) collect (if (|ListQ| j)(elt j i) j)))))) )
;; Each global object X is associated with a hash table
;; and we can, for each,
;; to get the value, do (gethash X X), (gethash 'rules X) etc.
;; Local bindings hide everything.
;;Do we want to do infinite evaluation?
;;How do we keep single copies of items in memory?
;;set up initial symbol-table entries for built-in stuff
;; should also set attributes
(mapc #'chash built-in-syms)
;; All system-level $-stuff can be initialized and stored this way
(defun globinit(name val)
(chash name); just in case it isn't already there
(setf (gethash name (gethash name symtab)) val))
(globinit '|$Line| 1)
;;(globinit '|False| '|False|)
(globinit '|False| nil) ;; maybe, maybe not
(globinit '|$Showtime| nil)
(globinit '|I| #c(0 1)) ;; imaginary unit I^2 = -1.
;; simple debugging tool: examine contents of symtable entry
(defun showhash(x)
(maphash #'(lambda(key val) (format t "~%key=~s, val=~s" key val)) x))
; |Attributes| that evaluation routines use. maybe
; - Flat [associative, flatten out nested expressions]
; - Orderless [commutative, put args in order]
; - |Hold|First [don't evaluate first arg yet]
; - |Hold|Rest [only evaluate first arg now]
; - |HoldAll| [don't evaluate any args now]
; - Procedure [procedure to call to do actual evaluation]
; - Default [default value for optional variables]
;;[version 3]?
;; the attribute semantics are probably OK as long as only global properties
;; are being recorded.
;; define ClearAttribute similarly
;; mma does not allow setting of |Attributes| other than
;;Protected, ReadProtected, Locked, Temporary, |Hold|First, |Hold|Rest, |HoldAll|, Flat, Orderless, OneIdentity, |List|able, Constant, Stub, N|Hold|First, N|Hold|Rest, N|HoldAll|, NumericFunction, |Sequence||Hold|, and |HoldAll|Complete. [version 7]
;;bunch of additions, 1/2011 RJF
(defun setattribute(h att &optional (val '|True|)) ;; not in mathematica
(if (typep h 'hash-table) nil (setq h (gethash h symtab)));; now its a ht
(setf (gethash att h) val) ;; in h's hashtable, set the attribute att's value to true
(setf(gethash '|Attributes| h);; also in h's hashtable, set its property of |Attributes| to a list
(adjoin att (gethash '|Attributes| h)))
)
(defun |Default|(h)
(gethash '|Default| (gethash h symtab emptyht) '(|Sequence|)))
(defun |SetAttributes|(hi attlist) ;; this is in Mathematica.
(let ((h (gethash hi symtab))) ;; get the hashtable for the symbol h.
(cond ((atom attlist) ;; just one
(setattribute h attlist))
(t (map nil #'(lambda(r)(setattribute h r))(cdr attlist))
(cons '|List| (gethash '|Attributes| h))
;attlist
))
(|Attributes| hi)))
(defun |Attributes|(h)
(cons '|List| (gethash '|Attributes| (gethash h symtab emptyht ) nil)))
(setattribute '|Plus| '|Flat|)
(setattribute '|Plus| '|Orderless|)
(setattribute '|Plus| '|Default| 0)
(setattribute '|Plus| '|Listable|)
(setattribute '|Times| '|Flat|)
(setattribute '|Times| '|Orderless|)
(setattribute '|Times| '|Listable|)
(setattribute '|Times| '|Default| 1)
(setattribute '|Power| '|Default| 1)
(setattribute '|And| '|HoldAll|) ; short-circuiting
(setattribute '|Or| '|HoldAll|)
(setattribute '|If| '|HoldRest|)
(setattribute '|Condition| '|HoldRest|)
(setattribute '|Set| '|HoldFirst|)
(setattribute '|Set| '|HoldSequence|) ;; whatever this does; nothing at the moment
(setattribute '|SetDelayed| '|HoldAll|)
(setattribute '|UpSet| '|HoldFirst|)
(setattribute '|UpSetDelayed| '|HoldAll|)
(setattribute '|TagSet| '|HoldFirst|)
(setattribute '|TagSetDelayed| '|HoldAll|)
(setattribute '|Pattern| '|HoldFirst|)
;;(setattribute 'ReplaceAll '|HoldFirst|)
(setattribute '|ReplaceRepeated| '|HoldRest|)
;;(setattribute 'Rule '|HoldFirst|) ;12/2010
;;(setattribute 'RuleDelayed '|HoldAll|) ;12/2010
(setattribute '|RuleDelayed| '|HoldRest|)
(setattribute '|Clear| '|HoldAll|)
(setattribute '|Do| '|HoldAll|)
(setattribute '|Table| '|HoldAll|)
(setattribute '|Every| '|HoldAll|)
(setattribute '|Some| '|HoldAll|)
(setattribute '|Function| '|HoldAll|)
;; NO, BAD THINGS HAPPEN (setattribute '|Attributes| '|HoldAll|)
;;(chash 'ltrace) ;; lisp trace
;;(chash 'luntrace);; lisp untrace
;;(setattribute 'ltrace '|HoldAll|)
;;(setattribute 'luntrace '|HoldAll|)
;;(defun ltrace(&rest funs) (eval `(trace ,@funs)))
;;(defun luntrace(&rest funs)(eval `(untrace ,@funs)))
;; convert all real numbers to exact rational numbers
(defun |Real|(a b) (+ a b))
;; this works only for integer x, x>0
(defun decimalsin(x)
(ceiling (* (integer-length x) 0.30102999566398114d0)))
;; handle %, %%, etc.
(defun |Out| (&rest n)
(gethash (ucons
(cond ((null n) (1- COUNT))
((minusp (setq n (car n))) (+ COUNT n))
(t n))
nil)
(gethash '|Out| symtab)))
(defun |Simp|(x)(simp x)) ;; rational simplification
(defun |Rat|(x)(into-rat x)) ;; leave the answer in rational form.
(defun |UnRat|(x)(outof-rat x)) ;; convert the answer to list form.
;; convert u to a rational with a single polynomial numerator
;; and denominator. That is (x+1)^2 will be multiplied out.
;; result in rational form.
(defun |RatExpand|(u)
(let* ((*expand* t) ;; global flag to rat program
(x (into-rat u)))
(make-rat :numerator (make-fpe (fpe-expand (rat-numerator x))1)
:denominator
(make-fpe (fpe-expand (rat-denominator x)) 1))))
#+ignore (defun UnivariateDistinctDegreeFactorization (u)
(let((x (into-rat u)))
(make-rat :numerator (poly-uddf (rat-numerator x))
:denominator (poly-uddf (rat-denominator x)))))
#+ignore (defun UnivariateSquareFree etc)
#+ignore (defun UnivariateFactorizationMod(u p)
etc)
;; pick out parts of an expression. x[[y]] parses to Part[x,y].
;; (a+r+b^c) [[3,2]] is c.
;;Generalizes somewhat in that (a+b^c)[[2,r]] returns (b^c)[[r]].
;; Does not handle negative part-numbers or lists of parts as
;; done in Mathematica. Also, won't decompose defstruct items
;; unless we do something about it for each structure...
(defun |Part|(u &rest k)(part1 (meval u) k)) ;; meval??
(defun part1 (u kl)(cond ((null kl) u)
((and(integerp (car kl))
(>= (length u)(car kl)))
(part1 (nth (car kl) u)(cdr kl)))
;; leave unevaluated part if can't handle it.
(t (ucons 'Part (ucons u kl)))))
;;If is HoldRest, so (car stuff) is evaluated.
(defun |If| (&rest stuff)
; (format t "~%If stuff =~s, env=~s" stuff env)
(cond ((eql (car stuff) '|True|) ; test is True?? do we need to meval??
;;(format t "~% then ~s mevals to ~s with env ~s" (cadr stuff)(meval (cadr stuff)) env)
(meval (cadr stuff))) ;; evaluate the "then clause"
((null (car stuff)) ;test is False
; evaluate the "else" if present else return Null
(if (caddr stuff)(meval (caddr stuff)) '|Null|))
(t ;; test is neither true nor false,
(ucons '|If| stuff))))
;; basic simplification of |Times|
(defun |Times| (&rest x &aux (nums 1) oths)
(dolist (h x ;; iterate with h running over all args
;;resultform
(cond((= 1 nums)
(if (null oths) 1
(if (cdr oths) ;; more than one item in product 10/13/94
(ucons '|Times| (uniq(nreverse oths)))
(car oths))))
((null oths) nums)
(t (ucons '|Times| (ucons nums (uniq(nreverse oths)))))))
;; body
(cond ((numberp h)(setq nums (* nums h))) ;; collect CL numbers
;; if you find a rat, break out !
((typep h 'rat)(return-from |Times|
(reduce-rat #'rat*
(into-rat (car x))
(cdr x))))
(t (push h oths)))))
(defun |Condition|(a test)
(let ((bool (meval test)))
(cond ((or (null bool)(eql bool '|False|)) '|Null|)
((eql bool '|True|) (meval a);a
)
(t (ulist '|Condition| a test)))))
;; f[3, 4] /. (f[x_, y_] /; x > y -> gg)
;; f[5, 4] /. (f[x_, y_] /; x > y -> gg)
;; this definition allows a=c; to take effect and return Null, so no display
(defun |CompoundExpression|(&rest x &aux result)
(do* ((i x (cdr i))
(j (car i)(car i)))
((null i) result) ;; evaluate each element in turn, return last one.
(setf result(meval j)))
#+ignore (catch :ret ;; if a return is executed somewhere inside here,
)
;; no, we want not to exit NOT from the Compound expression, but the
;; construction outside it
)
(defun |Return|(x)
;;(format t "~% throwing :ret with value ~s" x)
;;(spopframe env) ;;hm. careful here.
(throw :ret x))
(defun |Plus| (&rest x &aux (nums 0) oths)
(dolist (h x ;; iterate with h running over all args
;;resultform
(cond((zerop nums)
(cond ((null oths) 0)
((null (cdr oths)) (car oths))
(t (ucons '|Plus| (uniq(nreverse oths))))))
((null oths) nums)
(t (ucons '|Plus| (ucons nums (uniq(nreverse oths)))))))
;; body
(cond ((numberp h)(incf nums h))
;; if a rat form, break out!
((typep h 'rat)(return-from |Plus|
(reduce-rat #'rat+ (into-rat (car x)) (cdr x))))
(t (push h oths)))))
(defun |Power| (b &optional (e 1)) ;; need to handle (|Power| x) --> x
(cond((or
(and (integerp b)(integerp e))
(and *numer* (numberp b)(numberp e)))
(expt b e))
((and (eql '|Rat|(|Head| b))
(integerp e))
(into-rat (uniq `(|Power| ,b ,e))))
((eql e 1) b)
((and (integerp e)(eql (|Head| b) '|Power|)) ;;(x^y)^2 -> x^(2*y). (x^2)^(1/2) no change.
(ulist '|Power| (cadr b)(|Times| (caddr b) e)))
(t (ulist '|Power| b e))))
#+ignore;; leave Complex of symbols alone?
(defun |Complex|(re im)
;; insufficient for bigfloats or other number types that are not lisp numbers
(cond ((numberp im)(cond ((numberp re)(complex re im)) ; both re and im are numbers
(t (uniq `(|Plus| ,re ,(complex 0 im))))))
(t (uniq `(Plus ,re (|Times| ,im ,(complex 0 1)))))))
(defun |Complex|(re im)
;; insufficient for bigfloats or other number types that are not lisp numbers
(cond ((and (numberp im)(numberp re))(complex re im)) ; both re and im are numbers
(t `(|Complex| ,re ,im))))
#+ignore
(defun |Rational|(n d)
;; insufficient for bigfloats or other number types that are not lisp integers
(cond ((integerp d)(cond ((integerp n)(/ n d)) ; both n and d are integers
(t (uniq `(|Times| , n ,(/ 1 d))))))
(t (uniq `(|Times| ,n (|Power| ,d -1))))))
(defun |Rational|(n d)
;; insufficient for bigfloats or other number types that are not lisp integers
(cond ((and(integerp d)(integerp n))(/ n d))
(t `(|Rational| ,n ,d))))
;; note: Timing is a |HoldAll| function... otherwise the evaluation
;; of the argument would come first, and the timing would
;; be of an already evaluated expression.
(defun |Timing|(x) ; x is an expression, perhaps compound, uneval'd
(let*((timeunit (/ 1.0 internal-time-units-per-second))
(timesofar (get-internal-run-time))
(result (meval x)))
(uniq `(|List| (|Times| , (*(- (get-internal-run-time) timesofar)
timeunit)
Second) , result))))
;; if we are stuck with all one case
;; then we are forced to do something like this for
;; every function that is already defined in lisp with the
;; same name as in mathematica (tm)
#+ignore
(eval-when (compile load eval)
(shadow '(sin cos tan log exp sinh cosh tanh abs sqrt
plusp) :mma)) ;;etc
;; more notes
;; Sin[x_]/; x>3-> S[x]
;; parses to
;; (Rule (Condition (Sin (Pattern x (Blank))) (Comparison x Greater 3)) (S x))
;; we don't have evaluation of Block implemented.
;;
;; probably should add evaluation of functions and slots.
;; eg #+1&[4] should return 5.
#|
(break "t")
;;(ww (Pattern x (Blank))) Condition aha
;;(Comparison x Greater 5)
;; w[x_]:= aha /; x>5 parses into something like ...
;;(( (ww (Pattern x (Blank))) . (Condition aha (Comparison x Greater 5)) ))
;;but we need (Rule (Condition (ww (Pattern x (Blank))) (Comparison x Greater 5)) aha)
;;or something close to that
;;(trial '(Condition (ww (Pattern x (Blank))) (Comparison x Greater 5)) '(w 10))
;;(trial '(Condition (ww (Pattern x (Blank))) (Comparison x Greater 5)) '(w 4))
|#
;;just a hack ..
#|
(defun macint (x y)
(max2mma (maxima::$integrate (mma2max x) (mma2max y))))
|#
(defun |Every| (exp iter)
(every1 exp iter))
(defun |Some| (exp iter)
(some1 exp iter))
(defun every1 (exp iter) ;; kick out if anything is False (=nil)
;;Exp is an expression with a free variable itvar
;;iter looks like {i,low,hi} or (|List| i low hi) in Lisp
(case (length iter)
(1 (error "invalid iterator ~s" iter))
(2 ;; (List count)
(let ((count (second iter)))
(cond((not(integerp count)) (format t "~%expected integer iterator ~s" iter)
(signal 'error))
((< count 0)(format t "~%expected non-negative iterator ~s" iter)(signal 'error))
(t (setf exp (meval exp))
(loop for i from 1 to count do (if (eql exp '|True|) nil
(return nil)))
'|True|))))
(3
;; (List i hi); no low, assumed 1
;; or (list i (List a b c ...))
(let ((tt (third iter))
(itvar (second iter)))
(cond((and(integerp tt ) (>= tt 1))
(every1 exp (uniq `(|List| ,(second iter) 1 ,tt)))) ;; just count from 1.
((and (consp tt)(eql (car tt) '|List|))
(spush env iter nil)
(do ((i (cdr tt) (cdr i))
(res nil
(progn (schange env itvar (car i))
(if (eql '|True| (meval exp) ) nil (let()(spop env)(return nil))))))
((null i) (spop env) '|True|)))))) ;; kept on going until exhausted so must be
((4 5)
(let ((itvar (second iter)) ;; (List i low hi [step])
(hi (meval (fourth iter))) ;hi
(step (or (meval (fifth iter)) 1))) ;if missing, then 1
(spush env itvar 0) ; reserve a space
;; the case of {i, 1, 10} or {i,1,10,2} ;; set step
(do ((i (meval (third iter)) (+ step i))
(res nil
(progn (schange env itvar i)
(if (eql '|True| (meval exp) ) nil (let()(spop env)(return nil))))))
((> i hi) (spop env) '|True|))))
))
(defun some1 (exp iter) ;; kick out if anything is True
;;Exp is an expression with a free variable itvar
;;iter looks like {i,low,hi} or (|List| i low hi) in Lisp
(case (length iter)
(1 (error "invalid iterator ~s" iter))
(2 ;; (List count)
(let ((count (second iter)))
(cond((not(integerp count)) (format t "~%expected integer iterator ~s" iter)
(signal 'error))
((< count 0)(format t "~%expected non-negative iterator ~s" iter)(signal 'error))
(t (setf exp (meval exp))
(loop for i from 1 to count do (if (eql exp '|True|)
(return nil) nil))
'|True|))))
(3
;; (List i hi); no low, assumed 1
;; or (list i (List a b c ...))
(let ((tt (third iter))
(itvar (second iter)))
(cond((and(integerp tt ) (>= tt 1))
(some1 exp (uniq `(|List| ,(second iter) 1 ,tt)))) ;; just count from 1.
((and (consp tt)(eql (car tt) '|List|))
(spush env iter nil)
(do ((i (cdr tt) (cdr i))
(res nil
(progn (schange env itvar (car i))
(if (eql '|True| (meval exp)) (let()(spop env)(return '|True|)) nil))))
((null i) (spop env) nil)))))) ;; kept on going until exhausted so none..
((4 5)
(let ((itvar (second iter)) ;; (List i low hi [step])
(hi (meval (fourth iter))) ;hi
(step (or (meval (fifth iter)) 1))) ;if missing, then 1
(spush env itvar 0) ; reserve a space
;; the case of {i, 1, 10} or {i,1,10,2} ;; set step
(do ((i (meval (third iter)) (+ step i))
(res nil
(progn (schange env itvar i)
(if (eql '|True| (meval exp) ) (let()(spop env)(return nil)) nil))))
((> i hi) (spop env) nil))))
))
;;BBB BUG. Gotta fix.
;; m[a_,x_]:=aha/;FreeQ[a,x]
;; m[b,x] --> aha
;; m[x,x] --> m[x,x]
;; m[a,x] --> aha
;; m[a+b,x] --> loop. because FreeQ[a,x] evaluates a to get a+b which ...