[Maxima] Zero version of mathematica evaluator for MAXIMA
Siver Andrey
siver at Sirius.ihep.su
Sun Mar 12 09:42:52 CST 2006
This is a multi-part message in MIME format.
------=_NextPart_000_0023_01C64604.C4F80580
Content-Type: multipart/alternative;
boundary="----=_NextPart_001_0024_01C64604.C4F80580"
------=_NextPart_001_0024_01C64604.C4F80580
Content-Type: text/plain;
charset="koi8-r"
Content-Transfer-Encoding: quoted-printable
Hello, Maxima users,
I would like to demonstrate zero version of the Mathematica evaluator =
for MAXIMA. It's fully based on the Mathematica parser from the old Mma =
package.
Now it accepts following Mathematica constructs:=20
Assignments: =3D :=3D=20
Functional dependence: f[x_]
Arithmetics: - + * / ^=20
Simple functions: Log Sin Cos=20
Lists: {...}
To use the evaluator interactively one can call :lisp(math) and type the =
Mathematica expression.
Here's an example session:
(%i1) load("e:/siver/develop/mma1.6/math-1.lisp");
(%o1) e:/siver/develop/mma1.6/math-1.lisp
(%i2) load("e:/siver/develop/mma1.6/parser-1.lisp");
(%o2) e:/siver/develop/mma1.6/parser-1.lisp
(%i3) :lisp(mtest) <!-- this executes code from the attached file =
test.txt contaning =
"a=3D0;b=3Da+1;f[x_]=3Da+x;a=3D1;c:=3Da+1;g[x_,y_]:=3Dx+y+a;a=3D2" -->
NIL
(%i3) ?a;
(%o3) 2
(%i4) ?b;
(%o4) 1
(%i5) ?f(x);
(%o5) x
...
(%i18) ev(?c);
(%o18) 3
(%i19) ?a:0;
(%o19) 0
(%i20) ev(?c);
(%o20) 1
(%i21) ?g(x,y);
(%o21) y + x
And at last one unresolved problem :) :
(%i34) ?a:t;
(%o34) t
(%i35) t:1;
(%o35) 1
(%i36) ev(?g(x,y));
(%o36) y + x + t
Mathematica result: y+x+1
How it is possible to force MAXIMA to use final result of the =
assigments?
Best regards,
Andrey Siver
------=_NextPart_001_0024_01C64604.C4F80580
Content-Type: text/html;
charset="koi8-r"
Content-Transfer-Encoding: quoted-printable
<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN">
<HTML><HEAD>
<META http-equiv=3DContent-Type content=3D"text/html; charset=3Dkoi8-r">
<META content=3D"MSHTML 6.00.2800.1528" name=3DGENERATOR>
<STYLE></STYLE>
</HEAD>
<BODY bgColor=3D#ffffff>
<DIV><FONT face=3DArial size=3D2>Hello, Maxima users,</FONT></DIV>
<DIV><FONT face=3DArial size=3D2></FONT> </DIV>
<DIV><FONT face=3DArial size=3D2>I would like to demonstrate zero =
version of=20
the Mathematica evaluator for MAXIMA. It's fully based on the =
Mathematica parser=20
from the old Mma package.</FONT></DIV>
<DIV><FONT face=3DArial size=3D2>Now it accepts following Mathematica =
constructs:=20
</FONT></DIV>
<DIV><FONT face=3DArial size=3D2> Assignments: =3D =
:=3D </FONT></DIV>
<DIV><FONT face=3DArial size=3D2> Functional =
dependence:=20
f[x_]</FONT></DIV>
<DIV><FONT face=3DArial size=3D2> Arithmetics: - + * =
/ ^=20
</FONT></DIV>
<DIV><FONT face=3DArial size=3D2> Simple functions: =
Log Sin Cos=20
</FONT></DIV>
<DIV><FONT face=3DArial size=3D2> Lists: =
{...}</FONT></DIV>
<DIV><FONT face=3DArial size=3D2></FONT> </DIV>
<DIV><FONT face=3DArial size=3D2>To use the evaluator interactively one =
can call=20
:lisp(math) and type the Mathematica expression.</FONT></DIV>
<DIV><FONT face=3DArial size=3D2></FONT> </DIV>
<DIV><FONT face=3DArial size=3D2>Here's an example =
session:</FONT></DIV>
<DIV><FONT face=3DArial size=3D2>(%i1)=20
load("e:/siver/develop/mma1.6/math-1.lisp");<BR>(%o1)=20
=20
e:/siver/develop/mma1.6/math-1.lisp<BR>(%i2)=20
load("e:/siver/develop/mma1.6/parser-1.lisp");<BR>(%o2)=20
=20
e:/siver/develop/mma1.6/parser-1.lisp<BR>(%i3) :lisp(mtest) =
<!-- this=20
executes code from the attached file test.txt contaning=20
"a=3D0;b=3Da+1;f[x_]=3Da+x;a=3D1;c:=3Da+1;g[x_,y_]:=3Dx+y+a;a=3D2" -=
-><BR>NIL<BR>(%i3)=20
?a;<BR>(%o3) =
=20
2<BR>(%i4) ?b;<BR>(%o4)=20
1<BR>(%i5)=20
?f(x);<BR>(%o5) =
=20
x</FONT></DIV>
<DIV><FONT face=3DArial size=3D2>...<BR>(%i18) ev(?c);<BR>(%o18)=20
3<BR>(%i19) =
?a:0;<BR>(%o19) =
=20
0<BR>(%i20) ev(?c);<BR>(%o20)=20
1<BR>(%i21) =
?g(x,y);<BR>(%o21) y +=20
x<BR></DIV></FONT>
<DIV><FONT face=3DArial size=3D2>And at last one unresolved problem :)=20
:</FONT></DIV>
<DIV><FONT face=3DArial size=3D2></FONT> </DIV>
<DIV><FONT face=3DArial size=3D2>(%i34) ?a:t;<BR>(%o34)=20
t<BR>(%i35) =
t:1;<BR>(%o35) =
=20
1<BR>(%i36) ev(?g(x,y));<BR>(%o36) =
y + x +=20
t<BR></FONT></DIV>
<DIV><FONT face=3DArial size=3D2>Mathematica result: y+x+1</DIV></FONT>
<DIV><FONT face=3DArial size=3D2> </DIV></FONT>
<DIV><FONT face=3DArial size=3D2>How it is possible to force MAXIMA to =
use final=20
result of the assigments?</DIV></FONT>
<DIV><FONT face=3DArial size=3D2></FONT> </DIV>
<DIV><FONT face=3DArial size=3D2></FONT> </DIV>
<DIV><FONT face=3DArial size=3D2>Best regards,</FONT></DIV>
<DIV><FONT face=3DArial size=3D2></FONT> </DIV>
<DIV><FONT face=3DArial size=3D2>Andrey Siver</DIV></FONT></BODY></HTML>
------=_NextPart_001_0024_01C64604.C4F80580--
------=_NextPart_000_0023_01C64604.C4F80580
Content-Type: application/octet-stream;
name="parser-1.lisp"
Content-Transfer-Encoding: quoted-printable
Content-Disposition: attachment;
filename="parser-1.lisp"
;; -*- Mode:Common-Lisp;Package:mma; Base:10 -*-=0A=
=0A=
;; e:/siver/develop/mma1.6/parser-1.lisp=0A=
=0A=
;; Lisp-mathematica (Lmath) parser for Mathematica (tm)-like language.=0A=
;;(c) copyright 1990, 1991, 1996 by Richard J. Fateman=0A=
;; Last revised 1/11/96 by RJF=0A=
;; Mathematica is described in S. Wolfram: Mathematica, a=0A=
;; System for Doing Mathematics By Computer, (Addison-Wesley).=0A=
;; this line is not quite enough. Need to do, prior to compiling this=0A=
;; file, (set-case-mode :case-sensitive-lower)=0A=
#+ignore ;; just use default case=0A=
(eval-when (compile load eval)=0A=
#+Allegro(cond((eq *current-case-mode* :case-sensitive-lower))=0A=
(t (set-case-mode :case-sensitive-lower))))=0A=
=0A=
(declaim (optimize (speed 3)(safety 0)))=0A=
=0A=
;;(provide 'math-parser)=0A=
;; (eval-when (compile) (load "mma")) ;; get all the symbols from this =
file=0A=
;(in-package :mma)=0A=
;;(export '(p pc rc))=0A=
=0A=
(defvar mathbuffer nil) =0A=
(defvar stream t) ;; if needed=0A=
=0A=
;; The first section consists of readtable hacking for mathematica =
parser.=0A=
;; We set up a separate readtable for=0A=
;; mathematica input, and utilize it when scanning.=0A=
;; We use lisp atoms to store information on tokens.=0A=
;; For production, this could all be put in a Lisp package.=0A=
=0A=
(defvar mathrt (copy-readtable nil))=0A=
(defvar si (make-synonym-stream '*standard-input*))=0A=
=0A=
=0A=
(setq *print-level* nil *print-length* nil *print-pretty* t)=0A=
=0A=
(defun pc()(peek-char nil stream nil #\newline))=0A=
(defun rc()(read-char stream))=0A=
=0A=
(defun char-to-int (c) ;; return the integer 0-9 corresponding to=0A=
;; the character c, #\0 - #\9=0A=
;; will not work in larger bases though..=0A=
(let ((h (char-int c)))=0A=
(cond ((< h 48)(- h 7)) ;; #\A=3D17=0A=
((< h 58) (- h 48)) ; #\0 is 48 in ascii.=0A=
(t (- h 87)) ; #\a=3D97=0A=
)))=0A=
(defun collect-integer (val r)=0A=
(cond ((eql (pc) #\newline) val)=0A=
((digit-char-p (pc) r) ;r is radix=0A=
=0A=
(collect-integer (+ (char-to-int (rc))(* r val)) r))=0A=
;; ((eql (pc) #\`)(rc)(collect-integer val r)) ;;option 123`456 is =
123456.=0A=
(t val)))=0A=
=0A=
;; to test scanner, try typing=0A=
;; (mreadl) =0A=
=0A=
;; most of these read-table entries were generated by macro expansion=0A=
(set-macro-character #\/=0A=
#'(lambda =0A=
(stream char)=0A=
(declare (ignore char))=0A=
(case (pc)=0A=
(#\newline '/)=0A=
(#\: (rc) '|/:|)=0A=
(#\. (rc) '/.)=0A=
(#\@ (rc) '/@)=0A=
(#\; (rc) '|/;|)=0A=
(#\=3D (rc) '/=3D)=0A=
(#\/ (rc)=0A=
(case (pc) (#\newline '//) (#\@ (rc) '//@) (#\. (rc) '//.) (t '//)))=0A=
(t '/)))=0A=
nil mathrt)=0A=
=0A=
(set-macro-character #\^=0A=
#'(lambda =0A=
(stream char)=0A=
(declare (ignore char))=0A=
(case (pc)=0A=
(#\newline '^)=0A=
(#\=3D (rc) '^=3D)=0A=
(#\^ (rc) '^^)=0A=
(#\: (rc)=0A=
(case (pc) (#\newline '|^:|) (#\=3D (rc) '|^:=3D|) (t '|^:|)))=0A=
(t '^)))=0A=
nil mathrt)=0A=
=0A=
(set-macro-character #\&=0A=
#'(lambda (stream char)=0A=
(declare (ignore char))=0A=
(case (pc) (#\newline '&) (#\& (rc) '&&) (t '&)))=0A=
nil mathrt)=0A=
=0A=
(set-macro-character #\|=0A=
#'(lambda (stream char)=0A=
(declare (ignore char))=0A=
(case (pc) (#\newline '\|) (#\| (rc) '\|\|) (t '\|)))=0A=
nil mathrt)=0A=
=0A=
=0A=
=0A=
(set-macro-character #\+=0A=
#'(lambda (stream char)=0A=
(declare (ignore char))=0A=
(case (pc)=0A=
(#\newline '+) (#\+ (rc) '++) (#\=3D (rc) '+=3D) (t '+)))=0A=
nil mathrt)=0A=
=0A=
(set-macro-character #\*=0A=
#'(lambda (stream char)=0A=
(declare (ignore char))=0A=
(case (pc) (#\newline '*) (#\* (rc) '**) (#\=3D (rc) '*=3D) (t =
'*)))=0A=
nil mathrt) =0A=
=0A=
(set-macro-character #\-=0A=
#'(lambda =0A=
(stream char)=0A=
(declare (ignore char))=0A=
(case (pc)=0A=
(#\newline '-) (#\> (rc) '->) (#\=3D (rc) '-=3D) (#\- (rc) '--) (t =
'-)))=0A=
nil mathrt)=0A=
=0A=
(set-macro-character #\[=0A=
#'(lambda (stream char)=0A=
(declare (ignore char))=0A=
(case (pc)=0A=
(#\newline '[) (#\[ (rc) '[[) (t '[))) =0A=
nil mathrt)=0A=
=0A=
(set-macro-character #\]=0A=
#'(lambda (stream char)=0A=
(declare (ignore char))=0A=
(case (pc) (#\newline ']) (#\] (rc) ']]) (t '])))=0A=
nil mathrt)=0A=
=0A=
(set-macro-character #\{=0A=
#'(lambda (stream char)=0A=
(declare (ignore char)) =0A=
'{) ; fixed 2/21/91 lvi at ida.liu.se=0A=
nil mathrt) =0A=
=0A=
(set-macro-character #\<=0A=
#'(lambda (stream char)=0A=
(declare (ignore char))=0A=
(case (pc) (#\newline '<) (#\=3D (rc) '<=3D) (t '<)))=0A=
nil mathrt) =0A=
=0A=
(set-macro-character #\>=0A=
#'(lambda (stream char)=0A=
(declare (ignore char))=0A=
(case (pc)=0A=
(#\newline '>)=0A=
(#\=3D (rc) '>=3D)=0A=
(#\> (rc)=0A=
(case (pc) (#\newline '>>) (#\> (rc) '>>>) (t '>>)))=0A=
(t '>)))=0A=
nil mathrt) =0A=
=0A=
(set-macro-character #\!=0A=
#'(lambda (stream char)=0A=
(declare (ignore char))=0A=
(case (pc) (#\newline '!) (#\! (rc) '!!) (#\=3D (rc) '!=3D) (t =
'!)))=0A=
nil mathrt) =0A=
=0A=
(set-macro-character #\#=0A=
#'(lambda (stream char)=0A=
(declare (ignore char))=0A=
(case (pc) (#\newline '|#|) (#\# (rc) '|##|) (t '|#|)))=0A=
nil mathrt)=0A=
=0A=
(set-macro-character #\\ =0A=
#'(lambda(stream char)=0A=
(declare (ignore char))=0A=
(case (pc)=0A=
(#\newline (rc) (mread1)) ;; \ at end of line -> splice=0A=
(t (intern (make-string 1 :initial-element (rc))))=0A=
; \ within line, ignore the \ and return the next char=0A=
))=0A=
nil mathrt)=0A=
=0A=
(set-macro-character #\=3D =0A=
#'(lambda(stream char)=0A=
(declare (ignore char))=0A=
(case (pc)=0A=
(#\newline '|=3D|)=0A=
(#\=3D (rc) =0A=
(case(pc) (#\newline '|=3D=3D|) (#\=3D (rc) '|=3D=3D=3D|) (t =
'|=3D=3D|)))=0A=
(#\! (rc) (case(pc)=0A=
(#\newline '|=3D!|) ;unused=0A=
(#\=3D (rc) '|=3D!=3D|)=0A=
(t '|=3D!|)))=0A=
(t '|=3D|))) nil mathrt)=0A=
=0A=
(set-macro-character #\. =0A=
#'(lambda (stream char)=0A=
(declare (ignore char))=0A=
(case (pc)=0A=
(#\newline '|.|)=0A=
(#\. (rc) =0A=
(case (pc)=0A=
(#\newline '|..|) (#\. (rc) '|...|) (t '|..|)))=0A=
(t '|.|)))=0A=
nil mathrt)=0A=
=0A=
(set-macro-character #\:=0A=
#'(lambda (stream char)=0A=
(declare (ignore char))=0A=
(case (pc)=0A=
(#\newline '|:|)=0A=
(#\> (rc) '|:>|)=0A=
(#\: (rc)=0A=
(case (pc) =0A=
(#\newline '|::|) (#\=3D (rc) '|::=3D|) (t '|::|)))=0A=
(#\=3D (rc) '|:=3D|)=0A=
(t '|:|)))=0A=
nil mathrt)=0A=
=0A=
(set-macro-character #\' #'(lambda (stream char)=0A=
(declare (ignore char))=0A=
'|'|) nil mathrt) =0A=
=0A=
(set-macro-character #\@ #'(lambda (stream char)=0A=
(declare (ignore char))=0A=
(case (pc) (#\newline '@)(#\@ (rc) '@@)(t '@)))=0A=
nil mathrt) =0A=
;; above fixed by lvi at ida.liu 3/20/92=0A=
=0A=
(set-macro-character #\~ #'(lambda (stream char) (declare (ignore char))=0A=
'~) nil mathrt) =0A=
(set-macro-character #\? #'(lambda (stream char) (declare (ignore char))=0A=
'?) nil mathrt) =0A=
(set-macro-character #\) #'(lambda (stream char) (declare (ignore char))=0A=
'|)|) nil mathrt) =0A=
(set-macro-character #\} #'(lambda (stream char) (declare (ignore char))=0A=
'}) nil mathrt) =0A=
(set-macro-character #\; #'(lambda (stream char) (declare (ignore char))=0A=
'|;|) nil mathrt) =0A=
(set-macro-character #\, #'(lambda (stream char) (declare (ignore =
char))=0A=
'|,|) nil mathrt) =0A=
(set-macro-character #\newline #'(lambda(stream char) (declare (ignore =
char))=0A=
'e-o-l) nil mathrt)=0A=
=0A=
(mapc #'(lambda(x) (setf (get x 'mathtoken) T))=0A=
'(/ |/:| /. /@ |/;| /=3D // //@ //.=0A=
^ ^=3D ^^ |^:=3D| |^:| =0A=
& && \| \|\| + ++ +=3D ** *=3D =0A=
- -> -=3D -- [ [[ ] ]] { } > >=3D >> >>> < <=3D=0A=
! !! !=3D =0A=
|#| |##|=0A=
|:=3D| |:>| |::| |::=3D| |:|=0A=
|=3D| |=3D=3D| |=3D=3D=3D| |=3D!=3D|=0A=
|.| |..| |...| \\ =0A=
e-o-l |(| |)|=0A=
|'| @ ~ ? |;| |,|))=0A=
=0A=
;; Extension. This allows us to use foo[*,1]*bar[1,*] notationally.=0A=
;; also a * * means (Times a *)=0A=
;;(setf (get '* 'mathtoken t))=0A=
=0A=
(set-macro-character #\_=0A=
#'(lambda (stream char &aux next)=0A=
(declare (ignore char))=0A=
(case=0A=
(pc)=0A=
(#\Newline '(Blank)) ; _=0A=
(#\. (rc)=0A=
'(Optional (Blank))) ;_.=0A=
(#\_ (rc)=0A=
(case=0A=
(pc)=0A=
(#\Newline '(BlankSequence)) ;__=0A=
(#\_=0A=
(rc) ;___ (3 of em)=0A=
(cond ((and (alpha-char-p (pc))=0A=
(setq next(rt)))=0A=
`(BlankNullSequence ,next))=0A=
(t '(BlankNullSequence)))) =0A=
(t ;; __ (2 of em)=0A=
(cond ((and (alpha-char-p (pc))=0A=
(setq next(rt)))=0A=
`(BlankSequence ,next))=0A=
(t '(BlankSequence))) =0A=
))) =0A=
(t ; _ (1 of em)=0A=
(cond ((and (alpha-char-p (pc))=0A=
(setq next(rt)))=0A=
`(Blank ,next))=0A=
(t '(Blank))))))=0A=
nil=0A=
mathrt)=0A=
=0A=
;; left paren could start a comment=0A=
=0A=
=0A=
(defun sawlpar (stream char) ;; comments are (* any text *)=0A=
(declare (ignore char))=0A=
(case (pc)=0A=
(#\* ;skip to end of comment=0A=
(rc)=0A=
(commentskip stream))=0A=
(t '\())) ;)=0A=
=0A=
(set-macro-character #\( #'sawlpar nil mathrt) ;)=0A=
=0A=
;; the use of the % character is peculiar.=0A=
(set-macro-character #\% =0A=
#'(lambda(stream char)=0A=
(declare (ignore char))=0A=
(cond((eq(pc) #\%) (parse-outform1 2))=0A=
((digit-char-p (pc))=0A=
`(Out,(collect-integer 0 10)))=0A=
(t '(Out))))=0A=
nil mathrt)=0A=
=0A=
(defun parse-outform1(counter) ; saw more than one % =0A=
(rc)=0A=
(cond ((equal (pc) #\%) (parse-outform1 (+ 1 counter))) ;another %=0A=
(t `(Out ,(- counter)))))=0A=
=0A=
=0A=
(defun commentskip (stream &aux x )=0A=
(loop=0A=
(setq x (rc))=0A=
(cond ((eql x #\( ) (sawlpar stream x)) =0A=
((and (eql x #\* )=0A=
(eql (pc) #\) ))=0A=
(rc) ; flush the last leftpar=0A=
(return(mread1))) ;return next item=0A=
)))=0A=
=0A=
;;; end of the lexical analysis part=0A=
;;----------------------------------------------------------=0A=
;;; The Parser=0A=
;; You can use (p) to try out the parser by typing in from the=0A=
;; keyboard. It sets up the readtable and calls parse-comp.=0A=
=0A=
;; Reading from lines is set up so that if a sentence ends at=0A=
;; an end-of-line, the parse is completed. Otherwise, the e-o-l=0A=
;; is absorbed and the reading continued. A continuation line=0A=
;; can be forced by a \. (This is Mathematica's usual operation)=0A=
=0A=
(defvar interactive t) ; t means 2 eol's ends a command. not for files.=0A=
=0A=
=0A=
=0A=
;; ps will read from a Mathematica stream // print to std output=0A=
;; e.g. (ps (open "foo.text"))=0A=
=0A=
(defun ps(stream &aux (interactive nil) res (*readtable* =
mathrt)(mathbuffer nil)z)=0A=
=0A=
(rt)=0A=
(loop (setq res (catch 'endofparse(parse-comp t))) ;; end=3Dt means a =
#\newline will end expr.=0A=
(print (cond ;((null res) (return 'done))=0A=
((eq #\newline (pc)) =0A=
(rc) =0A=
res) ;; proper ending=0A=
((setq z(rt))=0A=
(cond ((equal z 'e-o-l)) ;;may also be proper ending=0A=
(t(format t "~%garbage at end of expression:~s~%" z )))=0A=
res)))))=0A=
=0A=
(defun psm ;; (meval (parse ( stream-from-file)))=0A=
(stream &aux (interactive nil) res (*readtable* mathrt)(mathbuffer =
nil)z)=0A=
=0A=
(rt)=0A=
(loop (setq res (catch 'endofparse(parse-comp t))) ;; end=3Dt means a =
#\newline will end expr.=0A=
(print (cond ;((null res) (return 'done))=0A=
((eq #\newline (pc)) =0A=
(rc) =0A=
res) ;; proper ending=0A=
((setq z(meval(rt))) ;;; call meval on stuff read in.=0A=
(cond ((equal z 'e-o-l)) ;;may also be proper ending=0A=
(t(format t "~%garbage at end of expression:~s~%" z )))=0A=
res)))))=0A=
=0A=
=0A=
=0A=
=0A=
;mreadl is a debugging loop that just reads lexemes until it reads done=0A=
=0A=
(defun mreadl(&aux (stream *standard-input* ) next (*readtable* mathrt))=0A=
(loop =0A=
(setq next (mread1))=0A=
(when (eq next 'e-o-l) (return 'done))=0A=
(print next)))=0A=
=0A=
(defmacro rt()`(cond((null mathbuffer)(mread1))=0A=
(t (prog1 mathbuffer (setq mathbuffer nil )))))=0A=
=0A=
(defmacro eolp(end) ;;used all over to see if we've reached an end of =
line=0A=
`(and ,end (eq 'e-o-l (peek-token))))=0A=
=0A=
;; this function reads a token. Although it looks like it=0A=
;; just reads a lisp s-expression or number, it uses a different=0A=
;; read-table. If mread1 encounters a #\newline, it returns the=0A=
;; atom e-o-l, as specified in the read-table.=0A=
(defun mread1()=0A=
;; (format t "~% next char =3D ~s" (pc))=0A=
(cond ((member (pc)'( #\space #\tab #\page) :test #'char=3D)=0A=
(rc)(mread1)) ;; fix - 2x bug=0A=
((digit-char-p (pc));; next character is a digit 0-9=0A=
(collect-integer =0A=
(char-to-int(read-char stream)) 10)) ;radix 10 default=0A=
(t (or(read-preserving-whitespace stream nil 'e-o-l) 'False)=0A=
;; nil reads as False=0A=
)))=0A=
=0A=
(defun p (&optional(stream *standard-input*) =0A=
&aux (interactive t)=0A=
res=0A=
(*readtable* mathrt)=0A=
(mathbuffer nil))=0A=
; (rt) ;;get something in mathbuffer=0A=
(setq res (catch 'endofparse (parse-comp t))) ;; end=3Dt means a =
#\newline will end expr.=0A=
(cond((eq mathbuffer 'e-o-l) (if res res 'Null)) ;; proper ending=0A=
(t (format t "~%Unexpected token at end of expression:~s~%" =
mathbuffer)=0A=
res)))=0A=
=0A=
(defun peek-token() (cond(mathbuffer)=0A=
(t (setq mathbuffer(mread1)))))=0A=
=0A=
(defun parse-nary1 (res tag)=0A=
(cond ((null(cdr res))(car res))=0A=
(t (cons tag (nreverse res)))))=0A=
=0A=
(defun guess-token (guess &aux (tok (peek-token)))=0A=
(cond((eql guess tok) t)=0A=
((eql 'e-o-l tok)(rt)=0A=
(if (and interactive (eql'e-o-l (peek-token))) ;; if two in-a-row; get =
outta here=0A=
(throw 'endofparse nil)))))=0A=
=0A=
;; a variable is any symbol that looks like a lisp symbol and=0A=
;; is not an integer or string, or a pattern-var=0A=
=0A=
(defun var-p(token)=0A=
(or (consp token) ;; case of (blank)=0A=
(and =0A=
(not (integerp token))=0A=
(not (eql token 'e-o-l))=0A=
(or (stringp token) (not (get token 'mathtoken))))))=0A=
=0A=
;; is Head one of the pattern items "blank..."=0A=
(defun blankp(token)=0A=
(and(not (atom token))=0A=
(member (car token) '(Blank BlankSequence BlankNullSequence=0A=
Optional ;; 10/28/94=0A=
) :test #'eql)))=0A=
=0A=
=0A=
;; parse a number=0A=
(defun parse-number(end &aux (x (parse-int end)) afterdot) ;; reads =
floats and radix nums also=0A=
(cond (x=0A=
(cond =0A=
((equal (pc) #\.); is the very next character a "."?=0A=
(rc) ;; remove exactly that character.=0A=
;; note: in Mathematica, 1. 2 is 1.0*2 =3D 2.0=0A=
;; 1 .2 is 1*0.2 =3D 0.2=0A=
;; 1 . 2 is Dot[1,2]=0A=
;;Now check: Is there a digit next?=0A=
(cond((digit-char-p (pc))=0A=
(setq afterdot (parse-frac end))=0A=
(cond (afterdot (make-real x afterdot)) ;;like 12.34=0A=
(t x))); not a float -> return integer=0A=
(t (make-real x 0)) ;a float of the form 1. =0A=
))=0A=
(t x))) ;;x is an integer, but no "." follows=0A=
;; still, we must check for a number of the form .123=0A=
((guess-token '|.|)=0A=
(rt)=0A=
;;is there a digit next?=0A=
(cond((digit-char-p (pc))=0A=
(setq afterdot (parse-frac end))=0A=
(cond (afterdot (make-real 0 afterdot)) ;;like 0.34=0A=
(t "what's a dot doing here?")))));; we could make it 0?=0A=
(t nil) ))=0A=
=0A=
=0A=
=0A=
;;parse an integer, including radix=0A=
=0A=
(defun parse-int(end &aux (x (peek-token))) =0A=
(cond =0A=
((integerp x)=0A=
(cond=0A=
((eolp end) x)=0A=
((and (rt) (eql (pc) #\^) ;; don't sop up extra spaces here. what if =
1 .2=0A=
(guess-token '|^^|)) ;; see if it is, e.g. 8^^101 =3D65=0A=
(rt)=0A=
(cond((or (> x 10)=0A=
(< x 2))=0A=
(format t "radix ~s ?~%" x)))=0A=
(collect-integer 0 x))=0A=
(t x))) ;; ok, no radix stuff -- just return x=0A=
(t nil)))=0A=
=0A=
;; parse the fraction part of a decimal number .123=0A=
=0A=
(defun parse-frac(end &aux x (num 0)(den 1))=0A=
(loop=0A=
;; since all of the line termination chars are not digits, all we=0A=
;; need to check is for digits..=0A=
(if (not(setq x(digit-char-p (pc)))) (return (/ num den)))=0A=
(rc) ;; read past the char=0A=
(setq den (* den 10))=0A=
(setq num (+ (* 10 num) x))=0A=
))=0A=
=0A=
;; this is a stub until we decide what to really do here=0A=
(defun make-real (x y) `(Real ,x ,y))=0A=
=0A=
;; parse lists delimited by [] [[]]{} tricky to handle f[g[x]].=0A=
(defun parse-list (&optional op &aux next)=0A=
(setq next (peek-token))=0A=
(cond ((equal next '|[[|)=0A=
(rt)=0A=
(parselist1 (list op 'Part) '|]]|))=0A=
((equal next '\[)=0A=
(rt)=0A=
(parselist1 (list op) '\]))=0A=
((equal next '\{)=0A=
(rt)=0A=
(parselist1 (list 'List) '\}))))=0A=
=0A=
(defun parselist1 (sofar endmark &aux next) ;; we want to find an =
expression=0A=
(setq next (peek-token))=0A=
(cond ((eq next '\,)=0A=
(rt);; get past the comma=0A=
(parselist1 (cons nil sofar) endmark))=0A=
((eq next endmark)=0A=
(rt);; get past the endmark [a,b,]=0A=
(cond ((null (cdr sofar)) sofar ) ;; f[] -> (f)=0A=
(t(nreverse (cons nil sofar)))))=0A=
((and(eq endmark '\]) ;; we might find a '|]]|=0A=
(parse-list-hack next (cons nil sofar))))=0A=
((setq next (parse-comp nil)) ;; end=3Dnil; can't end with just =
#\newline=0A=
(parselist2 (cons next sofar) endmark))=0A=
(t (error "parse-list: looking for a comma, expression or endmark"))=0A=
))=0A=
(defun parse-list-hack(next sofar) ;make f[g[h]] work ok by parsing as=0A=
;; f[g[h] ]=0A=
(cond ((equal next '\])=0A=
(rt)=0A=
(nreverse sofar))=0A=
((equal next '|]]|)=0A=
(setq mathbuffer '\]) ; one '\] left over for f[g[h]]=0A=
(nreverse sofar))))=0A=
=0A=
(defun parselist2 (sofar endmark &aux next) ;; we want to find , or =
close mark=0A=
(setq next (peek-token))=0A=
(cond ((equal next '\,)=0A=
(rt);; get past the comma=0A=
(parselist1 sofar endmark))=0A=
((equal next endmark) (rt) (nreverse sofar ))=0A=
((and(equal endmark '\]) ;; we might find a '|]]|=0A=
(parse-list-hack next sofar)))=0A=
(t (error "parse-list: looking for a comma, expression or endmark"))=0A=
))=0A=
=0A=
;;comparison operators=0A=
(setf (get '=3D=3D 'compop) 'Equal)=0A=
(setf (get '!=3D 'compop) 'Unequal)=0A=
(setf (get '< 'compop) 'Less)=0A=
(setf (get '<=3D 'compop) 'LessEqual)=0A=
(setf (get '> 'compop) 'Greater)=0A=
(setf (get '>=3D 'compop) 'GreaterEqual)=0A=
(setf (get '=3D=3D=3D 'sameop) 'SameQ)=0A=
(setf (get '=3D!=3D 'sameop) 'UnSameQ)=0A=
=0A=
;; sample parses. All comparisons of 3 or more items are questionable,=0A=
;; but this is what Mathematica does...=0A=
;; a<b<c (Less a b c)=0A=
;; a>b<c (Inequality a Greater b Less c) ;but=0A=
;; a>b=3D=3Dc (Equal (Greater a b) c) ;--- associates to left=0A=
;; a=3D=3Db=3D=3Dc (Equal a b c) ; meaning (And (Equal a b)(Equal b c))=0A=
;; but no duplicate evaluation of b; yet=0A=
;; (a=3D=3Db)=3D=3Dc (Equal (Equal a b) c) ;; not the same -- a=3D=3Db =
is True or False=0A=
;; a=3D=3D(b=3D=3Dc) (Equal a (Equal b c))=0A=
;; a=3D=3Db!=3Dc (Unequal (Equal a b) c)=0A=
;; a!=3Db=3D=3Dc (Equal (Unequal a b) c)=0A=
;; a+b=3D=3Dc (Equal (Plus a b) c)=0A=
=0A=
(defun parse-or (end &aux (temp (parse-and end)) res) ; E::=3De1||e2 =
n-ary=0A=
(cond ((eolp end) temp)=0A=
(temp=0A=
(cond ((guess-token '\|\|) ;;check first to avoid consing=0A=
(setq res (cons temp nil))=0A=
(loop=0A=
(cond ((eolp end) (return(parse-nary1 res 'Or)))=0A=
((guess-token '\|\|)=0A=
(rt)=0A=
(setq res (cons (parse-and end) res)))=0A=
(t (return(parse-nary1 res 'Or)))=0A=
)))=0A=
(t temp)))=0A=
(t nil) ; not an or-expression=0A=
))=0A=
=0A=
(defun parse-and (end &aux (temp (parse-not end)) res) ; E::=3De1 && e2 =
n-ary (And)=0A=
(cond ((eolp end) temp)=0A=
(temp=0A=
(cond ((guess-token '&&) ;;check first to avoid consing=0A=
(setq res (cons temp nil))=0A=
(loop=0A=
(cond ((eolp end)(return(parse-nary1 res 'And)))=0A=
((guess-token '&&)=0A=
(rt)=0A=
(setq res (cons (parse-not end) res)))=0A=
(t (return(parse-nary1 res 'And)))=0A=
)))=0A=
(t temp)))=0A=
(t nil) ; not an and-expression=0A=
))=0A=
=0A=
(defun parse-not(end)=0A=
(cond((eolp end) nil)=0A=
((guess-token '|!|) ;; Not=0A=
(rt)=0A=
`(Not ,(parse-not end)))=0A=
(t (parse-same end))))=0A=
=0A=
;; this definition does not handle 3-way or more comparisons quite=0A=
;; the same as Mathematica. =0A=
;; a=3D=3D=3Db is (SameQ a b) but a=3D!=3Db=3D=3D=3Dc is (Inequality a =
SameQ b SameQ c)=0A=
;; rather than (Sameq (UnSameQ a b) c).=0A=
;; reason: probably Mathematica is wrong; probably the feature is unused=0A=
;; and hence un-noticed.=0A=
=0A=
(defun parse-same (end &aux (temp (parse-equal end))res op) ; E::=3De1 =
=3D=3D=3De2 etc=0A=
(cond ((eolp end) temp)=0A=
(temp=0A=
(setq op (peek-token))=0A=
(cond ((and (atom op)(get op 'sameop)) ;; check before cons=0A=
;;SameQ=0A=
(setq res (cons temp nil))=0A=
(loop=0A=
(cond ((eolp end) =0A=
(return (patch-equal(parse-nary1 res 'Inequality))))=0A=
((and (atom (setq op (peek-token)))=0A=
(setq op (get op 'sameop)))=0A=
(rt)=0A=
(setq res (cons (parse-equal end) (cons op res))))=0A=
(t (return (patch-equal(parse-nary1 res 'Inequality))))=0A=
)))=0A=
(t temp)))=0A=
(t nil) ; not a SameQ or UnSameQ=0A=
))=0A=
=0A=
(defun parse-equal (end &aux (temp (parse-plus end))res op) ; E::=3De1 =
compop e2 n-ary (=3D=3D, etc)=0A=
(cond ((eolp end) temp)=0A=
(temp=0A=
(setq op (peek-token))=0A=
(cond ((and (atom op)(get op 'compop)) ;; check before cons=0A=
;;Unequal, for example=0A=
(setq res (cons temp nil))=0A=
(loop=0A=
(cond ((eolp end) (return (patch-equal(parse-nary1 res 'Inequality))))=0A=
((and (atom (setq op (peek-token)))=0A=
(setq op (get op 'compop)))=0A=
(rt)=0A=
(setq res (cons (parse-plus end) (cons op res))))=0A=
(t (return (patch-equal(parse-nary1 res 'Inequality))))=0A=
)))=0A=
(t temp)))=0A=
(t nil) ; not an equal or inequal -expression=0A=
))=0A=
(defun patch-equal(h)=0A=
(if (=3D (length h) 4)(list (caddr h) (cadr h)(cadddr h)) h))=0A=
;; arithmetic expression=0A=
=0A=
(defun parse-plus (end &aux (temp (parse-times end)) res); E::=3DT1{+T2} =
| T1{-T2}=0A=
(cond (temp=0A=
(cond =0A=
((eolp end) temp)=0A=
((or (guess-token '+)(guess-token '-))=0A=
(setq res (cons temp nil)) =0A=
(loop=0A=
(cond ((eolp end) (return (parse-nary1 res 'Plus)))=0A=
((guess-token '+)=0A=
(rt)=0A=
(setq res (cons (parse-times end) res)))=0A=
((guess-token '-)=0A=
(rt)=0A=
(setq res (cons =0A=
=0A=
(let ((h (parse-times end)))=0A=
(if (numberp h) (- h)=0A=
`(Times -1 ,h)=0A=
)) res)))=0A=
(t (return(parse-nary1 res 'Plus))))))=0A=
(t temp)))=0A=
(t nil)) ; not a Plus expr=0A=
)=0A=
=0A=
(defun parse-comp (end &aux temp res ) ; E::=3DE;E; | E;=0A=
(cond ((setq temp (parse-put end))=0A=
(cond ((eolp end) temp)=0A=
((guess-token '|;|) ;;check first to avoid consing=0A=
(setq res (cons (if temp temp 'Null) nil))=0A=
(loop=0A=
(cond ((eolp end) (return(parse-nary1 res 'CompoundExpression)))=0A=
((guess-token '|;|)=0A=
(rt)=0A=
(setq res (cons (or(parse-put end) 'Null) res)))=0A=
(t(return (parse-nary1 res 'CompoundExpression))))))=0A=
(t temp)))=0A=
(t nil)) ; not a compound expr -- something wrong --=0A=
)=0A=
=0A=
=0A=
=0A=
=0A=
(defun parse-put( end &aux (temp (parse-set end))) ; e >> file or =
e>>>file=0A=
(cond(temp=0A=
(cond((eolp end) temp)=0A=
((guess-token '>>)(rt)`(Put ,temp ,(rt)))=0A=
((guess-token '>>>)(rt)`(PutAppend ,temp ,(rt)))=0A=
(t temp)))=0A=
(t nil)))=0A=
=0A=
;;replace is left-assoc e /. e | e//.e=0A=
;; 11/18/94 RJF=0A=
(defun parse-replace( end &aux(temp(parse-alternatives end)))=0A=
(cond (temp (parse-replace1 temp end))=0A=
(t nil)))=0A=
#| formerly=0A=
(defun parse-replace( end &aux(temp(parse-rule end)))=0A=
(cond (temp (parse-replace1 temp end))=0A=
(t nil)))=0A=
|#=0A=
=0A=
(defun parse-replace1(temp end)=0A=
(cond ((eolp end) temp)=0A=
((guess-token '|/.|)=0A=
(rt)=0A=
(parse-replace1 `(ReplaceAll ,temp ,(parse-replace end)) end))=0A=
((guess-token '|//.|)=0A=
(rt)=0A=
(parse-replace1 `(ReplaceRepeated ,temp ,(parse-replace end)) end))=0A=
(t temp)))=0A=
=0A=
;; added 11/18/94; RJF=0A=
;; I do not know if the precedence implied by this=0A=
;; is entirely accurate wrt Mathematica.=0A=
=0A=
(defun parse-alternatives=0A=
(end &aux (temp (parse-rule end)) res) ; E::=3De1 \| e2 n-ary =
(Alternatives)=0A=
=0A=
(cond ((eolp end) temp)=0A=
(temp=0A=
(cond ((guess-token '|\|| ) ;;check first to avoid consing=0A=
(setq res (cons temp nil))=0A=
(loop=0A=
(cond ((eolp end)(return(parse-nary1 res 'Alternatives)))=0A=
((guess-token '|\||)=0A=
(rt)=0A=
(setq res (cons (parse-rule end) res)))=0A=
(t (return(parse-nary1 res 'Alternatives)))=0A=
)))=0A=
(t temp)))=0A=
(t nil) ; not an Alternatives-expression=0A=
))=0A=
=0A=
(defun parse-rule(end &aux (temp (parse-condition end))) ;e->(e->e) etc=0A=
(cond(temp (cond ((eolp end) temp)=0A=
((guess-token '|->|)=0A=
(rt)=0A=
`(Rule ,temp ,(parse-rule end)))=0A=
((guess-token '|:>|)=0A=
(rt)=0A=
`(RuleDelayed ,temp ,(parse-rule end)))=0A=
(t temp)))=0A=
(t nil)))=0A=
=0A=
;;condition is left-assoc=0A=
(defun parse-condition( end &aux(temp(parse-repeated end)))=0A=
(cond (temp (parse-condition1 temp end))=0A=
(t nil)))=0A=
=0A=
(defun parse-condition1(temp end)=0A=
(cond ((eolp end) temp)=0A=
((guess-token '|/;|)=0A=
(rt)=0A=
(parse-condition1 `(Condition ,temp ,(parse-repeated=0A=
end)) end))=0A=
(t temp)))=0A=
=0A=
=0A=
(defun parse-repeated(end &aux (temp (parse-or end)))=0A=
(cond (temp =0A=
(cond((eolp end) temp)=0A=
((guess-token '|..|)(rt)`(Repeated ,temp))=0A=
((guess-token '|...|)(rt)`(RepeatedNull ,temp))=0A=
(t temp)))=0A=
(t nil)))=0A=
=0A=
=0A=
(defun parse-addto(end &aux (temp (parse-replace end)))=0A=
;; bug noticed by /fixed by lvi at ida.liu.se=0A=
(cond (temp=0A=
(cond =0A=
((eolp end) temp)=0A=
((guess-token '|+=3D|)(rt)`(AddTo ,temp ,(parse-addto end)))=0A=
((guess-token '|*=3D|)(rt)`(TimesBy ,temp ,(parse-addto end)))=0A=
((guess-token '|-=3D|)(rt)`(SubtractFrom ,temp ,(parse-addto end)))=0A=
((guess-token '|/=3D|)(rt)`(DivideBy ,temp ,(parse-addto end)))=0A=
(t temp)))=0A=
(t nil)))=0A=
=0A=
=0A=
(defun parse-set(end &aux (temp (parse-// end)) )=0A=
(cond (temp=0A=
(cond ((eolp end) temp)=0A=
((guess-token '=3D)(rt)=0A=
(cond ((guess-token '|.|)(rt)`(UnSet-1 ,temp))=0A=
(t`(Set-1 ,temp ,(parse-set end)))))=0A=
((guess-token '|:=3D|)(rt)`(SetDelayed-1 ,temp ,(parse-set end)))=0A=
((guess-token '^=3D ) (rt)`(UpSet-1 ,temp ,(parse-set end)))=0A=
((guess-token '|^:=3D| ) (rt)`(UpSetDelayed-1 ,temp ,(parse-set =
end)))=0A=
((guess-token '|/:| ) (rt)`(TagSet-1 ,temp ,(parse-set end)))=0A=
;;actually, Mathematica uses TagSet Delayed, Un. =0A=
((guess-token '|::=3D| ) (rt)=0A=
(cond =0A=
((guess-token '|.|)(rt)`(UnAlias-1 ,temp))=0A=
(t`(Alias-1 ,temp ,(parse-set end)))))=0A=
(t temp)))=0A=
(t nil)))=0A=
=0A=
;; f&[a,b] --> ((Function f) a b)=0A=
(defun parse-ampersand(end &aux temp)=0A=
(cond((setq temp (parse-addto end))=0A=
(cond ((eolp end) temp)=0A=
((eq (peek-token) '\&) (rt)(parse-fun1 `(Function ,temp) end))=0A=
(t temp)))=0A=
(t nil)))=0A=
=0A=
;;left associative e1//e2 =0A=
(defun parse-//(end &aux (temp (parse-ampersand end)))=0A=
(cond (temp=0A=
(cond ((eolp end) temp)=0A=
((guess-token '|//|)(rt)=0A=
(parse-//1 `(,(parse-ampersand end) ,temp) end))=0A=
(t temp)))=0A=
(t nil)))=0A=
=0A=
(defun parse-//1(sofar end) =0A=
(cond ((eolp end) sofar)=0A=
((guess-token '|//|) =0A=
(rt)=0A=
(parse-//1 `(,(parse-ampersand end) ,sofar) end))=0A=
(t sofar)))=0A=
=0A=
=0A=
(defun parse-times(end &aux (temp (parse-unary end))res) ;=0A=
; t::=3Df1{*f2} | f1{/f2} | f1 <space> f2 =0A=
(cond ((eolp end) temp)=0A=
(temp =0A=
(setq res (cons temp nil))=0A=
(loop=0A=
(cond ((eolp end)(return (parse-nary1 res 'Times)))=0A=
((guess-token '*)=0A=
(rt)=0A=
;; a * !b+c is (Times a (Not (Plus b c)))=0A=
(setq res (cons (parse-unary end)res)))=0A=
((guess-token '/)=0A=
(rt)=0A=
;; patch 1/11/96 RJF to make 1/2 come out as 1/2=0A=
;; rather than (Times 1(Power 2 -1)).=0A=
;; This helped in a pattern matching application=0A=
;; so I put it in here too.=0A=
(let ((denom (parse-unary end)))=0A=
(setf res=0A=
(if (numberp denom)=0A=
(if (numberp (car res))=0A=
;; combine numerator and denominator, numerically=0A=
(cons (/ (car res) denom) (cdr res))=0A=
;; just tack on number like 1/2=0A=
(cons (/ 1 denom) res))=0A=
(cons `(Power ,denom -1) res))))=0A=
;; previously I just did this...=0A=
;;(setq res (cons `(Power ,(parse-unary end) -1) res))=0A=
)=0A=
;; note that a / b c =3D (a * b^-1 *c) not (a* (b*c)^-1)=0A=
=0A=
;; this implements the kludge a x =3D a*x=0A=
;; can't tolerate a +b =3D=3D> (Times a b), and +b is b...=0A=
;; hence use parse-power, not parse-not=0A=
=0A=
((setq temp (parse-power end)) (setq res (cons temp res)))=0A=
(t (return (parse-nary1 res 'Times))))))=0A=
(t nil) ; not a term=0A=
))=0A=
(defun parse-unary (end &aux) ; E::=3D+T | -T=0A=
(cond ((guess-token '+)(rt)(parse-unary end)) ;unary +=0A=
((guess-token '-)(rt)=0A=
(let ((h (parse-unary end)))=0A=
(if (numberp h) (- h)=0A=
`(Times -1 ,h))))=0A=
((guess-token '|!| )(parse-not end))=0A=
;;; extra added attraction!! 'foo -> (Quote foo)=0A=
((guess-token '|'|) (rt)`(Quote, (parse-unary end)))=0A=
(t (parse-power end))))=0A=
=0A=
(defun parse-power (end &aux (temp (parse-dot end))) ; f ::=3D p^f | p=0A=
(cond ;((eolp end) temp)=0A=
(temp=0A=
(cond ((eolp end) temp)=0A=
((guess-token '^)=0A=
(rt)=0A=
`(Power ,temp ,(parse-unary end))) ;;really going up the precedence=0A=
(t temp)))=0A=
(t nil)))=0A=
=0A=
=0A=
(defun parse-dot (end &aux (temp (parse-ncm end))res) ; E::=3De1 . e2 =
n-ary dot=0A=
(cond (temp=0A=
(cond ((eolp end) temp)=0A=
((guess-token '|.|) ;;check first to avoid consing=0A=
(setq res (cons temp nil))=0A=
(loop=0A=
(cond ((eolp end) (return (parse-nary1 res 'Dot)))=0A=
((guess-token '|.|)=0A=
(rt)=0A=
(setq res (cons (parse-ncm end) res)))=0A=
(t (return (parse-nary1 res 'Dot))))))=0A=
(t temp)))=0A=
(t nil) ; not a dot-expression=0A=
))=0A=
=0A=
(defun parse-ncm (end &aux (temp (parse-fact end)) res) ; E::=3De1 ** e2 =
n-ary =0A=
(cond (temp=0A=
(cond ((eolp end) temp)=0A=
((guess-token '**) ;;check first to avoid consing=0A=
(setq res (cons temp nil))=0A=
(loop=0A=
(cond =0A=
((eolp end)=0A=
(return =0A=
(parse-nary1 res=0A=
'NonCommutativeMultiply)))=0A=
((guess-token '**)=0A=
(rt)=0A=
(setq res (cons (parse-fact end) res)))=0A=
(t (return (parse-nary1 res 'NonCommutativeMultiply))))))=0A=
(t temp)))=0A=
(t nil) ; not a **-expression=0A=
))=0A=
=0A=
=0A=
;;factorial is left-associative a ! ! means (a!)!=0A=
=0A=
(defun parse-fact (end &aux (temp (parse-map end))) ; d ::=3D m | m! | =
m!!=0A=
(cond (temp (parse-fact1 temp end))=0A=
(t nil)))=0A=
=0A=
(defun parse-fact1 (temp end) ; d ::=3D m | m! | m!!=0A=
(cond((eolp end) temp)=0A=
((guess-token '|!|)=0A=
(rt)=0A=
(parse-fact1 `(Factorial ,temp) end))=0A=
((guess-token '|!!|)=0A=
(rt)=0A=
(parse-fact1 `(Factorial2 ,temp) end))=0A=
(t temp)))=0A=
=0A=
(defun parse-map =0A=
(end &aux (temp (parse-tilde (parse-at end) end))) ; d ::=3D t | t /@ =
expr=0A=
(cond ((eolp end) temp)=0A=
(temp=0A=
(cond ((guess-token '|/@|)=0A=
(rt)=0A=
`(Map ,temp ,(parse-map end)))=0A=
((guess-token '|//@|)=0A=
(rt)=0A=
`(MapAll ,temp ,(parse-map end))) =0A=
((guess-token '|@@|)=0A=
(rt)=0A=
`(Apply ,temp ,(parse-map end)))=0A=
(t temp)))=0A=
(t nil)))=0A=
=0A=
=0A=
(defun parse-tilde(sofar end &aux op last )=0A=
(cond ((null sofar)nil)=0A=
((eolp end) sofar)=0A=
(t(cond ((and =0A=
(guess-token '|~|) (rt)=0A=
(setq op (parse-at nil))=0A=
(guess-token '|~|)(rt)=0A=
(setq last (parse-at end)))=0A=
(parse-tilde `(,op ,sofar ,last) end))=0A=
(t sofar)))))=0A=
=0A=
(defun parse-precrement(end);; look for ++a or --a ;lvi fix for ++ ++ a=0A=
(cond ;((eolp end) nil)=0A=
((guess-token '|++|)(rt) `(PreIncrement ,(parse-precrement end)))=0A=
((guess-token '|--|)(rt) `(PreDecrement ,(parse-precrement end)))=0A=
(t (parse-fun end))))=0A=
=0A=
(defun parse-pattest(end &aux (temp (parse-var end))) ; patterntest is =
e1?e2=0A=
(cond (temp=0A=
(cond ((eolp end) temp)=0A=
((guess-token '\?)=0A=
(rt)=0A=
`(PatternTest ,temp ,(parse-var end)))=0A=
(t temp)))=0A=
(t nil)))=0A=
=0A=
(defvar rpar '\) )=0A=
(defvar lpar '\( )=0A=
=0A=
;;parse-optional looks for Optional a_:v is (Optional(Pattern a =
(Blank)) v)=0A=
=0A=
(defun parse-optional (end &aux (temp (parse-pattest end)) temp2)=0A=
(cond (temp =0A=
(cond=0A=
((eolp end) temp)=0A=
((guess-token '\:) =0A=
(rt)=0A=
(if (null (setf temp2 (parse-comp end))) ;10/28/94 RJF=0A=
(list 'Optional temp)=0A=
(list 'Optional temp temp2)))=0A=
(t temp)))=0A=
(t temp)))=0A=
=0A=
; var ::=3D var_ etc| #var | _ | __ | ___ | patternstuff | var :: =
string=0A=
;( stuff ) | ( a , ....) | { a , ...} | number =0A=
=0A=
(defun parse-var (end &aux (next (peek-token))) =0A=
(cond ((eql next 'e-o-l)=0A=
(rt)=0A=
(setq next (peek-token))=0A=
(cond ((eql next 'e-o-l) nil)=0A=
(t (parse-var end))))=0A=
((var-p next)=0A=
(rt)=0A=
(cond ((eolp end) next)=0A=
((blankp (peek-token))=0A=
(if (eql (car (peek-token)) 'Optional) ;; 10/28/94 RJF=0A=
`(Optional (Pattern ,next ,@(cdr(rt))))=0A=
(list 'Pattern next (rt))))=0A=
=0A=
((guess-token '|::|) (rt) (list 'MessageName next (rt)))=0A=
((guess-token '|:|)(rt)(list 'Pattern next (parse-repeated end)))=0A=
(t next)))=0A=
((equal next lpar) ;; look for (expr)=0A=
;; actually (a,b,..), a Sequence is not accepted in 2.0, but in 1.2=0A=
(rt)=0A=
(setq next (parse-comp nil))=0A=
(cond ((guess-token rpar)=0A=
(rt)=0A=
next)=0A=
((parselist2 (list next 'Sequence) rpar))=0A=
(t (error "too few rpars"))))=0A=
((equal next '{) (rt) ;; look for List=0A=
(cond ((guess-token '})=0A=
(rt)=0A=
(list 'List))=0A=
((setq next (parse-comp nil)) ;lvi 8/29=0A=
(parselist2 (list next 'List) '}))=0A=
(t=0A=
(error "too few right-}"))))=0A=
((equal next '|#|)=0A=
(parse-slotform 'Slot end))=0A=
((equal next '|##|)=0A=
(parse-slotform 'SlotSequence end))=0A=
#+ignore ((and (setq hh (peek-token)) (format t "hh=3D~s" hh)=0A=
(equal hh'(Optional (Blank))))=0A=
(rt) ;;example x_. 3/30/92=0A=
`(Optional(Pattern ,next (Blank))))=0A=
=0A=
((setq next (parse-number end))=0A=
;;(if (atom next) (list 'Integer next) next);;tags integers =
specifically=0A=
next;; just leaves integers as self-declared, exact.=0A=
)=0A=
(t nil)))=0A=
=0A=
;; # means (Slot 1) ## means (SlotSequence 1)=0A=
;; #2 means (Slot 2) etc.=0A=
=0A=
(defun parse-slotform(head end &aux var)=0A=
(rt) ;; sop up # or ##=0A=
(cond((null (setq var(parse-int end)))`(,head 1))=0A=
(t `(,head ,var))))=0A=
=0A=
=0A=
(defun parse-at (end &aux (var (parse-precrement end))) =0A=
;; collect e1 @ e2 | e++ | e--=0A=
(cond (var =0A=
(cond ((eolp end) var) =0A=
((guess-token `|@|) (rt) `(,var ,(parse-at end)))=0A=
((guess-token '|++|) (rt) `(Increment ,var)) =0A=
((guess-token '|--|) (rt) `(Decrement ,var))=0A=
(t var)))=0A=
(t nil)))=0A=
=0A=
;; parse-fun collects f[x] or similar; also a++=0A=
;; it is left-assoc. f[x]=3D(f x); f[x][y] =3D ((f x) y)=0A=
=0A=
(defun parse-fun(end &aux (temp(parse-optional end)))=0A=
(cond (temp (parse-fun1 temp end))=0A=
(t nil)))=0A=
=0A=
;; parser must handle the following cases:=0A=
;; f' --> ((Derivative 1) f)=0A=
;; f'x --> (Times ((Derivative 1) f) x)=0A=
;; f'[x] --> (((Derivative 1) f) x)=0A=
;; f'' --> ((Derivative 2) f)=0A=
=0A=
=0A=
=0A=
(defun parse-fun1(sofar end)=0A=
(cond((eolp end) sofar)=0A=
;; handle the derivative cases=0A=
((eq (peek-token) '|'|)=0A=
(do ((i 0 (1+ i)))=0A=
((or (eolp end)(not (guess-token '|'| )))=0A=
(parse-fun1 `((Derivative ,i) ,sofar) end))=0A=
(rt)))=0A=
;; handle the function invocation f[x] and part .. f[[1]]=0A=
((member(peek-token) '(\[ |[[|) :test #'eq)=0A=
(parse-fun1(parse-list sofar) end));; f[], f[x] or maybe (f[x])[y] etc.=0A=
=0A=
=0A=
(t sofar)))=0A=
=0A=
=0A=
;; some extensions/ modifications=0A=
;; 1. we parse a=3D=3Db>c as (Inequality a Equal b Greater c) =0A=
;; 2. integers are parsed as (for example) 4, not (Integer 4) ;;optional=0A=
;; (we could do this so we can eventually tag integers with other info=0A=
;; like precision, accuracy, base)=0A=
;; 3. integer args to % and # are just lisp integers.=0A=
;; 4. real numbers like 1.20 are simply (Real 1 20) for the=0A=
;; same reason as for integers.=0A=
;; (Mathematica has such info stashed away in secret)=0A=
;; 5. within " " we allow any number of newlines even interactively. M =
allows 2=0A=
;; 6. we count lines consisting only of (*comments*) as newlines=0A=
;; 7 optional.. (commented out) 123`456`789 syntax for long bignumber =
input=0A=
=0A=
;;known bugs or features(?) 1/90=0A=
=0A=
;; we support radix only between 2 and 10; blame it on laziness=0A=
;; we do not support non-decimal radix flt. pt; blame it on ditto.=0A=
;; we do TagSet slightly differently; ditto=0A=
=0A=
=0A=
;; fixed bugs/new features 1/91 -- RJF=0A=
=0A=
;; typing nil provides the symbol False, not nil. I don't know if=0A=
;; this is a bug or a feature, though. It means that the parser will=0A=
;; not think it has failed to parse a subexpression when it merely =0A=
;; has parsed the symbol nil, so it is convenient, anyway.=0A=
;; Mma has the symbol Null, perhaps for similar reasons.=0A=
=0A=
;; fixed 1/28/91=0A=
;; fixed the parsing a_:v of which is now=0A=
;; (Optional (Pattern a (Blank)) v).=0A=
;; fixed the parsing of #1+#2&[a,b] to ((Function (Plus (Slot 1)(Slot =
2))) a b)=0A=
;; fixed 2/15/91 parsing of a**b followed by eol=0A=
=0A=
;; added 2/3/91=0A=
=0A=
;; 'a is same as Quote[a]. f' is derivative, though. 'f'a is=0A=
;; (Times (Quote ((Derivative 1)f)) a). This is not in conflict with =
mma.=0A=
=0A=
;; added 2/15/91=0A=
;; the symbol * can be used, in some circumstances, as a variable name.=0A=
;; In those circumstances where it cannot be confused with an operator,=0A=
;; it can be used as a symbol. In some cases it can be used as a symbol=0A=
;; even if YOU confuse it. Advantages: you can use it as a =
regular-expression=0A=
;; tag like foo[*,3] to denote the 3rd column of a matrix.=0A=
=0A=
;; You can use * * * to mean (Times * *) although *^2 (Power * 2) =
also=0A=
;; works. The expressions x * * y and x * * * y mean (Times x * y).=0A=
;; The expression ( * * ) means (Times * *) =0A=
=0A=
;; BUT NOTE THAT (* ANYTHING *) is A COMMENT !!!! :) =0A=
=0A=
;; fixed 5/29/91 from lvi at ida.liu.se =0A=
;; fixed parsing of a+=3Db;c from a=3D+(b;c) to (a=3D+b);c.=0A=
;; fixed ++ ++ a also.=0A=
;; 8/29/91 bug fix from lars viklund (lvi at ida,liu.se)=0A=
;; in parse var, replace parse-set by parse-comp (twice)=0A=
;; 11/23/91 bug fix to repair parsing of 1.004 (was same as 1.4) using =0A=
;; parse-frac. This was pointed out by gotoda at is.s.u-tokyo.ac.jp=0A=
=0A=
;; this next item allows one to do, in lisp, (setq r #mx^2-1=0A=
;; )=0A=
=0A=
;; 10/28/94. Optionals in patterns were not parsing right c_. was=0A=
;; parsing as (Times c (Optional (Blank))). It should be=0A=
;; (Optional(Pattern C (Blank)))=0A=
=0A=
;; a_: was parsing as (Optional (Pattern a (Blank))nil) instead of=0A=
;; (Optional (Pattern a (Blank))) . fixed.=0A=
=0A=
(set-dispatch-macro-character #\# #\m=0A=
#'(lambda (stream sub-char infix-argument)=0A=
(declare (ignore sub-char infix-argument))=0A=
(list 'quote(p stream) )))=0A=
;;; 11/18/94=0A=
;; had to recompile for new version of allegro common lisp=0A=
;; the Alternatives form was added to mathematica... how about for=0A=
;; this parser?=0A=
=0A=
=0A=
;; remove the special meaning of "|" from the emacs reader of lisp code=0A=
;; and change it to inherit from the standard syntax table=0A=
=0A=
=0A=
#+Allegro (eval-when (eval load)=0A=
(when (find-package :lep)=0A=
(let ((s (find-symbol (symbol-name :*connection*) :lep)))=0A=
(and (boundp s)=0A=
(symbol-value s)=0A=
(fboundp 'lep::eval-in-emacs)=0A=
(progn=0A=
(lep::eval-in-emacs "(modify-syntax-entry 124 \"@\")")=0A=
(format t "~%modified | syntax for compatibility with mma"))))))=0A=
=0A=
=0A=
------=_NextPart_000_0023_01C64604.C4F80580
Content-Type: application/octet-stream;
name="math-1.lisp"
Content-Transfer-Encoding: quoted-printable
Content-Disposition: attachment;
filename="math-1.lisp"
(defun take-or-null (p) (if (eq (car p) 'PATTERN) (car (cdr p)) nil))
(defmacro SET-1 (var val)=20
(if (atom var)=20
`((MSET) (quote ,var) ,val)=20
`((MDEFINE) ,(cons (list (car var)) (mapcar 'take-or-null (cdr var))=20
) ,(progn ;;(print (mfuncall '$ev val))
(mfuncall '$ev val))
)))
(defmacro SETDELAYED-1 (var val)=20
(if (atom var)=20
`((MSET) (quote ,var) ',val)=20
`((MDEFINE) ,(cons (list (car var)) (mapcar 'take-or-null (cdr var))=20
) ,val)))
;; 1) Mathematica hash tables like f[x] need additional effords for =
implemantaion in MAXIMA
;; 2) MAXIMA definition of function is connected with the name (VS) - =
with the parameters list in Mathematica
(defparameter accordance-table '((PLUS . (MPLUS)) (TIMES . (MTIMES)) =
(EXP . (MEXP)) (LIST . (MLIST)) (LOG . (%LOG)) (SIN . (%SIN)) (COS . =
(%COS))
)
)
(defun Math () (meval (macroexpand (sublis accordance-table (p))))))
(defun mtest() (meval (macroexpand (sublis accordance-table (p (open =
"e:/siver/develop/mma1.6/test.txt")))))))
(defmacro COMPOUNDEXPRESSION (&rest li) (dolist (e li)=20
;;(progn ;;(print e)=20
(meval (macroexpand e)))=20
;;)
)
;; to calculate the value call ev every time
------=_NextPart_000_0023_01C64604.C4F80580
Content-Type: text/plain;
name="test.txt"
Content-Transfer-Encoding: 7bit
Content-Disposition: attachment;
filename="test.txt"
a=0;b=a+1;f[x_]=a+x;a=1;c:=a+1;g[x_,y_]:=x+y+a;a=2
------=_NextPart_000_0023_01C64604.C4F80580--
More information about the Maxima
mailing list