mirror of
https://github.com/PDP-10/its.git
synced 2026-03-02 01:50:24 +00:00
This fixes the declare command in macsyma.
Also updates a bunch of Macsyma sources to latest versions, which was needed to get declare working with consistent sources. Resolves #960.
This commit is contained in:
Eric Swenson
@@ -527,12 +527,13 @@ respond "*" "(quit)"
|
||||
|
||||
respond "*" "aljabr\033\023"
|
||||
respond "*" ":lisp\r"
|
||||
type "(load \"libmax;module\")"
|
||||
respond "132170" "(load \"libmax;define\")"
|
||||
respond "134541" "(load \"libmax;maxmac\")"
|
||||
respond "140351" "(load \"libmax;displm\")"
|
||||
respond "141162" "(load \"aljabr;loader\")"
|
||||
respond "T" "(loader 999)"
|
||||
type "(load \"lisp;mlsub\")"
|
||||
respond "124656" "(load \"libmax;module\")"
|
||||
respond "133046" "(load \"libmax;define\")"
|
||||
respond "135417" "(load \"libmax;maxmac\")"
|
||||
respond "141227" "(load \"libmax;displm\")"
|
||||
respond "142040" "(load \"aljabr;loader\")"
|
||||
respond "T" "(loader 1000)"
|
||||
respond "(C1)" "quit();"
|
||||
|
||||
respond "*" ":link sys3;ts macsym,maxdmp;loser >\r"
|
||||
|
||||
964
src/jpg/comm.415
Normal file
964
src/jpg/comm.415
Normal file
@@ -0,0 +1,964 @@
|
||||
;; -*- Mode: Lisp; Package: Macsyma; -*-
|
||||
|
||||
;; (c) Copyright 1976, 1984 Massachusetts Institute of Technology
|
||||
;; All Rights Reserved.
|
||||
|
||||
;; Enhancements (c) Copyright 1984 Symbolics Inc.
|
||||
;; All Rights Reserved.
|
||||
|
||||
;; The data and information in the Enhancements are proprietary to, and
|
||||
;; a valuable trade secret of, SYMBOLICS, INC., a Delaware corporation.
|
||||
;; They are given in confidence by SYMBOLICS, pursuant to the license
|
||||
;; agreement between Symbolics and their recipient, and may not be used,
|
||||
;; reproduced, or copied, or distributed to any other party, in whole or
|
||||
;; in part, without the prior written consent of SYMBOLICS except as
|
||||
;; permitted by the license agreement.
|
||||
|
||||
(macsyma-module comm)
|
||||
|
||||
(DECLARE (GENPREFIX C)
|
||||
(SPECIAL $EXPTSUBST $LINECHAR $NOLABELS $INFLAG $PIECE $DISPFLAG
|
||||
$GRADEFS $PROPS $DEPENDENCIES DERIVFLAG DERIVLIST
|
||||
$LINENUM $PARTSWITCH LINELABLE NN* DN* ISLINP
|
||||
$POWERDISP ATVARS ATP $ERREXP $DERIVSUBST $DOTDISTRIB
|
||||
$OPSUBST $SUBNUMSIMP $TRANSRUN IN-P SUBSTP $SQRTDISPFLAG
|
||||
$PFEFORMAT DUMMY-VARIABLE-OPERATORS)
|
||||
(*LEXPR FACTOR)
|
||||
(FIXNUM I N LARGL LVRS COUNT TIM (SIGNUM1)))
|
||||
|
||||
(PROG1 '(OP and OPR properties)
|
||||
(MAPC #'(LAMBDA (X) (PUTPROP (CAR X) (CADR X) 'OP)
|
||||
(PUTPROP (CADR X) (CAR X) 'OPR))
|
||||
'((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 &!) (MARROW &->) (MPROGN &/()
|
||||
(MCOND &IF)))
|
||||
(MAPC #'(LAMBDA (X) (PUTPROP (CAR X) (CADR X) 'OP))
|
||||
'((MQAPPLY $SUBVAR) (BIGFLOAT $BFLOAT)))
|
||||
(MAPC #'(LAMBDA (X) (PUTPROP (CAR X) (CADR X) 'OPR))
|
||||
#-(or Franz Multics)
|
||||
'((|&and| MAND) (|&or| MOR) (|¬| MNOT) (|&if| MCOND))
|
||||
#+(or Franz Multics)
|
||||
'((|&AND| MAND) (|&OR| MOR) (|&NOT| MNOT) (|&IF| MCOND))))
|
||||
|
||||
(SETQ $EXPTSUBST NIL $PARTSWITCH NIL $INFLAG NIL $GRADEFS '((MLIST SIMP))
|
||||
$DEPENDENCIES '((MLIST SIMP)) ATVARS '(&@1 &@2 &@3 &@4) ATP NIL
|
||||
ISLINP NIL LNORECURSE NIL &** '&^ $DERIVSUBST NIL TIMESP NIL
|
||||
$OPSUBST T IN-P NIL SUBSTP NIL)
|
||||
|
||||
(DEFMVAR $VECT_CROSS NIL
|
||||
"If TRUE allows DIFF(X~Y,T) to work where ~ is defined in
|
||||
SHARE;VECT where VECT_CROSS is set to TRUE.")
|
||||
|
||||
(DEFMFUN $SUBSTITUTE N
|
||||
(COND ((= N 2)
|
||||
(LET ((L (ARG 1)) (Z (ARG 2)))
|
||||
(COND ((AND ($LISTP L) ($LISTP (CADR L)) (NULL (CDDR L)))
|
||||
($SUBSTITUTE (CADR L) Z))
|
||||
((NOTLOREQ L) (IMPROPER-ARG-ERR L '$SUBSTITUTE))
|
||||
((EQ (CAAR L) 'MEQUAL) (SUBSTITUTE (CADDR L) (CADR L) Z))
|
||||
(T (DO ((L (CDR L) (CDR L))) ((NULL L) Z)
|
||||
(SETQ Z ($SUBSTITUTE (CAR L) Z)))))))
|
||||
((= N 3) (SUBSTITUTE (ARG 1) (ARG 2) (ARG 3)))
|
||||
(T (WNA-ERR '$SUBSTITUTE))))
|
||||
|
||||
(DECLARE (SPECIAL X Y OPRX OPRY NEGXPTY TIMESP))
|
||||
|
||||
(DEFMFUN SUBSTITUTE (X Y Z) ; The args to SUBSTITUTE are assumed to be simplified.
|
||||
(LET ((IN-P T) (SUBSTP T))
|
||||
(IF (AND (MNUMP Y) (= (SIGNUM1 Y) 1))
|
||||
(LET ($SQRTDISPFLAG ($PFEFORMAT T)) (SETQ Z (NFORMAT-ALL Z))))
|
||||
(SIMPLIFYA
|
||||
(IF (ATOM Y)
|
||||
(COND ((EQUAL Y -1)
|
||||
(SETQ Y '((MMINUS) 1)) (SUBST2 (NFORMAT-ALL Z)))
|
||||
(T (LET ((OPRX (GETOPR X)) (OPRY (GETOPR Y)))
|
||||
(SUBST1 Z))))
|
||||
(LET ((NEGXPTY (IF (AND (EQ (CAAR Y) 'MEXPT)
|
||||
(= (SIGNUM1 (CADDR Y)) 1))
|
||||
(MUL2 -1 (CADDR Y))))
|
||||
(TIMESP (IF (EQ (CAAR Y) 'MTIMES) (SETQ Y (NFORMAT Y)))))
|
||||
(SETQ SUBSTP 'MQAPPLY) (SUBST2 Z)))
|
||||
NIL)))
|
||||
|
||||
(DEFUN SUBST1 (Z) ; Y is an atom
|
||||
(COND ((ATOM Z) (IF (EQUAL Y Z) X Z))
|
||||
((SPECREPP Z) (SUBST1 (SPECDISREP Z)))
|
||||
((EQ (CAAR Z) 'BIGFLOAT) Z)
|
||||
((AND (EQ (CAAR Z) 'RAT) (OR (EQUAL Y (CADR Z)) (EQUAL Y (CADDR Z))))
|
||||
(DIV (SUBST1 (CADR Z)) (SUBST1 (CADDR Z))))
|
||||
((AT-SUBSTP Z) Z)
|
||||
((AND (EQ Y T) (EQ (CAAR Z) 'MCOND))
|
||||
(LIST (NCONS (CAAR Z)) (SUBST1 (CADR Z)) (SUBST1 (CADDR Z))
|
||||
(CADDDR Z) (SUBST1 (CAR (CDDDDR Z)))))
|
||||
(T (LET ((MARGS (MAPCAR #'SUBST1 (CDR Z))))
|
||||
(IF (AND $OPSUBST
|
||||
(OR (EQ OPRY (CAAR Z))
|
||||
(AND (EQ (CAAR Z) 'RAT) (EQ OPRY 'MQUOTIENT))))
|
||||
(IF (OR (NUMBERP X)
|
||||
(MEMQ X '(T NIL $%E $%PI $%I))
|
||||
(AND (NOT (ATOM X))
|
||||
(NOT (OR (EQ (CAR X) 'LAMBDA)
|
||||
(EQ (CAAR X) 'LAMBDA)))))
|
||||
(IF (OR (AND (MEMQ 'ARRAY (CDAR Z))
|
||||
(OR (AND (MNUMP X) $SUBNUMSIMP)
|
||||
(AND (NOT (MNUMP X)) (NOT (ATOM X)))))
|
||||
($SUBVARP X))
|
||||
(LET ((SUBSTP 'MQAPPLY))
|
||||
(SUBST0 (LIST* '(MQAPPLY) X MARGS) Z))
|
||||
(MERROR
|
||||
"Attempt to substitute ~M for ~M in ~M~
|
||||
~%Illegal substitution for operator of expression"
|
||||
X Y Z))
|
||||
(SUBST0 (CONS (NCONS OPRX) MARGS) Z))
|
||||
(SUBST0 (CONS (NCONS (CAAR Z)) MARGS) Z))))))
|
||||
|
||||
(DEFUN SUBST2 (Z)
|
||||
(LET (NEWEXPT)
|
||||
(COND ((ATOM Z) Z)
|
||||
((SPECREPP Z) (SUBST2 (SPECDISREP Z)))
|
||||
((AT-SUBSTP Z) Z)
|
||||
((ALIKE1 Y Z) X)
|
||||
((AND TIMESP (EQ (CAAR Z) 'MTIMES) (ALIKE1 Y (SETQ Z (NFORMAT Z)))) X)
|
||||
((AND (EQ (CAAR Y) 'MEXPT) (EQ (CAAR Z) 'MEXPT) (ALIKE1 (CADR Y) (CADR Z))
|
||||
(SETQ NEWEXPT (COND ((ALIKE1 NEGXPTY (CADDR Z)) -1)
|
||||
($EXPTSUBST (EXPTHACK (CADDR Y) (CADDR Z))))))
|
||||
(LIST '(MEXPT) X NEWEXPT))
|
||||
((AND $DERIVSUBST (EQ (CAAR Y) '%DERIVATIVE) (EQ (CAAR Z) '%DERIVATIVE)
|
||||
(ALIKE1 (CADR Y) (CADR Z)))
|
||||
(LET ((TAIL (SUBST-DIFF-MATCH (CDDR Y) (CDR Z))))
|
||||
(COND ((NULL TAIL) Z)
|
||||
(T (CONS (NCONS (CAAR Z)) (CONS X (CDR TAIL)))))))
|
||||
(T (RECUR-APPLY #'SUBST2 Z)))))
|
||||
|
||||
(DECLARE (UNSPECIAL X Y OPRX OPRY NEGXPTY TIMESP))
|
||||
|
||||
(DEFMFUN SUBST0 (NEW OLD)
|
||||
(COND ((ALIKE (CDR NEW) (CDR OLD))
|
||||
(COND ((EQ (CAAR NEW) (CAAR OLD)) OLD)
|
||||
(T (SIMPLIFYA (CONS (CONS (CAAR NEW) (MEMQ 'ARRAY (CDAR OLD))) (CDR OLD))
|
||||
NIL))))
|
||||
((MEMQ 'ARRAY (CDAR OLD))
|
||||
(SIMPLIFYA (CONS (CONS (CAAR NEW) '(ARRAY)) (CDR NEW)) NIL))
|
||||
(T (SIMPLIFYA NEW NIL))))
|
||||
|
||||
(DEFUN EXPTHACK (Y Z)
|
||||
(PROG (NN* DN* YN YD ZN ZD QD)
|
||||
(COND ((AND (MNUMP Y) (MNUMP Z))
|
||||
(RETURN (IF (NUMBERP (SETQ Y (DIV* Z Y))) Y)))
|
||||
((ATOM Z) (IF (NOT (MNUMP Y)) (RETURN NIL)))
|
||||
((OR (RATNUMP Z) (EQ (CAAR Z) 'MPLUS)) (RETURN NIL)))
|
||||
(NUMDEN Y) ; (CSIMP) sets NN* and DN*
|
||||
(SETQ YN NN* YD DN*)
|
||||
(NUMDEN Z)
|
||||
(SETQ ZN NN* ZD DN*)
|
||||
(SETQ QD (COND ((AND (EQUAL ZD 1) (EQUAL YD 1)) 1)
|
||||
((PROG2 (NUMDEN (DIV* ZD YD))
|
||||
(AND (EQUAL DN* 1) (EQUAL NN* 1)))
|
||||
1)
|
||||
((EQUAL NN* 1) (DIV* 1 DN*))
|
||||
((EQUAL DN* 1) NN*)
|
||||
(T (RETURN NIL))))
|
||||
(NUMDEN (DIV* ZN YN))
|
||||
(IF (EQUAL DN* 1) (RETURN (DIV* NN* QD)))))
|
||||
|
||||
(DEFUN SUBST-DIFF-MATCH (L1 L2)
|
||||
(DO ((L L1 (CDDR L)) (L2 (APPEND L2 NIL)) (FAILED NIL NIL))
|
||||
((NULL L) L2)
|
||||
(DO ((L2 L2 (CDDR L2)))
|
||||
((NULL (CDR L2)) (SETQ FAILED T))
|
||||
(IF (ALIKE1 (CAR L) (CADR L2))
|
||||
(IF (AND (FIXNUMP (CADR L))
|
||||
(FIXNUMP (CADDR L2)))
|
||||
(COND ((< (CADR L) (CADDR L2))
|
||||
(RETURN (RPLACD (CDR L2)
|
||||
(CONS (- (CADDR L2) (CADR L))
|
||||
(CDDDR L2)))))
|
||||
((= (CADR L) (CADDR L2))
|
||||
(RETURN (RPLACD L2 (CDDDR L2))))
|
||||
(T (RETURN (SETQ FAILED T))))
|
||||
(RETURN (SETQ FAILED T)))))
|
||||
(IF FAILED (RETURN NIL))))
|
||||
|
||||
(DEFUN AT-SUBSTP (Z)
|
||||
(AND ATP (OR (MEMQ (CAAR Z) '(%DERIVATIVE %DEL))
|
||||
(MEMQ (CAAR Z) DUMMY-VARIABLE-OPERATORS))))
|
||||
(DEFMFUN RECUR-APPLY (FUN E)
|
||||
(COND ((EQ (CAAR E) 'BIGFLOAT) E)
|
||||
((SPECREPP E) (FUNCALL FUN (SPECDISREP E)))
|
||||
(T (LET ((NEWARGS (MAPCAR FUN (CDR E))))
|
||||
(IF (ALIKE NEWARGS (CDR E))
|
||||
E
|
||||
(SIMPLIFYA (CONS (CONS (CAAR E) (MEMQ 'ARRAY (CDAR E))) NEWARGS)
|
||||
NIL))))))
|
||||
|
||||
(DEFMFUN $DEPENDS N
|
||||
(IF (ODDP N) (MERROR "DEPENDS takes an even number of arguments."))
|
||||
(DO ((I 1 (+ I 2)) (L))
|
||||
((> I N) (I-$DEPENDENCIES (NREVERSE L)))
|
||||
(COND (($LISTP (ARG I))
|
||||
(DO L1 (CDR (ARG I)) (CDR L1) (NULL L1)
|
||||
(SETQ L (CONS (DEPENDS1 (CAR L1) (ARG (1+ I))) L))))
|
||||
(T (SETQ L (CONS (DEPENDS1 (ARG I) (ARG (1+ I))) L))))))
|
||||
|
||||
(DEFUN DEPENDS1 (X Y)
|
||||
(NONSYMCHK X '$DEPENDS)
|
||||
(CONS (NCONS X) (IF ($LISTP Y) (CDR Y) (NCONS Y))))
|
||||
|
||||
(DEFMSPEC $DEPENDENCIES (FORM) (I-$DEPENDENCIES (CDR FORM)))
|
||||
|
||||
(DEFMFUN I-$DEPENDENCIES (L)
|
||||
(DOLIST (Z L)
|
||||
(COND ((ATOM Z) (MERROR "Wrong format. Try F(X)."))
|
||||
((OR (EQ (CAAR Z) 'MQAPPLY) (MEMQ 'ARRAY (CDAR Z)))
|
||||
(MERROR "Improper form for DEPENDS:~%~M" Z))
|
||||
(T (LET ((Y (MGET (CAAR Z) 'DEPENDS)))
|
||||
(MPUTPROP (CAAR Z)
|
||||
(SETQ Y (UNION* (REVERSE (CDR Z)) Y))
|
||||
'DEPENDS)
|
||||
(ADD2LNC (CONS (NCONS (CAAR Z)) Y) $DEPENDENCIES)))))
|
||||
(CONS '(MLIST SIMP) L))
|
||||
|
||||
(DEFMSPEC $GRADEF (L) (SETQ L (CDR L))
|
||||
(LET ((Z (CAR L)) (N 0))
|
||||
(COND ((ATOM Z)
|
||||
(IF (NOT (= (LENGTH L) 3)) (MERROR "Wrong arguments to GRADEF"))
|
||||
(MPUTPROP Z
|
||||
(CONS (CONS (CADR L) (MEVAL (CADDR L)))
|
||||
(MGET Z '$ATOMGRAD))
|
||||
'$ATOMGRAD)
|
||||
(I-$DEPENDENCIES (NCONS (LIST (NCONS Z) (CADR L))))
|
||||
(ADD2LNC Z $PROPS)
|
||||
Z)
|
||||
((OR (MOPP1 (CAAR Z)) (MEMQ 'ARRAY (CDAR Z)))
|
||||
(MERROR "Wrong arguments to GRADEF:~%~M" Z))
|
||||
((PROG2 (SETQ N (- (LENGTH Z) (LENGTH L))) (MINUSP N))
|
||||
(WNA-ERR '$GRADEF))
|
||||
(T (DO ZL (CDR Z) (CDR ZL) (NULL ZL)
|
||||
(IF (NOT (SYMBOLP (CAR ZL)))
|
||||
(MERROR "Parameters to GRADEF must be names:~%~M"
|
||||
(CAR ZL))))
|
||||
(SETQ L (NCONC (MAPCAR #'(LAMBDA (X) (REMSIMP (MEVAL X)))
|
||||
(CDR L))
|
||||
(MAPCAR #'(LAMBDA (X) (LIST '(%DERIVATIVE) Z X 1))
|
||||
(NTHCDR (- (LENGTH Z) N) Z))))
|
||||
(PUTPROP (CAAR Z)
|
||||
(SUBLIS (MAPCAR #'CONS (CDR Z) (MAPCAR #'STRIPDOLLAR (CDR Z)))
|
||||
(CONS (CDR Z) L))
|
||||
'GRAD)
|
||||
(ADD2LNC (CONS (NCONS (CAAR Z)) (CDR Z)) $GRADEFS)
|
||||
Z))))
|
||||
|
||||
(DEFMFUN $DIFF N (LET (DERIVLIST) (DERIV (LISTIFY N))))
|
||||
|
||||
(DEFMFUN $DEL (E) (STOTALDIFF E))
|
||||
|
||||
(DEFUN DERIV (E)
|
||||
(PROG (EXP Z COUNT)
|
||||
(COND ((NULL E) (WNA-ERR '$DIFF))
|
||||
((NULL (CDR E)) (RETURN (STOTALDIFF (CAR E))))
|
||||
((NULL (CDDR E)) (NCONC E '(1))))
|
||||
(SETQ EXP (CAR E) Z (SETQ E (APPEND E NIL)))
|
||||
LOOP (IF (OR (NULL DERIVLIST) (MEMBER (CADR Z) DERIVLIST)) (GO DOIT))
|
||||
; DERIVLIST is set by $EV
|
||||
(SETQ Z (CDR Z))
|
||||
LOOP2(COND ((CDR Z) (GO LOOP))
|
||||
((NULL (CDR E)) (RETURN EXP))
|
||||
(T (GO NOUN)))
|
||||
DOIT (COND ((NONVARCHECK (CADR Z) '$DIFF))
|
||||
((NULL (CDDR Z)) (WNA-ERR '$DIFF))
|
||||
((NOT (FIXNUMP (CADDR Z))) (GO NOUN))
|
||||
((MINUSP (SETQ COUNT (CADDR Z)))
|
||||
(MERROR "Improper count to DIFF:~%~M" COUNT)))
|
||||
LOOP1(COND ((ZEROP COUNT) (RPLACD Z (CDDDR Z)) (GO LOOP2))
|
||||
((EQUAL (SETQ EXP (SDIFF EXP (CADR Z))) 0) (RETURN 0)))
|
||||
(SETQ COUNT (1- COUNT))
|
||||
(GO LOOP1)
|
||||
NOUN (RETURN (DIFF%DERIV (CONS EXP (CDR E))))))
|
||||
|
||||
(DEFUN CHAINRULE (E X)
|
||||
(LET (W)
|
||||
(COND (ISLINP (IF (AND (NOT (ATOM E))
|
||||
(EQ (CAAR E) '%DERIVATIVE)
|
||||
(NOT (FREEL (CDR E) X)))
|
||||
(DIFF%DERIV (LIST E X 1))
|
||||
0))
|
||||
((ATOMGRAD E X))
|
||||
((NOT (SETQ W (MGET (COND ((ATOM E) E)
|
||||
((MEMQ 'ARRAY (CDAR E)) (CAAR E))
|
||||
((ATOM (CADR E)) (CADR E))
|
||||
(T (CAAADR E)))
|
||||
'DEPENDS)))
|
||||
0)
|
||||
(T (LET (DERIVFLAG)
|
||||
(ADDN (MAPCAR
|
||||
#'(LAMBDA (U)
|
||||
(LET ((Y (SDIFF U X)))
|
||||
(IF (EQUAL Y 0)
|
||||
0
|
||||
(LIST '(MTIMES)
|
||||
(OR (ATOMGRAD E U)
|
||||
(LIST '(%DERIVATIVE) E U 1))
|
||||
Y))))
|
||||
W)
|
||||
NIL))))))
|
||||
|
||||
(DEFUN ATOMGRAD (E X)
|
||||
(LET (Y) (AND (ATOM E) (SETQ Y (MGET E '$ATOMGRAD)) (ASSOLIKE X Y))))
|
||||
|
||||
(DEFUN DEPENDS (E X)
|
||||
(COND ((ALIKE1 E X) T)
|
||||
((MNUMP E) NIL)
|
||||
((ATOM E) (MGET E 'DEPENDS))
|
||||
(T (OR (DEPENDS (CAAR E) X) (DEPENDSL (CDR E) X)))))
|
||||
|
||||
(DEFUN DEPENDSL (L X) (DOLIST (U L) (IF (DEPENDS U X) (RETURN T))))
|
||||
|
||||
(DEFMFUN SDIFF (E X) ; The args to SDIFF are assumed to be simplified.
|
||||
(COND ((ALIKE1 E X) 1)
|
||||
((MNUMP E) 0)
|
||||
((OR (ATOM E) (MEMQ 'ARRAY (CDAR E))) (CHAINRULE E X))
|
||||
((EQ (CAAR E) 'MRAT) (RATDX E X))
|
||||
((EQ (CAAR E) 'MPLUS) (ADDN (SDIFFMAP (CDR E) X) T))
|
||||
((MBAGP E) (CONS (CAR E) (SDIFFMAP (CDR E) X)))
|
||||
((MEMQ (CAAR E) '(%SUM %PRODUCT)) (DIFFSUMPROD E X))
|
||||
((NOT (DEPENDS E X)) 0)
|
||||
((EQ (CAAR E) 'MTIMES) (ADDN (SDIFFTIMES (CDR E) X) T))
|
||||
((EQ (CAAR E) 'MEXPT) (DIFFEXPT E X))
|
||||
((EQ (CAAR E) 'MNCTIMES)
|
||||
(LET (($DOTDISTRIB T))
|
||||
(ADD2 (NCMULN (CONS (SDIFF (CADR E) X) (CDDR E)) T)
|
||||
(NCMUL2 (CADR E) (SDIFF (CONS '(MNCTIMES) (CDDR E)) X)))))
|
||||
((AND $VECT_CROSS (EQ (CAAR E) '|$~|))
|
||||
(ADD2* `((|$~|) ,(CADR E) ,(SDIFF (CADDR E) X))
|
||||
`((|$~|) ,(SDIFF (CADR E) X) ,(CADDR E))))
|
||||
((EQ (CAAR E) 'MNCEXPT) (DIFFNCEXPT E X))
|
||||
((MEMQ (CAAR E) '(%LOG %PLOG))
|
||||
(SDIFFGRAD (IF (AND (NOT (ATOM (CADR E))) (EQ (CAAADR E) 'MABS))
|
||||
(CONS (CAR E) (CDADR E))
|
||||
E)
|
||||
X))
|
||||
((EQ (CAAR E) '%DERIVATIVE)
|
||||
(COND ((OR (ATOM (CADR E)) (MEMQ 'ARRAY (CDAADR E))) (CHAINRULE E X))
|
||||
((FREEL (CDDR E) X) (DIFF%DERIV (CONS (SDIFF (CADR E) X) (CDDR E))))
|
||||
(T (DIFF%DERIV (LIST E X 1)))))
|
||||
((MEMQ (CAAR E) '(%BINOMIAL $BETA))
|
||||
(LET ((EFACT ($MAKEFACT E)))
|
||||
(MUL2 (FACTOR (SDIFF EFACT X)) (DIV E EFACT))))
|
||||
((EQ (CAAR E) '%INTEGRATE) (DIFFINT E X))
|
||||
((EQ (CAAR E) '%LAPLACE) (DIFFLAPLACE E X))
|
||||
((EQ (CAAR E) '%AT) (DIFF-%AT E X))
|
||||
((MEMQ (CAAR E) '(%REALPART %IMAGPART))
|
||||
(LIST (NCONS (CAAR E)) (SDIFF (CADR E) X)))
|
||||
(T (SDIFFGRAD E X))))
|
||||
|
||||
(DEFUN SDIFFGRAD (E X)
|
||||
(LET ((FUN (CAAR E)) GRAD ARGS)
|
||||
(COND ((AND (EQ FUN 'MQAPPLY) (GET (CAAADR E) 'GRAD))
|
||||
(SDIFFGRAD (CONS (NCONS (CAAADR E)) (APPEND (CDADR E) (CDDR E)))
|
||||
X))
|
||||
((OR (EQ FUN 'MQAPPLY) (NULL (SETQ GRAD (GET FUN 'GRAD))))
|
||||
(IF (NOT (DEPENDS E X)) 0 (DIFF%DERIV (LIST E X 1))))
|
||||
((NOT (= (LENGTH (CDR E)) (LENGTH (CAR GRAD))))
|
||||
(MERROR "Wrong number of arguments for ~:M" FUN))
|
||||
(T (SETQ ARGS (SDIFFMAP (CDR E) X))
|
||||
(ADDN (MAPCAR
|
||||
#'MUL2
|
||||
(CDR (SUBSTITUTEL
|
||||
(CDR E) (CAR GRAD)
|
||||
(DO ((L1 (CDR GRAD) (CDR L1))
|
||||
(ARGS ARGS (CDR ARGS)) (L2))
|
||||
((NULL L1) (CONS '(MLIST) (NREVERSE L2)))
|
||||
(SETQ L2 (CONS (COND ((EQUAL (CAR ARGS) 0) 0)
|
||||
(T (CAR L1)))
|
||||
L2)))))
|
||||
ARGS)
|
||||
T)))))
|
||||
|
||||
(DEFUN SDIFFMAP (E X) (MAPCAR #'(LAMBDA (TERM) (SDIFF TERM X)) E))
|
||||
|
||||
(DEFUN SDIFFTIMES (L X)
|
||||
(PROG (TERM LEFT OUT)
|
||||
LOOP (SETQ TERM (CAR L) L (CDR L))
|
||||
(SETQ OUT (CONS (MULN (CONS (SDIFF TERM X) (APPEND LEFT L)) T) OUT))
|
||||
(IF (NULL L) (RETURN OUT))
|
||||
(SETQ LEFT (CONS TERM LEFT))
|
||||
(GO LOOP)))
|
||||
|
||||
(DEFUN DIFFEXPT (E X)
|
||||
(IF (MNUMP (CADDR E))
|
||||
(MUL3 (CADDR E) (POWER (CADR E) (ADDK (CADDR E) -1)) (SDIFF (CADR E) X))
|
||||
(MUL2 E (ADD2 (MUL3 (POWER (CADR E) -1) (CADDR E) (SDIFF (CADR E) X))
|
||||
(MUL2 (SIMPLIFYA (LIST '(%LOG) (CADR E)) T)
|
||||
(SDIFF (CADDR E) X))))))
|
||||
|
||||
(DEFUN DIFF%DERIV (E) (LET (DERIVFLAG) (SIMPLIFYA (CONS '(%DERIVATIVE) E) T)))
|
||||
|
||||
(PROG1 '(GRAD properties)
|
||||
(LET ((HEADER (PURCOPY '(X))))
|
||||
(MAPC #'(LAMBDA (Z) (PUTPROP (CAR Z) (CONS HEADER (CDR Z)) 'GRAD))
|
||||
; All these GRAD templates have been simplified and then the SIMP flags
|
||||
; (which are unnecessary) have been removed to save core space.
|
||||
'((%LOG ((MEXPT) X -1)) (%PLOG ((MEXPT) X -1))
|
||||
(%GAMMA ((MTIMES) ((MQAPPLY) (($PSI ARRAY) 0) X) ((%GAMMA) X)))
|
||||
(MFACTORIAL ((MTIMES) ((MQAPPLY) (($PSI ARRAY) 0) ((MPLUS) 1 X))
|
||||
((MFACTORIAL) X)))
|
||||
(%SIN ((%COS) X))
|
||||
(%COS ((MTIMES) -1 ((%SIN) X)))
|
||||
(%TAN ((MEXPT) ((%SEC) X) 2))
|
||||
(%COT ((MTIMES) -1 ((MEXPT) ((%CSC) X) 2)))
|
||||
(%SEC ((MTIMES) ((%SEC) X) ((%TAN) X)))
|
||||
(%CSC ((MTIMES) -1 ((%COT) X) ((%CSC) X)))
|
||||
(%ASIN ((MEXPT) ((MPLUS) 1 ((MTIMES) -1 ((MEXPT) X 2))) ((RAT) -1 2)))
|
||||
(%ACOS ((MTIMES) -1 ((MEXPT) ((MPLUS) 1 ((MTIMES) -1 ((MEXPT) X 2)))
|
||||
((RAT) -1 2))))
|
||||
(%ATAN ((MEXPT) ((MPLUS) 1 ((MEXPT) X 2)) -1))
|
||||
(%ACOT ((MTIMES) -1 ((MEXPT) ((MPLUS) 1 ((MEXPT) X 2)) -1)))
|
||||
(%ACSC ((MTIMES) -1 ((MEXPT) X -1)
|
||||
((MEXPT) ((MPLUS) -1 ((MEXPT) X 2)) ((RAT) -1 2))))
|
||||
(%ASEC ((MTIMES) ((MEXPT) X -1) ((MEXPT) ((MPLUS) -1 ((MEXPT) X 2)) ((RAT) -1 2))))
|
||||
(%SINH ((%COSH) X))
|
||||
(%COSH ((%SINH) X))
|
||||
(%TANH ((MEXPT) ((%SECH) X) 2))
|
||||
(%COTH ((MTIMES) -1 ((MEXPT) ((%CSCH) X) 2)))
|
||||
(%SECH ((MTIMES) -1 ((%SECH) X) ((%TANH) X)))
|
||||
(%CSCH ((MTIMES) -1 ((%COTH) X) ((%CSCH) X)))
|
||||
(%ASINH ((MEXPT) ((MPLUS) 1 ((MEXPT) X 2)) ((RAT) -1 2)))
|
||||
(%ACOSH ((MEXPT) ((MPLUS) -1 ((MEXPT) X 2)) ((RAT) -1 2)))
|
||||
(%ATANH ((MEXPT) ((MPLUS) 1 ((MTIMES) -1 ((MEXPT) X 2))) -1))
|
||||
(%ACOTH ((MTIMES) -1 ((MEXPT) ((MPLUS) -1 ((MEXPT) X 2)) -1)))
|
||||
(%ASECH ((MTIMES) -1 ((MEXPT) X -1)
|
||||
((MEXPT) ((MPLUS) 1 ((MTIMES) -1 ((MEXPT) X 2))) ((RAT) -1 2))))
|
||||
(%ACSCH ((MTIMES) -1 ((MEXPT) X -1)
|
||||
((MEXPT) ((MPLUS) 1 ((MEXPT) X 2)) ((RAT) -1 2))))
|
||||
(MABS ((MTIMES) X ((MEXPT) ((MABS) X) -1)))
|
||||
(%ERF ((MTIMES) 2 ((MEXPT) $%PI ((RAT) -1 2))
|
||||
((MEXPT) $%E ((MTIMES) -1 ((MEXPT) X 2)))))
|
||||
; ($LI2 ((MTIMES) -1 ((%LOG) ((MPLUS) 1 ((MTIMES) -1 X))) ((MEXPT) X -1)))
|
||||
($EI ((MTIMES) ((MEXPT) X -1) ((MEXPT) $%E X))))))
|
||||
|
||||
(DEFPROP $ATAN2 ((X Y) ((MTIMES) Y ((MEXPT) ((MPLUS) ((MEXPT) X 2) ((MEXPT) Y 2)) -1))
|
||||
((MTIMES) -1 X ((MEXPT) ((MPLUS) ((MEXPT) X 2) ((MEXPT) Y 2)) -1)))
|
||||
GRAD)
|
||||
|
||||
(DEFPROP $%J ((N X) ((%DERIVATIVE) ((MQAPPLY) (($%J ARRAY) N) X) N 1)
|
||||
((MPLUS) ((MQAPPLY) (($%J ARRAY) ((MPLUS) -1 N)) X)
|
||||
((MTIMES) -1 N ((MQAPPLY) (($%J ARRAY) N) X) ((MEXPT) X -1))))
|
||||
GRAD)
|
||||
|
||||
(DEFPROP $LI ((N X) ((%DERIVATIVE) ((MQAPPLY) (($LI ARRAY) N) X) N 1)
|
||||
((MTIMES) ((MQAPPLY) (($LI ARRAY) ((MPLUS) -1 N)) X) ((MEXPT) X -1)))
|
||||
GRAD)
|
||||
|
||||
(DEFPROP $PSI ((N X) ((%DERIVATIVE) ((MQAPPLY) (($PSI ARRAY) N) X) N 1)
|
||||
((MQAPPLY) (($PSI ARRAY) ((MPLUS) 1 N)) X))
|
||||
GRAD))
|
||||
|
||||
(DEFMFUN ATVARSCHK (ARGL)
|
||||
(DO ((LARGL (LENGTH ARGL) (1- LARGL)) (LATVRS (LENGTH ATVARS)) (L))
|
||||
((NOT (< LATVRS LARGL)) (NCONC ATVARS L))
|
||||
(SETQ L (CONS (IMPLODE (CONS '& (CONS '@ (MEXPLODEN LARGL)))) L))))
|
||||
|
||||
(DEFMFUN NOTLOREQ (X)
|
||||
(OR (ATOM X)
|
||||
(NOT (MEMQ (CAAR X) '(MLIST MEQUAL)))
|
||||
(AND (EQ (CAAR X) 'MLIST)
|
||||
(DOLIST (U (CDR X)) (IF (NOT (MEQUALP U)) (RETURN T))))))
|
||||
|
||||
(DEFMFUN SUBSTITUTEL (L1 L2 E)
|
||||
(DO ((L1 L1 (CDR L1)) (L2 L2 (CDR L2))) ((NULL L1) E)
|
||||
(SETQ E (SUBSTITUTE (CAR L1) (CAR L2) E))))
|
||||
|
||||
(DEFMFUN UNION* (A B)
|
||||
(DO ((A A (CDR A)) (X B)) ((NULL A) X)
|
||||
(IF (NOT (MEMALIKE (CAR A) B)) (SETQ X (CONS (CAR A) X)))))
|
||||
|
||||
(DEFMFUN INTERSECT* (A B)
|
||||
(DO ((A A (CDR A)) (X)) ((NULL A) X)
|
||||
(IF (MEMALIKE (CAR A) B) (SETQ X (CONS (CAR A) X)))))
|
||||
|
||||
(DEFMFUN NTHELEM (N E) (CAR (NTHCDR (1- N) E)))
|
||||
|
||||
(DEFMFUN DELSIMP (E) (DELQ 'SIMP (APPEND E NIL) 1))
|
||||
|
||||
(DEFMFUN REMSIMP (E)
|
||||
(IF (ATOM E) E (CONS (DELSIMP (CAR E)) (MAPCAR #'REMSIMP (CDR E)))))
|
||||
|
||||
(DEFMFUN $TRUNC (E)
|
||||
(COND ((ATOM E) E)
|
||||
((EQ (CAAR E) 'MPLUS) (CONS (APPEND (CAR E) '(TRUNC)) (CDR E)))
|
||||
((MBAGP E) (CONS (CAR E) (MAPCAR #'$TRUNC (CDR E))))
|
||||
((SPECREPP E) ($TRUNC (SPECDISREP E)))
|
||||
(T E)))
|
||||
|
||||
(DEFMFUN NONVARCHECK (E FN)
|
||||
(IF (OR (MNUMP E)
|
||||
(AND (NOT (ATOM E)) (NOT (EQ (CAAR E) 'MQAPPLY)) (MOPP1 (CAAR E))))
|
||||
(MERROR "Non-variable 2nd argument to ~:M:~%~M" FN E)))
|
||||
|
||||
(DEFMSPEC $LDISPLAY (FORM) (DISP1 (CDR FORM) T T))
|
||||
|
||||
(DEFMFUN $LDISP N (DISP1 (LISTIFY N) T NIL))
|
||||
|
||||
(DEFMSPEC $DISPLAY (FORM) (DISP1 (CDR FORM) NIL T))
|
||||
|
||||
(DEFMFUN $DISP N (DISP1 (LISTIFY N) NIL NIL))
|
||||
|
||||
(DEFUN DISP1 (LL LABLIST EQNSP)
|
||||
(IF LABLIST (SETQ LABLIST (NCONS '(MLIST SIMP))))
|
||||
(DO ((LL LL (CDR LL)) (L) (ANS) ($DISPFLAG T) (TIM 0))
|
||||
((NULL LL) (OR LABLIST '$DONE))
|
||||
(SETQ L (CAR LL) ANS (IF EQNSP (MEVAL L) L))
|
||||
(IF (AND EQNSP (NOT (MEQUALP ANS)))
|
||||
(SETQ ANS (LIST '(MEQUAL SIMP) (DISP2 L) ANS)))
|
||||
(IF LABLIST (NCONC LABLIST (NCONS (ELABEL ANS))))
|
||||
(SETQ TIM (RUNTIME))
|
||||
(DISPLA (LIST '(MLABLE) (IF LABLIST LINELABLE) ANS))
|
||||
(MTERPRI)
|
||||
(TIMEORG TIM)))
|
||||
|
||||
(DEFUN DISP2 (E)
|
||||
(COND ((ATOM E) E)
|
||||
((EQ (CAAR E) 'MQAPPLY)
|
||||
(CONS '(MQAPPLY) (CONS (CONS (CAADR E) (MAPCAR #'MEVAL (CDADR E)))
|
||||
(MAPCAR #'MEVAL (CDDR E)))))
|
||||
((EQ (CAAR E) 'MSETQ) (DISP2 (CADR E)))
|
||||
((EQ (CAAR E) 'MSET) (DISP2 (MEVAL (CADR E))))
|
||||
((EQ (CAAR E) 'MLIST) (CONS (CAR E) (MAPCAR #'DISP2 (CDR E))))
|
||||
((MSPECFUNP (CAAR E)) E)
|
||||
(T (CONS (CAR E) (MAPCAR #'MEVAL (CDR E))))))
|
||||
|
||||
(DEFMFUN ELABEL (E)
|
||||
(IF (NOT (CHECKLABEL $LINECHAR)) (SETQ $LINENUM (1+ $LINENUM)))
|
||||
(MAKELABEL $LINECHAR)
|
||||
(IF (NOT $NOLABELS) (SET LINELABLE E))
|
||||
LINELABLE)
|
||||
|
||||
(DEFMFUN $DISPTERMS (E)
|
||||
(COND ((OR (ATOM E) (EQ (CAAR E) 'BIGFLOAT)) (DISPLA E))
|
||||
((SPECREPP E) ($DISPTERMS (SPECDISREP E)))
|
||||
(T (LET (($DISPFLAG T))
|
||||
(MTERPRI)
|
||||
(DISPLA (GETOP (MOP E)))
|
||||
(DO E (IF (AND (EQ (CAAR E) 'MPLUS) (NOT $POWERDISP))
|
||||
(REVERSE (CDR E))
|
||||
(MARGS E))
|
||||
(CDR E) (NULL E) (MTERPRI) (DISPLA (CAR E)) (MTERPRI)))
|
||||
(MTERPRI)))
|
||||
'$DONE)
|
||||
|
||||
(DEFMFUN $DISPFORM N
|
||||
(IF (NOT (OR (= N 1) (AND (= N 2) (EQ (ARG 2) '$ALL))))
|
||||
(MERROR "Incorrect arguments to DISPFORM"))
|
||||
(LET ((E (ARG 1)))
|
||||
(IF (OR (ATOM E)
|
||||
(ATOM (SETQ E (IF (= N 1) (NFORMAT E) (NFORMAT-ALL E))))
|
||||
(MEMQ 'SIMP (CDAR E)))
|
||||
E
|
||||
(CONS (CONS (CAAR E) (CONS 'SIMP (CDAR E)))
|
||||
(IF (AND (EQ (CAAR E) 'MPLUS) (NOT $POWERDISP))
|
||||
(REVERSE (CDR E))
|
||||
(CDR E))))))
|
||||
|
||||
(DEFMFUN $PART N (MPART (LISTIFY N) NIL NIL $INFLAG '$PART))
|
||||
|
||||
(DEFMFUN $INPART N (MPART (LISTIFY N) NIL NIL T '$INPART))
|
||||
|
||||
(DEFMSPEC $SUBSTPART (L) (LET ((SUBSTP T)) (MPART (CDR L) T NIL $INFLAG '$SUBSTPART)))
|
||||
|
||||
(DEFMSPEC $SUBSTINPART (L) (LET ((SUBSTP T)) (MPART (CDR L) T NIL T '$SUBSTINPART)))
|
||||
|
||||
(DEFMFUN PART1 (ARGLIST SUBSTFLAG DISPFLAG INFLAG) ; called only by TRANSLATE
|
||||
(LET ((SUBSTP T)) (MPART ARGLIST SUBSTFLAG DISPFLAG INFLAG '$SUBSTPART)))
|
||||
|
||||
(DEFMFUN MPART (ARGLIST SUBSTFLAG DISPFLAG INFLAG FN)
|
||||
(PROG (SUBSTITEM ARG ARG1 EXP EXP1 EXP* SEVLIST COUNT PREVCOUNT N SPECP
|
||||
LASTELEM LASTCOUNT)
|
||||
(DECLARE (FIXNUM PREVCOUNT LASTELEM LASTCOUNT))
|
||||
(SETQ SPECP (OR SUBSTFLAG DISPFLAG))
|
||||
(IF SUBSTFLAG (SETQ SUBSTITEM (CAR ARGLIST) ARGLIST (CDR ARGLIST)))
|
||||
(IF (NULL ARGLIST) (WNA-ERR '$PART))
|
||||
(SETQ EXP (IF SUBSTFLAG (MEVAL (CAR ARGLIST)) (CAR ARGLIST)))
|
||||
(WHEN (NULL (SETQ ARGLIST (CDR ARGLIST)))
|
||||
(SETQ $PIECE EXP)
|
||||
(RETURN (COND (SUBSTFLAG (MEVAL SUBSTITEM))
|
||||
(DISPFLAG (BOX EXP DISPFLAG))
|
||||
(T EXP))))
|
||||
(COND ((NOT INFLAG)
|
||||
(COND ((OR (AND ($LISTP EXP) (NULL (CDR ARGLIST)))
|
||||
(AND ($MATRIXP EXP)
|
||||
(OR (NULL (CDR ARGLIST)) (NULL (CDDR ARGLIST)))))
|
||||
(SETQ INFLAG T))
|
||||
((NOT SPECP) (SETQ EXP (NFORMAT EXP)))
|
||||
(T (SETQ EXP (NFORMAT-ALL EXP)))))
|
||||
((SPECREPP EXP) (SETQ EXP (SPECDISREP EXP))))
|
||||
(IF (AND (ATOM EXP) (NULL $PARTSWITCH))
|
||||
(MERROR "~:M called on atom: ~:M" FN EXP))
|
||||
(IF (AND INFLAG SPECP) (SETQ EXP (SUBST NIL NIL EXP)))
|
||||
(SETQ EXP* EXP)
|
||||
START(COND ((OR (ATOM EXP) (EQ (CAAR EXP) 'BIGFLOAT)) (GO ERR))
|
||||
((EQUAL (SETQ ARG (COND (SUBSTFLAG (MEVAL (CAR ARGLIST)))
|
||||
(T (CAR ARGLIST))))
|
||||
0)
|
||||
(SETQ ARGLIST (CDR ARGLIST))
|
||||
(COND ((MNUMP SUBSTITEM)
|
||||
(MERROR "~M is an invalid operator in ~:M"
|
||||
SUBSTITEM FN))
|
||||
((AND SPECP ARGLIST)
|
||||
(IF (EQ (CAAR EXP) 'MQAPPLY)
|
||||
(PROG2 (SETQ EXP (CADR EXP)) (GO START))
|
||||
(MERROR "Invalid operator in ~:M" FN)))
|
||||
(T (SETQ $PIECE (GETOP (MOP EXP)))
|
||||
(RETURN
|
||||
(COND (SUBSTFLAG
|
||||
(SETQ SUBSTITEM (GETOPR (MEVAL SUBSTITEM)))
|
||||
(COND ((MNUMP SUBSTITEM)
|
||||
(MERROR "Invalid operator in ~:M:~%~M"
|
||||
FN SUBSTITEM))
|
||||
((NOT (ATOM SUBSTITEM))
|
||||
(IF (NOT (EQ (CAAR EXP) 'MQAPPLY))
|
||||
(RPLACA (RPLACD EXP (CONS (CAR EXP)
|
||||
(CDR EXP)))
|
||||
'(MQAPPLY)))
|
||||
(RPLACA (CDR EXP) SUBSTITEM)
|
||||
(RETURN (RESIMPLIFY EXP*)))
|
||||
((EQ (CAAR EXP) 'MQAPPLY)
|
||||
(RPLACD EXP (CDDR EXP))))
|
||||
(RPLACA EXP (CONS SUBSTITEM
|
||||
(IF (AND (MEMQ 'ARRAY (CDAR EXP))
|
||||
(NOT (MOPP SUBSTITEM)))
|
||||
'(ARRAY))))
|
||||
(RESIMPLIFY EXP*))
|
||||
(DISPFLAG
|
||||
(RPLACD EXP (CDR (BOX (SUBST NIL NIL EXP) DISPFLAG)))
|
||||
(RPLACA EXP (IF (EQ DISPFLAG T)
|
||||
'(MBOX)
|
||||
'(MLABOX)))
|
||||
(RESIMPLIFY EXP*))
|
||||
(T (WHEN ARGLIST (SETQ EXP $PIECE) (GO A))
|
||||
$PIECE))))))
|
||||
((NOT (ATOM ARG)) (GO SEVERAL))
|
||||
((NOT (FIXNUMP ARG))
|
||||
(MERROR "Non-integer argument to ~:M:~%~M" FN ARG))
|
||||
((< ARG 0) (GO BAD)))
|
||||
(IF (EQ (CAAR EXP) 'MQAPPLY) (SETQ EXP (CDR EXP)))
|
||||
LOOP (COND ((NOT (ZEROP ARG)) (SETQ ARG (1- ARG) EXP (CDR EXP))
|
||||
(IF (NULL EXP) (GO ERR)) (GO LOOP))
|
||||
((NULL (SETQ ARGLIST (CDR ARGLIST)))
|
||||
(RETURN (COND (SUBSTFLAG (SETQ $PIECE (RESIMPLIFY (CAR EXP)))
|
||||
(RPLACA EXP (MEVAL SUBSTITEM))
|
||||
(RESIMPLIFY EXP*))
|
||||
(DISPFLAG (SETQ $PIECE (RESIMPLIFY (CAR EXP)))
|
||||
(RPLACA EXP (BOX (CAR EXP) DISPFLAG))
|
||||
(RESIMPLIFY EXP*))
|
||||
(INFLAG (SETQ $PIECE (CAR EXP)))
|
||||
(T (SETQ $PIECE (SIMPLIFY (CAR EXP))))))))
|
||||
(SETQ EXP (CAR EXP))
|
||||
A (COND ((AND (NOT INFLAG) (NOT SPECP)) (SETQ EXP (NFORMAT EXP)))
|
||||
((SPECREPP EXP) (SETQ EXP (SPECDISREP EXP))))
|
||||
(GO START)
|
||||
ERR (COND ((EQ $PARTSWITCH 'MAPPLY)
|
||||
(MERROR "Improper index to list or matrix"))
|
||||
($PARTSWITCH (RETURN (SETQ $PIECE '$END)))
|
||||
(T (MERROR "~:M fell off end." FN)))
|
||||
BAD (IMPROPER-ARG-ERR ARG FN)
|
||||
SEVERAL
|
||||
(IF (OR (NOT (MEMQ (CAAR ARG) '(MLIST $ALLBUT))) (CDR ARGLIST))
|
||||
(GO BAD))
|
||||
(SETQ EXP1 (CONS (CAAR EXP) (IF (MEMQ 'ARRAY (CDAR EXP)) '(ARRAY))))
|
||||
(IF (EQ (CAAR EXP) 'MQAPPLY)
|
||||
(SETQ SEVLIST (LIST (CADR EXP) EXP1) EXP (CDDR EXP))
|
||||
(SETQ SEVLIST (NCONS EXP1) EXP (CDR EXP)))
|
||||
(SETQ ARG1 (CDR ARG) PREVCOUNT 0 EXP1 EXP)
|
||||
(DOLIST (ARG* ARG1)
|
||||
(IF (NOT (FIXNUMP ARG*))
|
||||
(MERROR "Non-integer argument to ~:M:~%~M" FN ARG*)))
|
||||
(WHEN (AND SPECP (EQ (CAAR ARG) 'MLIST))
|
||||
(IF SUBSTFLAG (SETQ LASTELEM (CAR (LAST ARG1))))
|
||||
(SETQ ARG1 (SORT (APPEND ARG1 NIL) #'<)))
|
||||
(WHEN (EQ (CAAR ARG) '$ALLBUT)
|
||||
(SETQ N (LENGTH EXP))
|
||||
(DOLIST (I ARG1)
|
||||
(IF (OR (< I 1) (> I N))
|
||||
(MERROR "Invalid argument to ~:M:~%~M" FN I)))
|
||||
(DO ((I N (1- I)) (ARG2))
|
||||
((= I 0) (SETQ ARG1 ARG2))
|
||||
(IF (NOT (MEMBER I ARG1)) (SETQ ARG2 (CONS I ARG2))))
|
||||
(IF SUBSTFLAG (SETQ LASTELEM (CAR (LAST ARG1)))))
|
||||
(IF (NULL ARG1) (IF SPECP (GO BAD) (GO END)))
|
||||
(IF SUBSTFLAG (SETQ LASTCOUNT LASTELEM))
|
||||
SEVLOOP
|
||||
(IF SPECP
|
||||
(SETQ COUNT (- (CAR ARG1) PREVCOUNT) PREVCOUNT (CAR ARG1))
|
||||
(SETQ COUNT (CAR ARG1)))
|
||||
(IF (< COUNT 1) (GO BAD))
|
||||
(IF (AND SUBSTFLAG (< (CAR ARG1) LASTELEM))
|
||||
(SETQ LASTCOUNT (1- LASTCOUNT)))
|
||||
COUNT(COND ((NULL EXP) (GO ERR))
|
||||
((NOT (= COUNT 1)) (SETQ COUNT (1- COUNT) EXP (CDR EXP)) (GO COUNT)))
|
||||
(SETQ SEVLIST (CONS (CAR EXP) SEVLIST))
|
||||
(SETQ ARG1 (CDR ARG1))
|
||||
END (COND ((NULL ARG1)
|
||||
(SETQ SEVLIST (NREVERSE SEVLIST))
|
||||
(SETQ $PIECE (IF (OR INFLAG (NOT SPECP))
|
||||
(SIMPLIFY SEVLIST)
|
||||
(RESIMPLIFY SEVLIST)))
|
||||
(RETURN (COND (SUBSTFLAG (RPLACA (NTHCDR (1- LASTCOUNT) EXP1)
|
||||
(MEVAL SUBSTITEM))
|
||||
(RESIMPLIFY EXP*))
|
||||
(DISPFLAG (RPLACA EXP (BOX (CAR EXP) DISPFLAG))
|
||||
(RESIMPLIFY EXP*))
|
||||
(T $PIECE))))
|
||||
(SUBSTFLAG (IF (NULL (CDR EXP)) (GO ERR))
|
||||
(RPLACA EXP (CADR EXP)) (RPLACD EXP (CDDR EXP)))
|
||||
(DISPFLAG (RPLACA EXP (BOX (CAR EXP) DISPFLAG))
|
||||
(SETQ EXP (CDR EXP)))
|
||||
(T (SETQ EXP EXP1)))
|
||||
(GO SEVLOOP)))
|
||||
|
||||
(DEFMFUN GETOP (X) (OR (AND (SYMBOLP X) (GET X 'OP)) X))
|
||||
|
||||
(DEFMFUN GETOPR (X) (OR (AND (SYMBOLP X) (GET X 'OPR)) X))
|
||||
|
||||
#-Franz
|
||||
(DEFMFUN $LISTP (X)
|
||||
(AND (NOT (ATOM X))
|
||||
(NOT (ATOM (CAR X)))
|
||||
(EQ (CAAR X) 'MLIST)))
|
||||
|
||||
#+Franz ;; -Franz uses a macro definition in MAXMAC.
|
||||
(defmfun mlistp (x)
|
||||
(and (not (atom x))
|
||||
(or (eq (caar x) 'mlist) ($featurep (caar x) '$list))))
|
||||
|
||||
#+Franz
|
||||
(putd '$listp (getd 'mlistp))
|
||||
|
||||
(DEFMFUN $CONS (X E)
|
||||
(ATOMCHK (SETQ E (SPECREPCHECK E)) '$CONS T)
|
||||
(MCONS-EXP-ARGS E (CONS X (MARGS E))))
|
||||
|
||||
(DEFMFUN $ENDCONS (X E)
|
||||
(ATOMCHK (SETQ E (SPECREPCHECK E)) '$ENDCONS T)
|
||||
(MCONS-EXP-ARGS E (APPEND (MARGS E) (NCONS X))))
|
||||
|
||||
(DEFMFUN $REVERSE (E)
|
||||
(ATOMCHK (SETQ E (FORMAT1 E)) '$REVERSE NIL)
|
||||
(MCONS-EXP-ARGS E (REVERSE (MARGS E))))
|
||||
|
||||
(DEFMFUN $APPEND N
|
||||
(IF (= N 0)
|
||||
'((MLIST SIMP))
|
||||
(LET ((ARG1 (SPECREPCHECK (ARG 1))) OP ARRP)
|
||||
(ATOMCHK ARG1 '$APPEND NIL)
|
||||
(SETQ OP (MOP ARG1) ARRP (IF (MEMQ 'ARRAY (CDAR ARG1)) T))
|
||||
(MCONS-EXP-ARGS
|
||||
ARG1
|
||||
(APPLY #'APPEND
|
||||
(MAPCAR #'(LAMBDA (U)
|
||||
(ATOMCHK (SETQ U (SPECREPCHECK U)) '$APPEND NIL)
|
||||
(IF (OR (NOT (ALIKE1 OP (MOP U)))
|
||||
(NOT (EQ ARRP (IF (MEMQ 'ARRAY (CDAR U)) T))))
|
||||
(MERROR "Arguments to APPEND are not compatible."))
|
||||
(MARGS U))
|
||||
(LISTIFY N)))))))
|
||||
|
||||
(DEFUN MCONS-EXP-ARGS (E ARGS)
|
||||
(IF (EQ (CAAR E) 'MQAPPLY)
|
||||
(LIST* (DELSIMP (CAR E)) (CADR E) ARGS)
|
||||
(CONS (IF (MLISTP E) (CAR E) (DELSIMP (CAR E))) ARGS)))
|
||||
|
||||
(DEFMFUN $MEMBER (X E)
|
||||
(ATOMCHK (SETQ E ($TOTALDISREP E)) '$MEMBER T)
|
||||
(IF (MEMALIKE ($TOTALDISREP X) (MARGS E)) T))
|
||||
|
||||
(DEFMFUN ATOMCHK (E FUN 2NDP)
|
||||
(IF (OR (ATOM E) (EQ (CAAR E) 'BIGFLOAT))
|
||||
(MERROR "~Margument to ~:M was atomic: ~M"
|
||||
(IF 2NDP '|2nd | '||) FUN E)))
|
||||
|
||||
(DEFMFUN FORMAT1 (E)
|
||||
(COND (($LISTP E) E) ($INFLAG (SPECREPCHECK E)) (T (NFORMAT E))))
|
||||
|
||||
(DEFMFUN $FIRST (E)
|
||||
(ATOMCHK (SETQ E (FORMAT1 E)) '$FIRST NIL)
|
||||
(IF (NULL (CDR E)) (MERROR "Argument to FIRST is empty."))
|
||||
(CAR (MARGS E)))
|
||||
|
||||
(DEFMFUN $REST N
|
||||
(PROG (M FUN FUN1 REVP)
|
||||
(IF (AND (= N 2) (EQUAL (ARG 2) 0)) (RETURN (ARG 1)))
|
||||
(ATOMCHK (SETQ M (FORMAT1 (ARG 1))) '$REST NIL)
|
||||
(COND ((= N 1))
|
||||
((NOT (= N 2)) (WNA-ERR '$REST))
|
||||
((NOT (FIXNUMP (ARG 2)))
|
||||
(MERROR "2nd argument to REST must be an integer:~%~M"
|
||||
(ARG 2)))
|
||||
((MINUSP (SETQ N (ARG 2))) (SETQ N (- N) REVP T)))
|
||||
(IF (< (LENGTH (MARGS M)) N)
|
||||
(IF $PARTSWITCH (RETURN '$END) (MERROR "REST fell off end.")))
|
||||
(SETQ FUN (CAR M))
|
||||
(IF (EQ (CAR FUN) 'MQAPPLY) (SETQ FUN1 (CADR M) M (CDR M)))
|
||||
(SETQ M (CDR M))
|
||||
(IF REVP (SETQ M (REVERSE M)))
|
||||
(DO N N (1- N) (ZEROP N) (SETQ M (CDR M)))
|
||||
(SETQ M (CONS (IF (EQ (CAR FUN) 'MLIST) FUN (DELSIMP FUN))
|
||||
(IF REVP (NREVERSE M) M)))
|
||||
(IF (EQ (CAR FUN) 'MQAPPLY)
|
||||
(RETURN (CONS (CAR M) (CONS FUN1 (CDR M)))))
|
||||
(RETURN M)))
|
||||
|
||||
(DEFMFUN $LAST (E)
|
||||
(ATOMCHK (SETQ E (FORMAT1 E)) '$LAST NIL)
|
||||
(IF (NULL (CDR E)) (MERROR "Argument to LAST is empty."))
|
||||
(CAR (LAST E)))
|
||||
|
||||
(DEFMFUN $ARGS (E) (ATOMCHK (SETQ E (FORMAT1 E)) '$ARGS NIL)
|
||||
(CONS '(MLIST) (MARGS E)))
|
||||
|
||||
(DEFMFUN $DELETE N
|
||||
(COND ((= N 2) (SETQ N -1))
|
||||
((NOT (= N 3)) (WNA-ERR '$DELETE))
|
||||
((OR (NOT (FIXNUMP (ARG 3))) (MINUSP (SETQ N (ARG 3))))
|
||||
(MERROR "Improper 3rd argument to DELETE:~%~M" (ARG 3))))
|
||||
(LET ((X (ARG 1)) (L (ARG 2)))
|
||||
(ATOMCHK (SETQ L (SPECREPCHECK L)) '$DELETE T)
|
||||
(SETQ X (SPECREPCHECK X) L (CONS (DELSIMP (CAR L)) (APPEND (CDR L) NIL)))
|
||||
(PROG (L1)
|
||||
(SETQ L1 (IF (EQ (CAAR L) 'MQAPPLY) (CDR L) L))
|
||||
LOOP (COND ((OR (NULL (CDR L1)) (ZEROP N)) (RETURN L))
|
||||
((ALIKE1 X (SPECREPCHECK (CADR L1)))
|
||||
(SETQ N (1- N)) (RPLACD L1 (CDDR L1)))
|
||||
(T (SETQ L1 (CDR L1))))
|
||||
(GO LOOP))))
|
||||
|
||||
(DEFMFUN $LENGTH (E)
|
||||
(SETQ E (COND (($LISTP E) E)
|
||||
((OR $INFLAG (NOT ($RATP E))) (SPECREPCHECK E))
|
||||
(T ($RATDISREP E))))
|
||||
(COND ((SYMBOLP E) 0)
|
||||
((OR (NUMBERP E) (EQ (CAAR E) 'BIGFLOAT))
|
||||
(IF (AND (NOT $INFLAG) (MNEGP E)) 1 0))
|
||||
((OR $INFLAG (NOT (MEMQ (CAAR E) '(MTIMES MEXPT)))) (LENGTH (MARGS E)))
|
||||
((EQ (CAAR E) 'MEXPT)
|
||||
(IF (AND (ALIKE1 (CADDR E) '((RAT SIMP) 1 2)) $SQRTDISPFLAG) 1 2))
|
||||
(T (LENGTH (CDR (NFORMAT E))))))
|
||||
|
||||
(DEFMFUN $ATOM (X)
|
||||
(SETQ X (SPECREPCHECK X)) (OR (ATOM X) (EQ (CAAR X) 'BIGFLOAT)))
|
||||
|
||||
(DEFMFUN $SYMBOLP (X) (SETQ X (SPECREPCHECK X)) (SYMBOLP X))
|
||||
|
||||
(DEFMFUN $NUM (E)
|
||||
(LET (X)
|
||||
(COND ((ATOM E) E)
|
||||
((EQ (CAAR E) 'MRAT) ($RATNUMER E))
|
||||
((EQ (CAAR E) 'RAT) (CADR E))
|
||||
((EQ (CAAR (SETQ X (NFORMAT E))) 'MQUOTIENT) (SIMPLIFY (CADR X)))
|
||||
((AND (EQ (CAAR X) 'MMINUS) (NOT (ATOM (SETQ X (CADR X))))
|
||||
(EQ (CAAR X) 'MQUOTIENT))
|
||||
(SIMPLIFY (LIST '(MTIMES) -1 (CADR X))))
|
||||
(T E))))
|
||||
|
||||
(DEFMFUN $DENOM (E)
|
||||
(COND ((ATOM E) 1)
|
||||
((EQ (CAAR E) 'MRAT) ($RATDENOM E))
|
||||
((EQ (CAAR E) 'RAT) (CADDR E))
|
||||
((OR (EQ (CAAR (SETQ E (NFORMAT E))) 'MQUOTIENT)
|
||||
(AND (EQ (CAAR E) 'MMINUS) (NOT (ATOM (SETQ E (CADR E))))
|
||||
(EQ (CAAR E) 'MQUOTIENT)))
|
||||
(SIMPLIFY (CADDR E)))
|
||||
(T 1)))
|
||||
|
||||
|
||||
(DEFMFUN $FIX (E) ($ENTIER E))
|
||||
|
||||
(DEFMFUN $ENTIER (E)
|
||||
(LET ((E1 (SPECREPCHECK E)))
|
||||
(COND ((NUMBERP E1) (FIX E1))
|
||||
((RATNUMP E1) (SETQ E (QUOTIENT (CADR E1) (CADDR E1)))
|
||||
(IF (MINUSP (CADR E1)) (SUB1 E) E))
|
||||
(($BFLOATP E1)
|
||||
(SETQ E (FPENTIER E1))
|
||||
(IF (AND (MINUSP (CADR E1)) (NOT (ZEROP1 (SUB E E1))))
|
||||
(SUB1 E)
|
||||
E))
|
||||
(T (LIST '($ENTIER) E)))))
|
||||
|
||||
(DEFMFUN $FLOAT (E)
|
||||
(COND ((NUMBERP E) (FLOAT E))
|
||||
((OR (ATOM E) (MEMQ 'ARRAY (CDAR E))) E)
|
||||
((EQ (CAAR E) 'RAT) (FPCOFRAT E))
|
||||
((EQ (CAAR E) 'BIGFLOAT) (FP2FLO E))
|
||||
((MEMQ (CAAR E) '(MEXPT MNCEXPT))
|
||||
(LIST (NCONS (CAAR E)) ($FLOAT (CADR E)) (CADDR E)))
|
||||
(T (RECUR-APPLY #'$FLOAT E))))
|
||||
|
||||
(DEFMFUN $COEFF N
|
||||
(COND ((= N 3) (IF (EQUAL (ARG 3) 0)
|
||||
(COEFF (ARG 1) (ARG 2) (ARG 3))
|
||||
(COEFF (ARG 1) (POWER (ARG 2) (ARG 3)) 1)))
|
||||
((= N 2) (COEFF (ARG 1) (ARG 2) 1))
|
||||
(T (WNA-ERR '$COEFF))))
|
||||
|
||||
(DEFMFUN COEFF (E VAR POW)
|
||||
(SIMPLIFY
|
||||
(COND ((ALIKE1 E VAR) (IF (EQUAL POW 1) 1 0))
|
||||
((ATOM E) (IF (EQUAL POW 0) E 0))
|
||||
((EQ (CAAR E) 'MEXPT)
|
||||
(COND ((ALIKE1 (CADR E) VAR)
|
||||
(IF (OR (EQUAL POW 0) (NOT (ALIKE1 (CADDR E) POW))) 0 1))
|
||||
((EQUAL POW 0) E)
|
||||
(T 0)))
|
||||
((OR (EQ (CAAR E) 'MPLUS) (MBAGP E))
|
||||
(CONS (IF (EQ (CAAR E) 'MPLUS) '(MPLUS) (CAR E))
|
||||
(MAPCAR #'(LAMBDA (E) (COEFF E VAR POW)) (CDR E))))
|
||||
((EQ (CAAR E) 'MRAT) (RATCOEFF E VAR POW))
|
||||
((EQUAL POW 0) (IF (FREE E VAR) E 0))
|
||||
((EQ (CAAR E) 'MTIMES)
|
||||
(LET ((TERM (IF (EQUAL POW 1) VAR (POWER VAR POW))))
|
||||
(IF (MEMALIKE TERM (CDR E)) ($DELETE TERM E 1) 0)))
|
||||
(T 0))))
|
||||
|
||||
(DECLARE (SPECIAL POWERS VAR HIFLG NUM FLAG))
|
||||
|
||||
(DEFMFUN $HIPOW (E VAR) (FINDPOWERS E T))
|
||||
; These work best on expanded "simple" expressions.
|
||||
|
||||
(DEFMFUN $LOPOW (E VAR) (FINDPOWERS E NIL))
|
||||
|
||||
(DEFUN FINDPOWERS (E HIFLG)
|
||||
(LET (POWERS NUM FLAG)
|
||||
(FINDPOWERS1 E)
|
||||
(COND ((NULL POWERS) (IF (NULL NUM) 0 NUM))
|
||||
(T (IF NUM (SETQ POWERS (CONS NUM POWERS)))
|
||||
(MAXIMIN POWERS (IF HIFLG '$MAX '$MIN))))))
|
||||
|
||||
(DEFUN FINDPOWERS1 (E)
|
||||
(COND ((ALIKE1 E VAR) (CHECKPOW 1))
|
||||
((ATOM E))
|
||||
((EQ (CAAR E) 'MPLUS)
|
||||
(COND ((NOT (FREEL (CDR E) VAR))
|
||||
(DO E (CDR E) (CDR E) (NULL E)
|
||||
(SETQ FLAG NIL) (FINDPOWERS1 (CAR E))
|
||||
(IF (NULL FLAG) (CHECKPOW 0))))))
|
||||
((AND (EQ (CAAR E) 'MEXPT) (ALIKE1 (CADR E) VAR)) (CHECKPOW (CADDR E)))
|
||||
((SPECREPP E) (FINDPOWERS1 (SPECDISREP E)))
|
||||
(T (MAPC #'FINDPOWERS1 (CDR E)))))
|
||||
|
||||
(DEFUN CHECKPOW (POW)
|
||||
(SETQ FLAG T)
|
||||
(COND ((NOT (NUMBERP POW)) (SETQ POWERS (CONS POW POWERS)))
|
||||
((NULL NUM) (SETQ NUM POW))
|
||||
(HIFLG (IF (GREATERP POW NUM) (SETQ NUM POW)))
|
||||
((LESSP POW NUM) (SETQ NUM POW))))
|
||||
|
||||
(DECLARE (UNSPECIAL POWERS VAR HIFLG NUM FLAG))
|
||||
|
||||
|
||||
; Undeclarations for the file:
|
||||
(DECLARE (NOTYPE I N LARGL LVRS COUNT TIM))
|
||||
|
||||
2754
src/jpg/suprv.642
Normal file
2754
src/jpg/suprv.642
Normal file
File diff suppressed because it is too large
Load Diff
1320
src/mrg/compar.864
Normal file
1320
src/mrg/compar.864
Normal file
File diff suppressed because it is too large
Load Diff
710
src/mrg/db.1149
Normal file
710
src/mrg/db.1149
Normal file
@@ -0,0 +1,710 @@
|
||||
;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;;
|
||||
;;; (c) Copyright 1982 Massachusetts Institute of Technology ;;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(macsyma-module db)
|
||||
|
||||
(LOAD-MACSYMA-MACROS MRGMAC)
|
||||
|
||||
;; This file uses its own special syntax which is set up here. The function
|
||||
;; which does it is defined in LIBMAX;MRGMAC. It sets up <, >, and : for
|
||||
;; structure manipulation. A major bug with this package is that the code is
|
||||
;; almost completely uncommented. Someone with nothing better to do should go
|
||||
;; through it, figure out how it works, and write it down.
|
||||
;; Note: After recompiling all of macsyma for the Lispm it was found
|
||||
;; that some files were compiled with the syntax of ":" set up
|
||||
;; incorrectly. The (MODE-SYNTAX-OFF) function, which calls
|
||||
;; undocumented system-internal routines evidently did not work anymore.
|
||||
;; Therefore I removed the need for MODE-SYNTAX-ON from this file.
|
||||
;; 7:57pm Thursday, 25 February 1982 -GJC
|
||||
|
||||
|
||||
;; On systems which cons fixnums, a fixnum is used as a single label cell
|
||||
;; and a pointer to the fixnum is passed around (i.e. the particular fixnum
|
||||
;; is passed around. On systems which have immediate fixnums, a single cons
|
||||
;; cell is created and the fixnum is stored in the car of the cell. Fixnums
|
||||
;; are consed only in PDP-10 MacLisp and Franz Lisp.
|
||||
|
||||
#+(OR PDP10 Franz)
|
||||
(EVAL-WHEN (EVAL COMPILE) (SSTATUS FEATURE FIXCONS))
|
||||
#+NIL
|
||||
(EVAL-WHEN (EVAL COMPILE) (SET-NOFEATURE 'FIXCONS))
|
||||
|
||||
(DECLARE (GENPREFIX DB)
|
||||
;; LAB is not a special. This declares all occurrences of LAB
|
||||
;; as a local or a parameter to be a fixnum. This should really
|
||||
;; be done using a LOCAL-DECLARE around the entire file so as to
|
||||
;; make sure any global compiler state gets undone.
|
||||
#+FIXCONS (FIXNUM LAB)
|
||||
(*LEXPR CONTEXT))
|
||||
|
||||
;; External specials
|
||||
;; Please do not use DEFMVAR on these because some of them contain
|
||||
;; circular list structure, and we want to be able to load in the
|
||||
;; English version of the file at times. (DEFMVAR tries to print
|
||||
;; out their values when the value in core is different from the
|
||||
;; value in the file.) - JPG
|
||||
;; Why don't you set PRINLEVEL and PRINLENGTH in your macsyma? -GJC
|
||||
|
||||
(DEFVAR CONTEXT 'GLOBAL)
|
||||
(DEFVAR CONTEXTS NIL)
|
||||
(DEFVAR CURRENT 'GLOBAL)
|
||||
(DEFVAR +LABS NIL)
|
||||
(DEFVAR -LABS NIL)
|
||||
(DEFVAR DBTRACE NIL)
|
||||
(DEFVAR DBCHECK NIL)
|
||||
(DEFVAR DOBJECTS NIL)
|
||||
(DEFVAR NOBJECTS NIL)
|
||||
|
||||
;; Internal specials
|
||||
|
||||
(DEFVAR MARKS 0) (DECLARE (FIXNUM MARKS))
|
||||
(DEFVAR +L) (DECLARE (FIXNUM +L))
|
||||
(DEFVAR -L) (DECLARE (FIXNUM -L))
|
||||
(DEFVAR ULABS NIL)
|
||||
|
||||
(DEFVAR CONINDEX 0) (DECLARE (FIXNUM CONINDEX))
|
||||
(DEFVAR CONNUMBER 50.) (DECLARE (FIXNUM CONNUMBER))
|
||||
|
||||
;; The most negative fixnum. On the PDP-10, this is 1_35.
|
||||
(DEFVAR LAB-HIGH-BIT (ROT 1 -1))
|
||||
;; One less than the number of bits in a fixnum. On the PDP-10, this is 35.
|
||||
(DEFVAR LABNUMBER (1- (HAULONG LAB-HIGH-BIT)))
|
||||
;; A cell with the high bit turned on.
|
||||
(DEFVAR LAB-HIGH-LAB #+FIXCONS LAB-HIGH-BIT #-FIXCONS (LIST LAB-HIGH-BIT))
|
||||
|
||||
(DECLARE (SPECIAL +S +SM +SL -S -SM -SL LABS LPRS LABINDEX LPRINDEX WORLD *))
|
||||
|
||||
;; Macro for indirecting through the contents of a cell.
|
||||
|
||||
(DEFMACRO UNLAB (CELL)
|
||||
#+FIXCONS CELL #-FIXCONS `(CAR ,CELL))
|
||||
|
||||
(DEFMACRO SETQ-UNLAB (CELL)
|
||||
#+FIXCONS NIL
|
||||
#-FIXCONS `(SETQ ,CELL (UNLAB ,CELL)))
|
||||
|
||||
(DEFMACRO SETQ-COPYN (CELL)
|
||||
#+FIXCONS NIL
|
||||
#-FIXCONS `(SETQ ,CELL (COPYN ,CELL)))
|
||||
|
||||
;; Conditionalize primitive functions used in this file. These are in
|
||||
;; LAP for Lisp implementations which cons fixnums. This interface
|
||||
;; is poorly designed since the meaning of COPYN is varies slightly
|
||||
;; between systems. In one case it means "take a cell and produce a
|
||||
;; new one with the same contents". In the other, it means "take an
|
||||
;; immediate fixnum and return a cell containing it." As a result of
|
||||
;; this, #+FIXCONS conditionalizations appear in the actual source code.
|
||||
|
||||
#-FIXCONS
|
||||
(PROGN 'COMPILE
|
||||
(DEFMACRO COPYN (N) `(LIST ,N))
|
||||
(DEFMACRO IORM (CELL N)
|
||||
`(RPLACA ,CELL (LOGIOR (CAR ,CELL) (CAR ,N))))
|
||||
(DEFMACRO XORM (CELL N)
|
||||
`(RPLACA ,CELL (LOGXOR (CAR ,CELL) (CAR ,N))))
|
||||
)
|
||||
|
||||
;; The LAP for the PDP-10 version.
|
||||
|
||||
#+PDP10 (LAP-A-LIST '(
|
||||
(LAP COPYN SUBR)
|
||||
(MOVE TT 0 A)
|
||||
(JSP T FWCONS)
|
||||
(POPJ P)
|
||||
NIL
|
||||
|
||||
(LAP IORM SUBR)
|
||||
(MOVE B 0 B)
|
||||
(IORM B 0 A)
|
||||
(POPJ P)
|
||||
NIL
|
||||
|
||||
(LAP XORM SUBR)
|
||||
(MOVE B 0 B)
|
||||
(XORM B 0 A)
|
||||
(POPJ P)
|
||||
NIL ))
|
||||
|
||||
#+Franz
|
||||
(progn 'compile
|
||||
(defmacro copyn (n) `(copyint* ,n))
|
||||
(defmacro iorm (cell n) `(replace ,cell (logior ,cell ,n)))
|
||||
(defmacro xorm (cell n) `(replace ,cell (logxor ,cell ,n))) )
|
||||
|
||||
(DEFPROP GLOBAL 1 CMARK)
|
||||
|
||||
(ARRAY CONUNMRK NIL (1+ CONNUMBER))
|
||||
(ARRAY CONMARK T (1+ CONNUMBER))
|
||||
|
||||
(DEFMFUN MARK (X) (PUTPROP X T 'MARK))
|
||||
(DEFMFUN MARKP (X) (AND (SYMBOLP X) (GET X 'MARK)))
|
||||
(DEFMFUN UNMRK (X) (REMPROP X 'MARK))
|
||||
(DEFUN MARKS (X) (COND ((NUMBERP X)) ((ATOM X) (MARK X)) (T (MAPC #'MARKS X))))
|
||||
(DEFUN UNMRKS (X)
|
||||
(COND ((NUMBERP X))
|
||||
((OR (ATOM X) (NUMBERP (CAR X))) (UNMRK X))
|
||||
(T (MAPC #'UNMRKS X))))
|
||||
|
||||
(DEFMODE TYPE ()
|
||||
(ATOM (SELECTOR +LABS) (SELECTOR -LABS) (SELECTOR DATA))
|
||||
SELECTOR)
|
||||
(DEFMODE INDV ()
|
||||
(ATOM (SELECTOR =LABS) (SELECTOR NLABS) (SELECTOR DATA) (SELECTOR IN))
|
||||
SELECTOR)
|
||||
(DEFMODE UNIV ()
|
||||
(ATOM (SELECTOR =LABS) (SELECTOR NLABS) (SELECTOR DATA) (SELECTOR UN))
|
||||
SELECTOR)
|
||||
(DEFMODE DATUM ()
|
||||
(ATOM (SELECTOR ULABS) (SELECTOR CON) (SELECTOR WN))
|
||||
SELECTOR)
|
||||
(DEFMODE CONTEXT ()
|
||||
(ATOM (SELECTOR CMARK FIXNUM 0) (SELECTOR SUBC) (SELECTOR DATA)))
|
||||
|
||||
;; Is (COPYN 0) really needed in these next four macros instead of simply 0?
|
||||
;; If the fixnum were to get clobbered, then it would seem that (LIST 0) would
|
||||
;; be the correct thing to return in the #-FIXCONS case. -cwh
|
||||
|
||||
(DEFMACRO +LABZ (X)
|
||||
`(COND ((+LABS ,X))
|
||||
(T #+FIXCONS (COPYN 0) #-FIXCONS '(0))))
|
||||
|
||||
(DEFMACRO -LABZ (X)
|
||||
`(COND ((-LABS ,X))
|
||||
(T #+FIXCONS (COPYN 0) #-FIXCONS '(0))))
|
||||
|
||||
(DEFMACRO =LABZ (X)
|
||||
`(COND ((=LABS ,X))
|
||||
(T #+FIXCONS (COPYN 0) #-FIXCONS '(0))))
|
||||
|
||||
(DEFMACRO NLABZ (X)
|
||||
`(COND ((NLABS ,X))
|
||||
(T #+FIXCONS (COPYN 0) #-FIXCONS '(0))))
|
||||
|
||||
(DEFMACRO ULABZ (X)
|
||||
`(COND ((ULABS ,X))
|
||||
(T #+FIXCONS 0 #-FIXCONS '(0))))
|
||||
|
||||
(DEFMACRO SUBP X
|
||||
#-FIXCONS (SETQ X (MAPCAR #'(LAMBDA (FORM) `(UNLAB ,FORM)) X))
|
||||
`(= ,(CAR X) (LOGAND . ,X)))
|
||||
|
||||
(DEFUN DBNODE (X) (IF (SYMBOLP X) X (LIST X)))
|
||||
(DEFUN NODEP (X) (OR (ATOM X) (MNUMP (CAR X))))
|
||||
(DEFUN DBVARP (X) (GETL X '(UN EX)))
|
||||
|
||||
;; Is this supposed to return a fixnum or a cell?
|
||||
|
||||
(DEFUN LAB (N) (LSH 1 (1- N)))
|
||||
|
||||
(DEFUN LPR (M N)
|
||||
(COND ((DO L LPRS (CDR L) (NULL L)
|
||||
(IF (AND (LABEQ M (CAAAR L)) (LABEQ N (CDAAR L)))
|
||||
(RETURN (CDAR L)))))
|
||||
((= (SETQ LPRINDEX (1- LPRINDEX)) LABINDEX) (BREAK LPR T))
|
||||
(T (SETQ LPRS (CONS (CONS (CONS M N) (LSH 1 LPRINDEX)) LPRS))
|
||||
(CDAR LPRS))))
|
||||
|
||||
(DEFUN LABEQ (X Y) (EQUAL (LOGIOR X LAB-HIGH-BIT) (LOGIOR Y LAB-HIGH-BIT)))
|
||||
|
||||
(DEFUN MARKND (ND)
|
||||
(COND ((+LABS ND))
|
||||
((= LPRINDEX (SETQ LABINDEX (1+ LABINDEX))) (BREAK MARKND T))
|
||||
(T (SETQ LABS (CONS (CONS ND (LAB LABINDEX)) LABS))
|
||||
(BEG ND (LAB LABINDEX))
|
||||
(CDAR LABS))))
|
||||
|
||||
(DEFUN DBV (X R)
|
||||
(DECLARE (FIXNUM X R Y))
|
||||
(DO ((L LPRS (CDR L)) (Y 0)) ((NULL L) Y)
|
||||
(IF (AND (NOT (= 0 (LOGAND R (CDAR L)))) (NOT (= 0 (LOGAND X (CAAAR L)))))
|
||||
(SETQ Y (LOGIOR (CDAAR L) Y)))))
|
||||
|
||||
(DEFUN DBA (R Y)
|
||||
(DECLARE (FIXNUM X R Y))
|
||||
(DO ((L LPRS (CDR L)) (X 0)) ((NULL L) X)
|
||||
(IF (AND (NOT (= 0 (LOGAND R (CDAR L)))) (NOT (= 0 (LOGAND (CDAAR L) Y))))
|
||||
(SETQ X (LOGIOR X (CAAAR L))))))
|
||||
|
||||
(DEFUN PRLAB (X)
|
||||
(SETQ-UNLAB X)
|
||||
(SETQ X (LET ((BASE 2)) (EXPLODEN (BOOLE 2 LAB-HIGH-BIT X))))
|
||||
(DO I (\ (LENGTH X) 3) 3 (NULL X)
|
||||
(DO J I (1- J) (= 0 J) (TYO (CAR X)) (SETQ X (CDR X)))
|
||||
(TYO #\SP)))
|
||||
|
||||
(DEFUN ONP (CL LAB) (SUBP LAB (+LABZ CL)))
|
||||
(DEFUN OFFP (CL LAB) (SUBP LAB (-LABZ CL)))
|
||||
(DEFUN ONPU (LAB FACT) (SUBP LAB (ULABZ FACT)))
|
||||
(DEFMFUN VISIBLEP (DAT) (AND (NOT (ULABS DAT)) (CNTP DAT)))
|
||||
|
||||
(DEFUN CANCEL (LAB DAT)
|
||||
(IF (SETQ * (ULABS DAT)) (IORM * LAB)
|
||||
(SETQ ULABS (CONS DAT ULABS))
|
||||
(SETQ-UNLAB LAB)
|
||||
(PUTPROP DAT (COPYN LAB) 'ULABS)))
|
||||
|
||||
(DEFUN BEG (ND LAB)
|
||||
(SETQ-COPYN LAB)
|
||||
(IF (QUEUE+P ND LAB)
|
||||
(IF (NULL +S) (SETQ +S (NCONS ND) +SM +S +SL +S)
|
||||
(SETQ +S (CONS ND +S)))))
|
||||
|
||||
(DEFUN BEG- (ND LAB)
|
||||
(SETQ-COPYN LAB)
|
||||
(IF (QUEUE-P ND LAB)
|
||||
(IF (NULL -S) (SETQ -S (NCONS ND) -SM -S -SL -S)
|
||||
(SETQ -S (CONS ND -S)))))
|
||||
|
||||
(DEFUN MID (ND LAB)
|
||||
(IF (QUEUE+P ND LAB)
|
||||
(IF (NULL +SM) (SETQ +S (NCONS ND) +SM +S +SL +S)
|
||||
(RPLACD +SM (CONS ND (CDR +SM)))
|
||||
(IF (EQ +SM +SL) (SETQ +SL (CDR +SL)))
|
||||
(SETQ +SM (CDR +SM)))))
|
||||
|
||||
(DEFUN MID- (ND LAB)
|
||||
(IF (QUEUE-P ND LAB)
|
||||
(IF (NULL -SM) (SETQ -S (NCONS ND) -SM -S -SL -S)
|
||||
(RPLACD -SM (CONS ND (CDR -SM)))
|
||||
(IF (EQ -SM -SL) (SETQ -SL (CDR -SL)))
|
||||
(SETQ -SM (CDR -SM)))))
|
||||
|
||||
(DEFUN END (ND LAB)
|
||||
(IF (QUEUE+P ND LAB)
|
||||
(IF (NULL +SL) (SETQ +S (NCONS ND) +SM +S +SL +S)
|
||||
(RPLACD +SL (NCONS ND))
|
||||
(SETQ +SL (CDR +SL)))))
|
||||
|
||||
(DEFUN END- (ND LAB)
|
||||
(IF (QUEUE-P ND LAB)
|
||||
(IF (NULL -SL) (SETQ -S (NCONS ND) -SM -S -SL -S)
|
||||
(RPLACD -SL (NCONS ND))
|
||||
(SETQ -SL (CDR -SL)))))
|
||||
|
||||
(DEFUN QUEUE+P (ND LAB)
|
||||
(COND ((NULL (SETQ * (+LABS ND)))
|
||||
(SETQ +LABS (CONS ND +LABS))
|
||||
(SETQ-UNLAB LAB)
|
||||
(PUT ND (COPYN (LOGIOR LAB-HIGH-BIT LAB)) '+LABS))
|
||||
((SUBP LAB *) NIL)
|
||||
((SUBP LAB-HIGH-LAB *) (IORM * LAB) NIL)
|
||||
(T (IORM * (LOGIOR LAB-HIGH-BIT (UNLAB LAB))))))
|
||||
|
||||
(DEFUN QUEUE-P (ND LAB)
|
||||
(COND ((NULL (SETQ * (-LABS ND)))
|
||||
(SETQ -LABS (CONS ND -LABS))
|
||||
(SETQ-UNLAB LAB)
|
||||
(PUT ND (COPYN (LOGIOR LAB-HIGH-BIT LAB)) '-LABS))
|
||||
((SUBP LAB *) NIL)
|
||||
((SUBP LAB-HIGH-LAB *) (IORM * LAB) NIL)
|
||||
(T (IORM * (LOGIOR LAB-HIGH-BIT (UNLAB LAB))))))
|
||||
|
||||
(DEFUN DQ+ ()
|
||||
(IF +S (PROG2 (XORM (+LABS (CAR +S)) LAB-HIGH-LAB)
|
||||
(CAR +S)
|
||||
(COND ((NOT (EQ +S +SM)) (SETQ +S (CDR +S)))
|
||||
((NOT (EQ +S +SL)) (SETQ +S (CDR +S) +SM +S))
|
||||
(T (SETQ +S NIL +SM NIL +SL NIL))))))
|
||||
|
||||
(DEFUN DQ- ()
|
||||
(IF -S (PROG2 (XORM (-LABS (CAR -S)) LAB-HIGH-LAB)
|
||||
(CAR -S)
|
||||
(COND ((NOT (EQ -S -SM)) (SETQ -S (CDR -S)))
|
||||
((NOT (EQ -S -SL)) (SETQ -S (CDR -S) -SM -S))
|
||||
(T (SETQ -S NIL -SM NIL -SL NIL))))))
|
||||
|
||||
(DEFMFUN CLEAR ()
|
||||
(IF DBTRACE (MTELL "~%Clearing ~A" MARKS))
|
||||
(MAPC #'(LAMBDA (L) (_ (SEL L +LABS) NIL)) +LABS)
|
||||
(MAPC #'(LAMBDA (L) (_ (SEL L -LABS) NIL)) -LABS)
|
||||
(MAPC #'(LAMBDA (L) (REM L 'ULABS)) ULABS)
|
||||
(SETQ +S NIL +SM NIL +SL NIL -S NIL -SM NIL -SL NIL
|
||||
LABS NIL LPRS NIL LABINDEX 0 LPRINDEX LABNUMBER
|
||||
MARKS 0 +LABS NIL -LABS NIL ULABS NIL)
|
||||
(CONTEXTMARK))
|
||||
|
||||
(DEFMFUN TRUEP (PAT)
|
||||
(CLEAR)
|
||||
(COND ((ATOM PAT) PAT)
|
||||
((PROG2 (SETQ PAT (MAPCAR #'SEMANT PAT)) NIL))
|
||||
((EQ (CAR PAT) 'KIND) (BEG (CADR PAT) 1) (BEG- (CADDR PAT) 1) (PROPG))
|
||||
(T (BEG (CADR PAT) 1) (BEG- (CADDR PAT) 2) (BEG (CAR PAT) (LPR 1 2)) (PROPG))))
|
||||
|
||||
(DEFMFUN FALSEP (PAT)
|
||||
(CLEAR)
|
||||
(COND ((EQ (CAR PAT) 'KIND)
|
||||
(BEG (CADR PAT) 1) (BEG (CADDR PAT) 1) (PROPG))))
|
||||
|
||||
(DEFMFUN ISP (PAT) (COND ((TRUEP PAT)) ((FALSEP PAT) NIL) (T 'UNKNOWN)))
|
||||
|
||||
(DEFMFUN KINDP (X Y)
|
||||
(IF (NOT (SYMBOLP X)) (MERROR "KINDP called on a non-symbolic atom."))
|
||||
(CLEAR) (BEG X 1)
|
||||
(DO P (DQ+) (DQ+) (NULL P)
|
||||
(IF (EQ Y P) (RETURN T) (MARK+ P (+LABS P)))))
|
||||
|
||||
(DEFMFUN TRUE* (PAT)
|
||||
(LET ((DUM (SEMANT PAT))) (IF DUM (CNTXT (IND (NCONS DUM)) CONTEXT))))
|
||||
|
||||
(DEFMFUN FACT (FUN ARG VAL) (CNTXT (IND (DATUM (LIST FUN ARG VAL))) CONTEXT))
|
||||
|
||||
(DEFMFUN KIND (X Y)
|
||||
(SETQ Y (DATUM (LIST 'KIND X Y))) (CNTXT Y CONTEXT) (ADDF Y X))
|
||||
|
||||
(DEFMFUN PAR (S Y)
|
||||
(SETQ Y (DATUM (LIST 'PAR S Y))) (CNTXT Y CONTEXT)
|
||||
(MAPC #'(LAMBDA (L) (ADDF Y L)) S))
|
||||
|
||||
(DEFMFUN DATUM (PAT) (NCONS PAT))
|
||||
|
||||
(DEFUN IND (DAT)
|
||||
(MAPC #'(LAMBDA (L) (IND1 DAT L)) (CDAR DAT))
|
||||
(MAPC #'IND2 (CDAR DAT))
|
||||
DAT)
|
||||
|
||||
(DEFUN IND1 (DAT PAT)
|
||||
(COND ((NOT (NODEP PAT)) (MAPC #'(LAMBDA (L) (IND1 DAT L)) PAT))
|
||||
((OR (MARKP PAT) (EQ 'UNKNOWN PAT)))
|
||||
(T (ADDF DAT PAT) (MARK PAT))))
|
||||
|
||||
(DEFUN IND2 (ND) (IF (NODEP ND) (UNMRK ND) (MAPC #'IND2 ND)))
|
||||
|
||||
|
||||
(DEFMFUN ADDF (DAT ND) (_ (SEL ND DATA) (CONS DAT (SEL ND DATA))))
|
||||
(DEFMFUN REMF (DAT ND) (_ (SEL ND DATA) (FDEL DAT (SEL ND DATA))))
|
||||
|
||||
(DEFUN FDEL (FACT DATA)
|
||||
(IF (AND (EQ (CAR FACT) (CAAAR DATA))
|
||||
(EQ (CADR FACT) (CADAAR DATA))
|
||||
(EQ (CADDR FACT) (CADDAAR DATA)))
|
||||
(CDR DATA)
|
||||
(DO ((DS DATA (CDR DS)) (D)) ((NULL (CDR DS)))
|
||||
(SETQ D (CAADR DS))
|
||||
(COND ((AND (EQ (CAR FACT) (CAR D))
|
||||
(EQ (CADR FACT) (CADR D))
|
||||
(EQ (CADDR FACT) (CADDR D)))
|
||||
(_ (SEL D CON DATA) (DELQ D (SEL D CON DATA)))
|
||||
(RPLACD DS (CDDR DS)) (RETURN T))))
|
||||
DATA))
|
||||
|
||||
(DEFUN SEMANTICS (PAT) (IF (ATOM PAT) PAT (LIST (SEMANT PAT))))
|
||||
|
||||
(DEFUN DB-MNUMP (X)
|
||||
(OR (NUMBERP X)
|
||||
(AND (NOT (ATOM X))
|
||||
(NOT (ATOM (CAR X)))
|
||||
(MEMQ (CAAR X) '(RAT BIGFLOAT)))))
|
||||
|
||||
(DEFUN SEMANT (PAT)
|
||||
(COND ((SYMBOLP PAT) (OR (GET PAT 'VAR) PAT))
|
||||
((DB-MNUMP PAT) (DINTNUM PAT))
|
||||
(T (MAPCAR #'SEMANT PAT))))
|
||||
|
||||
(DEFMFUN DINTERNP (X)
|
||||
(COND ((MNUMP X) (DINTNUM X))
|
||||
((ATOM X) X)
|
||||
((ASSOL X DOBJECTS))))
|
||||
|
||||
(DEFMFUN DINTERN (X)
|
||||
(COND ((MNUMP X) (DINTNUM X))
|
||||
((ATOM X) X)
|
||||
((ASSOL X DOBJECTS))
|
||||
(T (SETQ DOBJECTS (CONS (DBNODE X) DOBJECTS))
|
||||
(CAR DOBJECTS))))
|
||||
|
||||
(DEFUN DINTNUM (X)
|
||||
(COND ((ASSOL X NOBJECTS))
|
||||
((PROGN (SETQ X (DBNODE X)) NIL))
|
||||
((NULL NOBJECTS) (SETQ NOBJECTS (LIST X)) X)
|
||||
((EQ '$POS (RGRP (CAR X) (CAAR NOBJECTS)))
|
||||
(LET ((CONTEXT 'GLOBAL))
|
||||
(FACT 'MGRP X (CAR NOBJECTS)))
|
||||
(SETQ NOBJECTS (CONS X NOBJECTS)) X)
|
||||
(T (DO ((L NOBJECTS (CDR L)) (CONTEXT '$GLOBAL))
|
||||
((NULL (CDR L))
|
||||
(LET ((CONTEXT 'GLOBAL))
|
||||
(FACT 'MGRP (CAR L) X)) (RPLACD L (LIST X)) X)
|
||||
(COND ((EQ '$POS (RGRP (CAR X) (CAADR L)))
|
||||
(LET ((CONTEXT 'GLOBAL))
|
||||
(FACT 'MGRP (CAR L) X) (FACT 'MGRP X (CADR L)))
|
||||
(RPLACD L (CONS X (CDR L)))
|
||||
(RETURN X)))))))
|
||||
|
||||
(DEFMFUN DOUTERN (X) (IF (ATOM X) X (CAR X)))
|
||||
|
||||
(DEFMFUN UNTRUE (PAT)
|
||||
(KILL (CAR PAT) (SEMANT (CADR PAT)) (SEMANT (CADDR PAT))))
|
||||
|
||||
(DEFMFUN KILL (FUN ARG VAL) (KILL2 FUN ARG VAL ARG) (KILL2 FUN ARG VAL VAL))
|
||||
|
||||
(DEFUN KILL2 (FUN ARG VAL CL)
|
||||
(COND ((NOT (ATOM CL)) (MAPC #'(LAMBDA (L) (KILL2 FUN ARG VAL L)) CL))
|
||||
((NUMBERP CL))
|
||||
(T (_ (SEL CL DATA) (KILL3 FUN ARG VAL (SEL CL DATA))))))
|
||||
|
||||
(DEFUN KILL3 (FUN ARG VAL DATA)
|
||||
(IF (AND (EQ FUN (CAAAR DATA))
|
||||
(EQ ARG (CADAAR DATA)) (EQ VAL (CADDAAR DATA)))
|
||||
(CDR DATA)
|
||||
(DO ((DS DATA (CDR DS)) (D)) ((NULL (CDR DS)))
|
||||
(SETQ D (CAADR DS))
|
||||
(IF (NOT (AND (EQ FUN (CAR D))
|
||||
(EQ ARG (CADR D))
|
||||
(EQ VAL (CADDR D))))
|
||||
T
|
||||
(_ (SEL D CON DATA) (DELQ D (SEL D CON DATA)))
|
||||
(RPLACD DS (CDDR DS)) (RETURN T)))
|
||||
DATA))
|
||||
|
||||
(DEFMFUN UNKIND (X Y)
|
||||
(setq y (car (datum (LIST 'kind x y))))
|
||||
(kcntxt y context)
|
||||
(remf y x))
|
||||
|
||||
(defmfun remov (fact)
|
||||
(remov4 fact (cadar fact))
|
||||
(remov4 fact (caddar fact)))
|
||||
|
||||
(defun remov4 (fact cl)
|
||||
(cond ((or (symbolp cl) ;if CL is a symbol or
|
||||
(and (listp cl) ;an interned number, then we want to REMOV4 FACT
|
||||
(numberp (car cl)))) ;from its property list.
|
||||
(_ (sel cl data) (delq fact (sel cl data))))
|
||||
((or (atom cl) (atom (car cl)))) ;if CL is an atom (not a symbol)
|
||||
;or its CAR is an atom then we don't want to do
|
||||
;anything to it.
|
||||
(t (mapc #'(lambda (l) (remov4 fact l))
|
||||
(cond ((atom (caar cl)) (cdr cl)) ;if CL's CAAR is
|
||||
;an atom, then CL is an expression, and
|
||||
;we want to REMOV4 FACT from the parts
|
||||
;of the expression.
|
||||
((atom (caaar cl)) (cdar cl)))))))
|
||||
;if CL's CAAAR is an atom, then CL is a
|
||||
;fact, and we want to REMOV4 FACT from
|
||||
;the parts of the fact.
|
||||
|
||||
(DEFMFUN KILLFRAME (CL)
|
||||
(MAPC #'REMOV (SEL CL DATA))
|
||||
(REMPROP CL '+LABS) (REMPROP CL '-LABS)
|
||||
(REMPROP CL 'OBJ) (REMPROP CL 'VAR)
|
||||
(REMPROP CL 'FACT)
|
||||
(REMPROP CL 'WN))
|
||||
|
||||
(DEFMFUN ACTIVATE N
|
||||
(DO I 1 (1+ I) (> I N)
|
||||
(IF (MEMQ (ARG I) CONTEXTS) NIL
|
||||
(SETQ CONTEXTS (CONS (ARG I) CONTEXTS))
|
||||
(CMARK (ARG I)))))
|
||||
|
||||
(DEFMFUN DEACTIVATE N
|
||||
(DO I 1 (1+ I) (> I N)
|
||||
(IF (NOT (MEMQ (ARG I) CONTEXTS)) NIL
|
||||
(CUNMRK (ARG I))
|
||||
(SETQ CONTEXTS (DELQ (ARG I) CONTEXTS)))))
|
||||
|
||||
(DEFMFUN CONTEXT N (NEWCON (LISTIFY N)))
|
||||
|
||||
(DEFUN NEWCON (C)
|
||||
(IF (> CONINDEX CONNUMBER) (GCCON))
|
||||
(SETQ C (IF (NULL C) (LIST '*GC NIL) (LIST '*GC NIL 'SUBC C)))
|
||||
#-LISPM (STORE (CONUNMRK CONINDEX) C)
|
||||
#-LISPM (STORE (CONMARK CONINDEX) (CDR C))
|
||||
#+LISPM (SETF (AREF #'CONUNMRK CONINDEX) C)
|
||||
#+LISPM (SETF (AREF #'CONMARK CONINDEX) (CDR C))
|
||||
(SETQ CONINDEX (1+ CONINDEX))
|
||||
C)
|
||||
|
||||
;; To be used with the WITH-NEW-CONTEXT macro.
|
||||
(DEFUN CONTEXT-UNWINDER ()
|
||||
(KILLC (CONMARK CONINDEX))
|
||||
(SETQ CONINDEX (1- CONINDEX))
|
||||
#-LISPM (STORE (CONUNMRK CONINDEX) ())
|
||||
#+LISPM (SETF (AREF #'CONUNMRK CONINDEX) ())
|
||||
)
|
||||
|
||||
(DEFUN GCCON ()
|
||||
(GCCON1)
|
||||
(WHEN (> CONINDEX CONNUMBER)
|
||||
#+GC (GC)
|
||||
(GCCON1)
|
||||
(WHEN (> CONINDEX CONNUMBER)
|
||||
(MERROR "~%Too many contexts."))))
|
||||
|
||||
(DEFUN GCCON1 ()
|
||||
(SETQ CONINDEX 0)
|
||||
(DO I 0 (1+ I) (> I CONNUMBER)
|
||||
(IF (NOT (EQ (CONMARK I) (CDR (CONUNMRK I))))
|
||||
(KILLC (CONMARK I))
|
||||
#-LISPM (STORE (CONUNMRK CONINDEX) (CONUNMRK I))
|
||||
#+LISPM (SETF (AREF #'CONUNMRK CONINDEX) (CONUNMRK I))
|
||||
#-LISPM (STORE (CONMARK CONINDEX) (CONMARK I))
|
||||
#+LISPM (SETF (AREF #'CONMARK CONINDEX) (CONMARK I))
|
||||
(SETQ CONINDEX (1+ CONINDEX)))))
|
||||
|
||||
(DEFMFUN CNTXT (DAT CON)
|
||||
(IF (NOT (ATOM CON)) (SETQ CON (CDR CON)))
|
||||
(PUT CON (CONS DAT (GET CON 'DATA)) 'DATA)
|
||||
(IF (NOT (EQ 'GLOBAL CON)) (PUT DAT CON 'CON))
|
||||
DAT)
|
||||
|
||||
(defmfun kcntxt (fact con)
|
||||
(if (not (atom con)) (setq con (cdr con)))
|
||||
(put con (fdel fact (get con 'data)) 'data)
|
||||
(if (not (eq 'global con)) (rem fact 'con))
|
||||
fact)
|
||||
|
||||
(DEFUN CNTP (F)
|
||||
(COND ((NOT (SETQ F (SEL F CON))))
|
||||
((SETQ F (GET F 'CMARK)) (> F 0))))
|
||||
|
||||
(DEFMFUN CONTEXTMARK ()
|
||||
(LET ((CON CONTEXT))
|
||||
(UNLESS (EQ CURRENT CON)
|
||||
(CUNMRK CURRENT) (SETQ CURRENT CON) (CMARK CON))))
|
||||
|
||||
(DEFUN CMARK (CON)
|
||||
(IF (NOT (ATOM CON)) (SETQ CON (CDR CON)))
|
||||
(LET ((CM (GET CON 'CMARK)))
|
||||
(PUTPROP CON (IF CM (1+ CM) 1) 'CMARK)
|
||||
(MAPC #'CMARK (GET CON 'SUBC))))
|
||||
|
||||
(DEFUN CUNMRK (CON)
|
||||
(IF (NOT (ATOM CON)) (SETQ CON (CDR CON)))
|
||||
(LET ((CM (GET CON 'CMARK)))
|
||||
(COND (CM (PUTPROP CON (1- CM) 'CMARK)))
|
||||
(MAPC #'CUNMRK (GET CON 'SUBC))))
|
||||
|
||||
(DEFMFUN KILLC (CON)
|
||||
(CONTEXTMARK)
|
||||
(COND ((NOT (NULL CON))
|
||||
(MAPC #'REMOV (GET CON 'DATA))
|
||||
(REMPROP CON 'DATA)
|
||||
(REMPROP CON 'CMARK)
|
||||
(REMPROP CON 'SUBC)))
|
||||
T)
|
||||
|
||||
(DEFUN PROPG ()
|
||||
(DO ((X) (LAB)) (NIL)
|
||||
(COND ((SETQ X (DQ+))
|
||||
(SETQ LAB (+LABS X))
|
||||
(IF (= 0 (LOGAND (UNLAB LAB) (UNLAB (-LABZ X))))
|
||||
(MARK+ X LAB) (RETURN T)))
|
||||
((SETQ X (DQ-))
|
||||
(SETQ LAB (-LABS X))
|
||||
(IF (= 0 (LOGAND (UNLAB LAB) (UNLAB (+LABZ X))))
|
||||
(MARK- X LAB) (RETURN T)))
|
||||
(T (RETURN NIL)))))
|
||||
|
||||
(DEFUN MARK+ (CL LAB)
|
||||
(COND (DBTRACE (SETQ MARKS (1+ MARKS))
|
||||
(MTELL "~%Marking ~A +" CL) (PRLAB LAB)))
|
||||
(MAPC #'(LAMBDA (L) (MARK+0 CL LAB L)) (SEL CL DATA)))
|
||||
|
||||
(DEFUN MARK+0 (CL LAB FACT)
|
||||
(COND (DBCHECK (MTELL "~%Checking ~A from ~A+" (CAR FACT) CL) (PRLAB LAB)))
|
||||
(COND ((ONPU LAB FACT))
|
||||
((NOT (CNTP FACT)))
|
||||
((NULL (SEL FACT WN)) (MARK+1 CL LAB FACT))
|
||||
((ONP (SEL FACT WN) WORLD) (MARK+1 CL LAB FACT))
|
||||
((OFFP (SEL FACT WN) WORLD) NIL)
|
||||
(T (MARK+3 CL LAB FACT))))
|
||||
|
||||
(DEFUN MARK+1 (CL LAB DAT)
|
||||
(COND ((EQ (CAAR DAT) 'KIND)
|
||||
(IF (EQ (CADAR DAT) CL) (MID (CADDAR DAT) LAB))) ; E1
|
||||
((EQ (CAAR DAT) 'PAR)
|
||||
(IF (NOT (EQ (CADDAR DAT) CL))
|
||||
(PROGN (CANCEL LAB DAT) ; PR1
|
||||
(MID (CADDAR DAT) LAB)
|
||||
(DO L (CADAR DAT) (CDR L) (NULL L)
|
||||
(IF (NOT (EQ (CAR L) CL)) (MID- (CAR L) LAB))))))
|
||||
((EQ (CADAR DAT) CL)
|
||||
(IF (+LABS (CAAR DAT)) ; V1
|
||||
(END (CADDAR DAT) (DBV LAB (+LABS (CAAR DAT)))))
|
||||
(IF (-LABS (CADDAR DAT)) ; F4
|
||||
(END- (CAAR DAT) (LPR LAB (-LABS (CADDAR DAT))))))))
|
||||
|
||||
(DEFUN MARK+3 (CL LAB DAT) CL LAB ;Ignored
|
||||
(IFN (= 0 (LOGAND (UNLAB (+LABZ (CADDAR DAT)))
|
||||
(UNLAB (DBV (+LABZ (CADAR DAT)) (-LABZ (CAAR DAT))))))
|
||||
(BEG- (SEL DAT WN) WORLD)))
|
||||
|
||||
(DEFUN MARK- (CL LAB)
|
||||
(WHEN DBTRACE
|
||||
(SETQ MARKS (1+ MARKS)) (MTELL "Marking ~A -" CL) (PRLAB LAB))
|
||||
(MAPC #'(LAMBDA (L) (MARK-0 CL LAB L)) (SEL CL DATA)))
|
||||
|
||||
(DEFUN MARK-0 (CL LAB FACT)
|
||||
(WHEN DBCHECK (MTELL "~%Checking ~A from ~A-" (CAR FACT) CL) (PRLAB LAB))
|
||||
(COND ((ONPU LAB FACT))
|
||||
((NOT (CNTP FACT)))
|
||||
((NULL (SEL FACT WN)) (MARK-1 CL LAB FACT))
|
||||
((ONP (SEL FACT WN) WORLD) (MARK-1 CL LAB FACT))
|
||||
((OFFP (SEL FACT WN) WORLD) NIL)))
|
||||
|
||||
(DEFUN MARK-1 (CL LAB DAT)
|
||||
(COND ((EQ (CAAR DAT) 'KIND)
|
||||
(IF (NOT (EQ (CADAR DAT) CL)) (MID- (CADAR DAT) LAB))) ; E4
|
||||
((EQ (CAAR DAT) 'PAR)
|
||||
(IF (EQ (CADDAR DAT) CL)
|
||||
(PROG2 (CANCEL LAB DAT) ; S4
|
||||
(DO L (CADAR DAT) (CDR L) (NULL L) (MID- (CAR L) LAB)))
|
||||
(PROGN (SETQ-UNLAB LAB) ; ALL4
|
||||
(DO L (CADAR DAT) (CDR L) (NULL L)
|
||||
(SETQ LAB (LOGAND (UNLAB (-LABZ (CAR L))) LAB)))
|
||||
(SETQ-COPYN LAB)
|
||||
(CANCEL LAB DAT)
|
||||
(MID- (CADDAR DAT) LAB))))
|
||||
((EQ (CADDAR DAT) CL)
|
||||
(IF (+LABS (CAAR DAT)) ; A2
|
||||
(END- (CADAR DAT) (DBA (+LABS (CAAR DAT)) LAB)))
|
||||
(IF (+LABS (CADAR DAT)) ; F6
|
||||
(END- (CAAR DAT) (LPR (+LABS (CADAR DAT)) LAB))))))
|
||||
|
||||
; in out in out ins in out
|
||||
; ----------- ------------- ----------------
|
||||
; E1 | + INV1 | + AB1 |(+) + +
|
||||
; E2 | - INV2 | - AB2 |(+) - +
|
||||
; E3 | + INV3 | + AB3 |(+) + -
|
||||
; E4 | - INV4 | - AB4 |(+) - -
|
||||
; AB5 |(-) + +
|
||||
; in out in out AB6 |(-) - +
|
||||
; ----------- ------------- AB7 |(-) + -
|
||||
; S1 | (+) ALL1 |(+) + AB8 |(-) - -
|
||||
; S2 | (-) ALL2 |(+) -
|
||||
; S3 |(+) ALL3 |(-) +
|
||||
; S4 |(-) ALL4 |(-) -
|
||||
|
||||
|
||||
|
||||
; in rel out in rel out in rel out
|
||||
; --------------- --------------- ---------------
|
||||
; V1 | (+) + A1 | + (+) F1 | + (+)
|
||||
; V2 | (+) - A2 | - (+) F2 | + (-)
|
||||
; V3 | (-) + A3 | + (-) F3 | - (+)
|
||||
; V4 | (-) - A4 | - (-) F4 | - (-)
|
||||
; F5 |(+) +
|
||||
; F6 |(+) -
|
||||
; F7 |(-) +
|
||||
; F8 |(-) -
|
||||
|
||||
|
||||
(DEFUN UNI (P1 P2 AL)
|
||||
(COND ((DBVARP P1) (DBUNIVAR P1 P2 AL))
|
||||
((NODEP P1)
|
||||
(COND ((DBVARP P2) (DBUNIVAR P2 P1 AL))
|
||||
((NODEP P2) (IF (EQ P1 P2) AL))))
|
||||
((DBVARP P2) (DBUNIVAR P2 P1 AL))
|
||||
((NODEP P2) NIL)
|
||||
((SETQ AL (UNI (CAR P1) (CAR P2) AL)) (UNI (CDR P1) (CDR P2) AL))))
|
||||
|
||||
(DEFUN DBUNIVAR (P V AL)
|
||||
(LET ((DUM (ASSQ P AL)))
|
||||
(COND ((NULL DUM) (CONS (CONS P V) AL))
|
||||
(T (UNI (CDR DUM) V AL)))))
|
||||
|
||||
; Undeclarations for the file:
|
||||
|
||||
(DECLARE (NOTYPE LAB))
|
||||
|
||||
1589
src/mrg/displa.780
Normal file
1589
src/mrg/displa.780
Normal file
File diff suppressed because it is too large
Load Diff
158
src/mrg/fortra.66
Normal file
158
src/mrg/fortra.66
Normal file
@@ -0,0 +1,158 @@
|
||||
;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;;
|
||||
;;; (c) Copyright 1976, 1983 Massachusetts Institute of Technology ;;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(macsyma-module fortra)
|
||||
|
||||
(DECLARE (SPECIAL LB RB ;Used for communication with MSTRING.
|
||||
$LOADPRINT ;If NIL, no load message gets printed.
|
||||
1//2 -1//2)
|
||||
(*LEXPR FORTRAN-PRINT $FORTMX))
|
||||
|
||||
(DEFMVAR $FORTSPACES NIL
|
||||
"If T, Fortran card images are filled out to 80 columns using spaces."
|
||||
BOOLEAN
|
||||
MODIFIED-COMMANDS '$FORTRAN)
|
||||
|
||||
(DEFMVAR $FORTINDENT 0
|
||||
"The number of spaces (beyond 6) to indent Fortran statements as they
|
||||
are printed."
|
||||
FIXNUM
|
||||
MODIFIED-COMMANDS '$FORTRAN)
|
||||
|
||||
;;; Output the EXP to the editor buffer Macsyma-Generated-Fortran.
|
||||
#+LispM
|
||||
(DEFMSPEC $FORTRAN_TO_EDITOR (EXP)
|
||||
(ZWEI:WITH-EDITOR-STREAM (STANDARD-OUTPUT ':BUFFER-NAME "Macsyma-Generated-Fortran")
|
||||
(FUNCALL (GET '$FORTRAN 'MFEXPR*) EXP)))
|
||||
|
||||
;; This function is called from Macsyma toplevel. If the argument is a
|
||||
;; symbol, and the symbol is bound to a matrix, then the matrix is printed
|
||||
;; using an array assignment notation.
|
||||
|
||||
(DEFMSPEC $FORTRAN (L)
|
||||
(SETQ L (FEXPRCHECK L))
|
||||
(LET ((VALUE (STRMEVAL L)))
|
||||
(COND ((MSETQP L) (SETQ VALUE `((MEQUAL) ,(CADR L) ,(MEVAL L)))))
|
||||
(COND ((AND (SYMBOLP L) ($MATRIXP VALUE))
|
||||
($FORTMX L VALUE))
|
||||
((AND (NOT (ATOM VALUE)) (EQ (CAAR VALUE) 'MEQUAL)
|
||||
(SYMBOLP (CADR VALUE)) ($MATRIXP (CADDR VALUE)))
|
||||
($FORTMX (CADR VALUE) (CADDR VALUE)))
|
||||
(T (FORTRAN-PRINT VALUE)))))
|
||||
|
||||
;; This function is called from Lisp programs. It takes an expression and
|
||||
;; a stream argument. Default stream is NIL in MacLisp and STANDARD-OUTPUT
|
||||
;; in LMLisp. This should be canonicalized in Macsyma at some point.
|
||||
|
||||
;; TERPRI is a PDP10 MacLisp flag which, if set to T, will keep symbols and
|
||||
;; bignums from being broken across page boundaries when printed. $LOADPRINT
|
||||
;; is NIL to keep a message from being printed when the file containing MSTRING
|
||||
;; is loaded. (MRG;GRIND)
|
||||
|
||||
(DEFPROP MEXPT (#/* #/*) DISSYM)
|
||||
|
||||
(DEFUN FORTRAN-PRINT (X &OPTIONAL (STREAM #-LISPM NIL #+LISPM STANDARD-OUTPUT)
|
||||
&AUX #+PDP10 (TERPRI T) #+PDP10 ($LOADPRINT NIL)
|
||||
;; This is a poor way of saying that array references
|
||||
;; are to be printed with parens instead of brackets.
|
||||
(LB #/( ) (RB #/) ))
|
||||
;; Restructure the expression for displaying.
|
||||
(SETQ X (FORTSCAN X))
|
||||
;; Linearize the expression using MSTRING. Some global state must be
|
||||
;; modified for MSTRING to generate using Fortran syntax. This must be
|
||||
;; undone so as not to modify the toplevel behavior of MSTRING.
|
||||
(UNWIND-PROTECT
|
||||
(PROGN
|
||||
(DEFPROP MEXPT MSIZE-INFIX GRIND)
|
||||
(DEFPROP MMINUS 100. LBP)
|
||||
(DEFPROP MSETQ (#/=) STRSYM)
|
||||
(SETQ X (MSTRING X)))
|
||||
;; Make sure this gets done before exiting this frame.
|
||||
(DEFPROP MEXPT MSZ-MEXPT GRIND)
|
||||
(REMPROP 'MMINUS 'LBP)
|
||||
(DEFPROP MSETQ (#/:) STRSYM))
|
||||
;; MSTRING returns a list of characters. Now print them.
|
||||
(DO ((C #/0 (+ 1 (\ (- c #/0) 16) #/0))
|
||||
(COLUMN (+ 6 $FORTINDENT) (+ 9 $FORTINDENT)))
|
||||
((NULL X))
|
||||
;; Print five spaces, a continuation character if needed, and then
|
||||
;; more spaces. COLUMN points to the last column printed in. When
|
||||
;; it equals 80, we should quit.
|
||||
(COND ((= C #/0)
|
||||
(PRINT-SPACES COLUMN STREAM))
|
||||
(T (PRINT-SPACES 5 STREAM)
|
||||
(TYO C STREAM)
|
||||
(PRINT-SPACES (- COLUMN 6) STREAM)))
|
||||
;; Print the expression. Remember, Fortran ignores blanks and line
|
||||
;; terminators, so we don't care where the expression is broken.
|
||||
(DO ()
|
||||
((= COLUMN 72.))
|
||||
(IF (NULL X)
|
||||
(IF $FORTSPACES (TYO #\SP STREAM) (RETURN NIL))
|
||||
(progn (and (equal (car x) #/\) (setq x (cdr x)))
|
||||
(TYO (POP X) STREAM)))
|
||||
(INCREMENT COLUMN))
|
||||
;; Columns 73 to 80 contain spaces
|
||||
(IF $FORTSPACES (PRINT-SPACES 8 STREAM))
|
||||
(TERPRI STREAM))
|
||||
'$DONE)
|
||||
|
||||
(DEFUN PRINT-SPACES (N STREAM)
|
||||
(DOTIMES (I N) (TYO #\SP STREAM)))
|
||||
|
||||
;; This function is similar to NFORMAT. Prepare an expression
|
||||
;; for printing by converting x^(1/2) to sqrt(x), etc. A better
|
||||
;; way of doing this would be to have a programmable printer and
|
||||
;; not cons any new expressions at all. Some of this formatting, such
|
||||
;; as E^X --> EXP(X) is specific to Fortran.
|
||||
|
||||
(DEFUN FORTSCAN (E)
|
||||
(COND ((ATOM E) (cond ((eq e '$%i) '((mprogn) 0.0 1.0))
|
||||
(t E))) ;%I is (0,1)
|
||||
((AND (EQ (CAAR E) 'MEXPT) (EQ (CADR E) '$%E))
|
||||
(LIST '($EXP SIMP) (FORTSCAN (CADDR E))))
|
||||
((AND (EQ (CAAR E) 'MEXPT) (ALIKE1 (CADDR E) 1//2))
|
||||
(LIST '(%SQRT SIMP) (FORTSCAN (CADR E))))
|
||||
((AND (EQ (CAAR E) 'MEXPT) (ALIKE1 (CADDR E) -1//2))
|
||||
(LIST '(MQUOTIENT SIMP) 1 (LIST '(%SQRT SIMP) (FORTSCAN (CADR E)))))
|
||||
((AND (EQ (CAAR E) 'MTIMES) (RATNUMP (CADR E))
|
||||
(MEMBER (CADADR E) '(1 -1)))
|
||||
(COND ((EQUAL (CADADR E) 1) (FORTSCAN-MTIMES E))
|
||||
(T (LIST '(MMINUS SIMP) (FORTSCAN-MTIMES E)))))
|
||||
((EQ (CAAR E) 'RAT)
|
||||
(LIST '(MQUOTIENT SIMP) (FLOAT (CADR E)) (FLOAT (CADDR E))))
|
||||
((EQ (CAAR E) 'MRAT) (FORTSCAN (RATDISREP E)))
|
||||
;; complex numbers to f77 syntax a+b%i ==> (a,b)
|
||||
((and (memq (caar e) '(mtimes mplus))
|
||||
((lambda (a)
|
||||
(and (numberp (cadr a))
|
||||
(numberp (caddr a))
|
||||
(not (zerop1 (cadr a)))
|
||||
(list '(mprogn) (caddr a) (cadr a))))
|
||||
(simplify ($bothcoef e '$%i)))))
|
||||
(T (CONS (CAR E) (MAPCAR 'FORTSCAN (CDR E))))))
|
||||
|
||||
(DEFUN FORTSCAN-MTIMES (E)
|
||||
(LIST '(MQUOTIENT SIMP)
|
||||
(COND ((NULL (CDDDR E)) (FORTSCAN (CADDR E)))
|
||||
(T (CONS (CAR E) (MAPCAR 'FORTSCAN (CDDR E)))))
|
||||
(FLOAT (CADDR (CADR E)))))
|
||||
|
||||
;; Takes a name and a matrix and prints a sequence of Fortran assignment
|
||||
;; statements of the form
|
||||
;; NAME(I,J) = <corresponding matrix element>
|
||||
|
||||
(DEFMFUN $FORTMX (NAME MAT &OPTIONAL (STREAM #-LISPM NIL #+LISPM STANDARD-OUTPUT)
|
||||
&AUX ($LOADPRINT NIL))
|
||||
(DECLARE (FIXNUM I J))
|
||||
(COND ((NOT (EQ (TYPEP NAME) 'SYMBOL))
|
||||
(MERROR "~%First argument to FORTMX must be a symbol."))
|
||||
((NOT ($MATRIXP MAT))
|
||||
(MERROR "Second argument to FORTMX not a matrix: ~M" MAT)))
|
||||
(DO ((MAT (CDR MAT) (CDR MAT)) (I 1 (1+ I))) ((NULL MAT))
|
||||
(DO ((M (CDAR MAT) (CDR M)) (J 1 (1+ J))) ((NULL M))
|
||||
(FORTRAN-PRINT `((MEQUAL) ((,NAME) ,I ,J) ,(CAR M)) STREAM)))
|
||||
'$DONE)
|
||||
|
||||
|
||||
565
src/mrg/gram.487
Normal file
565
src/mrg/gram.487
Normal file
@@ -0,0 +1,565 @@
|
||||
;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;;
|
||||
;;; (c) Copyright 1981 Massachusetts Institute of Technology ;;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(macsyma-module gram)
|
||||
|
||||
;;; Notes:
|
||||
;;;
|
||||
;;; KMP 12/14/80 -- Modified $DO and friends (things with NUD prop of NUD-$DO)
|
||||
;;; to have an LBP of 5. instead 30. New operators introduced
|
||||
;;; after this time should have an LBP of 5 if they have an
|
||||
;;; NUD but no LED property unless there is a *very* good
|
||||
;;; reason for that not to be so.
|
||||
;;;
|
||||
;;; Note also that the binding powers for - are incorrectly
|
||||
;;; set also. New operators with LBP's in the range 120.-130.
|
||||
;;; should beware of this. My new parser scheme has the
|
||||
;;; correction for this. It's too much pain right now to
|
||||
;;; integrate the correct thing into this parser. Due to some
|
||||
;;; inelegant and inefficient patches to special-case "-" here
|
||||
;;; and there throughout this code, the user doesn't see the
|
||||
;;; difference, so we can live with current lossage for now.
|
||||
|
||||
|
||||
|
||||
(LOAD-MACSYMA-MACROS MRGMAC)
|
||||
|
||||
(DECLARE (GENPREFIX GRM)
|
||||
(SPECIAL ST1 STRING MOPL $PROPS ALIASLIST)
|
||||
(*EXPR MEVAL MEVAL1 GETOP ADD2LNC REMCHK
|
||||
FULLSTRIP1 STRING* WNA-ERR GETOPR REMPROPCHK $LISTP))
|
||||
|
||||
;; "First character" and "Pop character"
|
||||
|
||||
(DEFMACRO FIRST-C () `(FIRST STRING))
|
||||
(DEFMACRO POP-C () `(POP STRING))
|
||||
|
||||
(DEFMACRO CONVERT-$ANY (X) `(CDR ,X))
|
||||
|
||||
(DEFMACRO MATCH (X) `(GET ,X 'MATCH))
|
||||
|
||||
(DEFMVAR $PARSEWINDOW 10.
|
||||
"The maximum number of 'lexical tokens' that are printed out on
|
||||
each side of the error-point when a syntax (parsing) error occurs. This
|
||||
option is especially useful on slow terminals. Setting it to -1 causes the
|
||||
entire input string to be printed out when an error occurs."
|
||||
FIXNUM)
|
||||
|
||||
|
||||
(DEFUN PARSE (MODE RBP)
|
||||
(DO ((LEFT (IF (OPERATORP (FIRST-C)) (NUD (POP-C)) (CONS '$ANY (POP-C)))
|
||||
(LED (POP-C) LEFT)))
|
||||
((>= RBP (LBP (FIRST-C))) (CONVERT LEFT MODE))))
|
||||
|
||||
(DEFUN PARSE-PREFIX (OP)
|
||||
(LIST (POS OP) (LIST OP) (PARSE (RPOS OP) (RBP OP))))
|
||||
|
||||
(DEFUN PARSE-POSTFIX (OP L)
|
||||
(LIST (POS OP) (LIST OP) (CONVERT L (LPOS OP))))
|
||||
|
||||
(DEFUN PARSE-INFIX (OP L)
|
||||
(LIST (POS OP) (LIST OP) (CONVERT L (LPOS OP)) (PARSE (RPOS OP) (RBP OP))))
|
||||
|
||||
(DEFUN PARSE-NARY (OP L)
|
||||
(CONS (POS OP) (CONS (LIST OP) (CONS (CONVERT L (LPOS OP)) (PRSNARY OP (LPOS OP) (LBP OP))))))
|
||||
|
||||
(DEFUN PARSE-MATCHFIX (OP)
|
||||
(CONS (POS OP) (CONS (LIST OP) (PRSMATCH (MATCH OP) (LPOS OP)))))
|
||||
|
||||
(DEFUN PARSE-NOFIX (OP) (LIST (POS OP) (LIST OP)))
|
||||
|
||||
(DEFUN PRSNARY (OP MODE RBP)
|
||||
(DO ((NL (LIST (PARSE MODE RBP)) (CONS (PARSE MODE RBP) NL)))
|
||||
((NOT (EQ OP (FIRST-C))) (NREVERSE NL))
|
||||
(POP-C)))
|
||||
|
||||
(DEFUN PRSMATCH (MATCH MODE)
|
||||
(COND ((EQ MATCH (FIRST-C)) (POP-C) NIL)
|
||||
(T (DO ((NL (LIST (PARSE MODE 10.)) (CONS (PARSE MODE 10.) NL)))
|
||||
((EQ MATCH (FIRST-C)) (POP-C) (NREVERSE NL))
|
||||
(IF (EQ '|$,| (FIRST-C)) (POP-C) (MRP-ERR MATCH))))))
|
||||
|
||||
|
||||
(DEFUN CONVERT (ITEM MODE)
|
||||
(IF (OR (EQ MODE (CAR ITEM)) (EQ '$ANY MODE) (EQ '$ANY (CAR ITEM)))
|
||||
(CDR ITEM)
|
||||
(PARSE-ERR)))
|
||||
|
||||
(DEFUN OPERATORP (LEX) (OR (GET LEX 'LED) (GET LEX 'NUD)))
|
||||
(DEFUN OPERATORP1 (LEX) (OR (GET LEX 'LED) (GET LEX 'NUD)
|
||||
(GET LEX 'LBP) (GET LEX 'RBP)))
|
||||
(DEFUN NUD (OP) (IF (GET OP 'NUD) (FUNCALL (GET OP 'NUD) OP) (UDN-ERR OP)))
|
||||
(DEFUN LED (OP L) (IF (GET OP 'LED) (FUNCALL (GET OP 'LED) OP L) (UDL-ERR OP)))
|
||||
|
||||
(DEFMFUN LBP (LEX) (COND ((GET LEX 'LBP)) (T 200.)))
|
||||
(DEFMFUN RBP (LEX) (COND ((GET LEX 'RBP)) (T 200.)))
|
||||
|
||||
(DEFUN LPOS (OP) (COND ((GET OP 'LPOS)) (T '$ANY)))
|
||||
(DEFUN RPOS (OP) (COND ((GET OP 'RPOS)) (T '$ANY)))
|
||||
(DEFUN POS (OP) (COND ((GET OP 'POS)) (T '$ANY)))
|
||||
|
||||
;; This is all going to have to be made to signal if it is to work through
|
||||
;; ZWEI or a display front end. We can't pass format strings in MacLisp, and
|
||||
;; we can't pass symbols either (address space). So I guess we use a
|
||||
;; PARSE-ERROR macro which becomes PRINC on ITS. This doesn't solve the
|
||||
;; problem for the ITS display front end, unless separate fasl files are used.
|
||||
|
||||
;; N.B. Format strings can now be passed in Maclisp on ITS due to the
|
||||
;; out-of-core error-string system. So whoever wrote the above comment
|
||||
;; might want to do something about it. -gjc
|
||||
|
||||
(DEFUN PARSE-ERR ()
|
||||
(MTELL-OPEN "~%Syntax error") (PRSYNERR))
|
||||
|
||||
(DEFUN MRP-ERR (MATCH)
|
||||
(MTELL-OPEN "~%Missing /"~A/"" (STRIPDOLLAR MATCH))
|
||||
(PRSYNERR))
|
||||
|
||||
(DEFUN ERP-ERR (OP L) OP L ;Ignored
|
||||
(MTELL-OPEN "~%Too many /)")
|
||||
(PRSYNERR))
|
||||
|
||||
(DEFUN ERB-ERR (OP L) OP L ;Ignored
|
||||
(MTELL-OPEN "~%Too many ]")
|
||||
(PRSYNERR))
|
||||
|
||||
(DEFUN UDN-ERR (OP)
|
||||
(MTELL-OPEN "~%/"~A/" is not a prefix operator." (FULLSTRIP1 OP))
|
||||
(PRSYNERR))
|
||||
|
||||
(DEFUN UDL-ERR (OP)
|
||||
(MTELL-OPEN "~%/"~A/" is not an infix operator." (FULLSTRIP1 OP))
|
||||
(PRSYNERR))
|
||||
|
||||
(DEFUN DELIM-ERR (OP) OP ;Ignored
|
||||
(MTELL-OPEN "~%Illegal use of delimiter.")
|
||||
(PRSYNERR))
|
||||
|
||||
(DEFUN PRSYNERR ()
|
||||
(IF (NULL STRING) (RPLACA (LAST ST1) '**$**)
|
||||
(RPLACD STRING (CONS (CAR STRING) (CDR STRING)))
|
||||
(RPLACA STRING '**$**)
|
||||
(RPLACA (LAST ST1) '| |))
|
||||
(TERPRI)
|
||||
(COND ((NOT (= $PARSEWINDOW 0))
|
||||
(COND ((NOT (= $PARSEWINDOW -1))
|
||||
(COND ((NOT (NULL STRING))
|
||||
(DO ((STR (LIST NIL) (CONS (CAR S) STR))
|
||||
(S (CDR STRING) (CDR S)))
|
||||
((OR (NULL S) (> (LENGTH STR) $PARSEWINDOW))
|
||||
(RPLACD STRING (CDR (NREVERSE STR)))))))
|
||||
(DO ((STR ST1 (CDR STR)))
|
||||
((NOT (> (- (LENGTH STR) (LENGTH (MEMBER '**$** STR)))
|
||||
$PARSEWINDOW))
|
||||
(SETQ ST1 STR)))))
|
||||
(MAPC #'(LAMBDA (L) (PRINC (FULLSTRIP1 L)) (TYO #\SPACE)) ST1)
|
||||
(TERPRI)))
|
||||
(PRINC "Please rephrase or edit.")
|
||||
(IF (NOT (= $PARSEWINDOW 0)) (TERPRI))
|
||||
(MERROR ""))
|
||||
|
||||
(DEFMFUN DEFINE-SYMBOL (SYM)
|
||||
(PROG (DUMMY LEN X Y)
|
||||
(SETQ DUMMY (MAPCAR 'ASCII (CASIFY-EXPLODEN SYM))
|
||||
SYM (IMPLODE (CONS '$ DUMMY))
|
||||
LEN (LENGTH DUMMY))
|
||||
(COND ((= LEN 2)
|
||||
(COND ((NOT (AND (SETQ X (GET (CAR DUMMY) 'OP2C))
|
||||
(ASSOC (GETCHARN (CADR DUMMY) 1) X)))
|
||||
(PUTPROP (CAR DUMMY)
|
||||
(CONS (CONS (GETCHARN (CADR DUMMY) 1) SYM)
|
||||
(GET (CAR DUMMY) 'OP2C))
|
||||
'OP2C))))
|
||||
((= LEN 3)
|
||||
(SETQ Y (MAPCAR #'(LAMBDA (X) (GETCHARN X 1)) (CDR DUMMY)))
|
||||
(COND ((NOT (AND (SETQ X (GET (CAR DUMMY) 'OP3C))
|
||||
(ASSOC Y X)))
|
||||
(PUTPROP (CAR DUMMY)
|
||||
(CONS (CONS Y SYM) (GET (CAR DUMMY) 'OP3C))
|
||||
'OP3C))))
|
||||
; ((> LEN 3) ; This error check needs more work. - JPG
|
||||
; (PRINC (FULLSTRIP1 SYM))
|
||||
; (MERROR "~%User defined operators can have at most 3 characters."))
|
||||
)
|
||||
(RETURN SYM)))
|
||||
|
||||
(DEFUN KILL-OPERATOR (OP)
|
||||
(REM OP 'NUD) (REM OP 'LED)
|
||||
(REM OP 'LBP) (REM OP 'RBP)
|
||||
(REM OP 'LPOS) (REM OP 'RPOS) (REM OP 'POS)
|
||||
(REM OP 'GRIND)
|
||||
(REM OP 'DIMENSION) (REM OP 'DISSYM)
|
||||
(LET ((OPR (GET OP 'OP))) (REM OP 'OP) (REM OPR 'OPR) (REMPROPCHK OPR))
|
||||
(SETQ OP ($NOUNIFY OP))
|
||||
(REM OP 'DIMENSION) (REM OP 'DISSYM)
|
||||
(REM OP 'LBP) (REM OP 'RBP))
|
||||
|
||||
(DEFPROP $/[ NUD-$/[ NUD)
|
||||
(DEFPROP $/[ LED-$/[ LED)
|
||||
(DEFPROP $/[ 200. LBP)
|
||||
(DEFPROP $/] DELIM-ERR NUD)
|
||||
(DEFPROP $/] ERB-ERR LED)
|
||||
(DEFPROP $/] 5. LBP)
|
||||
|
||||
(DEFUN NUD-$/[ (OP) OP ;Ignored
|
||||
(CONS '$ANY (CONS '(MLIST) (PRSMATCH '$/] '$ANY))))
|
||||
|
||||
(DEFUN LED-$/[ (OP LEFT) OP ;Ignored
|
||||
(LET ((RIGHT))
|
||||
(SETQ LEFT (CONVERT-$ANY LEFT))
|
||||
(IF (NUMBERP LEFT) (PARSE-ERR))
|
||||
(SETQ RIGHT (PRSMATCH '$/] '$ANY))
|
||||
(IF (NULL RIGHT) (NSUB-ERR))
|
||||
(CONS '$ANY
|
||||
(COND ((ATOM LEFT)
|
||||
(SETQ RIGHT (CONS (LIST (AMPERCHK LEFT) 'ARRAY) RIGHT))
|
||||
(OR (CDR (ASSOL RIGHT ALIASLIST)) RIGHT))
|
||||
(T (LIST* '(MQAPPLY ARRAY) LEFT RIGHT))))))
|
||||
|
||||
(DEFUN NSUB-ERR ()
|
||||
(MTELL-OPEN "~%No subscripts given") (PRSYNERR))
|
||||
|
||||
|
||||
(DEFPROP $/( NUD-$/( NUD)
|
||||
(DEFPROP $/( LED-$/( LED)
|
||||
(DEFPROP $/( 200. LBP)
|
||||
(DEFPROP $/) DELIM-ERR NUD)
|
||||
(DEFPROP $/) ERP-ERR LED)
|
||||
(DEFPROP $/) 5. LBP)
|
||||
|
||||
(DEFUN NUD-$/( (OP) OP ;Ignored
|
||||
(LET ((RIGHT))
|
||||
(IF (EQ (FIRST-C) '$/)) (PARSE-ERR))
|
||||
(CONS '$ANY
|
||||
(COND ((OR (NULL (SETQ RIGHT (PRSMATCH '$/) '$ANY))) (CDR RIGHT))
|
||||
(CONS '(MPROGN) RIGHT))
|
||||
(T (CAR RIGHT))))))
|
||||
|
||||
(DEFUN LED-$/( (OP LEFT) OP ;Ignored
|
||||
(LET ((RIGHT))
|
||||
(SETQ LEFT (CONVERT-$ANY LEFT))
|
||||
(IF (NUMBERP LEFT) (PARSE-ERR))
|
||||
(SETQ RIGHT (PRSMATCH '$/) '$ANY))
|
||||
(CONS '$ANY
|
||||
(COND ((ATOM LEFT) (CONS (NCONS (AMPERCHK LEFT)) RIGHT))
|
||||
(T (LIST* '(MQAPPLY) LEFT RIGHT))))))
|
||||
|
||||
(DEFPROP $/' NUD-$/' NUD)
|
||||
|
||||
(DEFUN NUD-$/' (OP) OP ;Ignored
|
||||
(LET ((RIGHT))
|
||||
(CONS '$ANY
|
||||
(COND ((EQ (FIRST-C) '$/()
|
||||
(LIST '(MQUOTE) (PARSE '$ANY 190.)))
|
||||
((OR (ATOM (SETQ RIGHT (PARSE '$ANY 190.)))
|
||||
(MEMQ (CAAR RIGHT)
|
||||
'(MQUOTE MLIST MPROG MPROGN LAMBDA MDO MDOIN)))
|
||||
(LIST '(MQUOTE) RIGHT))
|
||||
((EQ (CAAR RIGHT) 'MQAPPLY)
|
||||
(COND ((EQ (CAAADR RIGHT) 'LAMBDA)
|
||||
(LIST '(MQUOTE) RIGHT))
|
||||
(T (RPLACA (CDR RIGHT)
|
||||
(CONS (CONS ($NOUNIFY (CAAADR RIGHT))
|
||||
(CDAADR RIGHT))
|
||||
(CDADR RIGHT)))
|
||||
RIGHT)))
|
||||
(T (CONS (CONS ($NOUNIFY (CAAR RIGHT)) (CDAR RIGHT))
|
||||
(CDR RIGHT)))))))
|
||||
|
||||
|
||||
(DEFPROP |$''| |NUD-$''| NUD)
|
||||
|
||||
(DEFUN |NUD-$''| (OP) OP ;Ignored
|
||||
(LET ((RIGHT))
|
||||
(CONS '$ANY
|
||||
(COND ((EQ (FIRST-C) '$/() (MEVAL (PARSE '$ANY 190.)))
|
||||
((ATOM (SETQ RIGHT (PARSE '$ANY 190.))) (MEVAL1 RIGHT))
|
||||
((EQ (CAAR RIGHT) 'MQAPPLY)
|
||||
(RPLACA (CDR RIGHT)
|
||||
(CONS (CONS ($VERBIFY (CAAADR RIGHT))
|
||||
(CDAADR RIGHT))
|
||||
(CDADR RIGHT)))
|
||||
RIGHT)
|
||||
(T (CONS (CONS ($VERBIFY (CAAR RIGHT)) (CDAR RIGHT))
|
||||
(CDR RIGHT)))))))
|
||||
|
||||
|
||||
(DEFPROP |$:| |LED-$:| LED)
|
||||
(DEFPROP |$:| 180. LBP)
|
||||
|
||||
(DEFUN |LED-$:| (OP LEFT) OP ;Ignored
|
||||
(LIST '$ANY '(MSETQ) (CDR LEFT) (PARSE '$ANY 20.)))
|
||||
|
||||
|
||||
(DEFPROP |$::| |LED-$::| LED)
|
||||
(DEFPROP |$::| 180. LBP)
|
||||
|
||||
(DEFUN |LED-$::| (OP LEFT) OP ;Ignored
|
||||
(LIST '$ANY '(MSET) (CDR LEFT) (PARSE '$ANY 20.)))
|
||||
|
||||
|
||||
(DEFPROP |$:=| |LED-$:=| LED)
|
||||
(DEFPROP |$:=| 180. LBP)
|
||||
|
||||
(DEFUN |LED-$:=| (OP LEFT) OP ;Ignored
|
||||
(COND ((ATOM (CDR LEFT)) (ATM-ERR))
|
||||
(T (LIST '$ANY '(MDEFINE) (CDR LEFT) (PARSE '$ANY 20.)))))
|
||||
|
||||
(DEFPROP |$::=| |LED-$::=| LED)
|
||||
(DEFPROP |$::=| 180. LBP)
|
||||
|
||||
(DEFUN |LED-$::=| (OP LEFT) OP ;Ignored
|
||||
(LIST '$ANY '(MDEFMACRO) (CDR LEFT) (PARSE '$ANY 20.)))
|
||||
|
||||
(DEFUN ATM-ERR ()
|
||||
(MTELL-OPEN "~%Atom passed to /":=/" or /"::=/"; try /":/"")
|
||||
(PRSYNERR))
|
||||
|
||||
|
||||
(DEFPROP $! LED-$! LED)
|
||||
(DEFPROP $! 160. LBP)
|
||||
|
||||
(DEFUN LED-$! (OP LEFT) OP ;Ignored
|
||||
(LIST '$EXPR '(MFACTORIAL) (CONVERT LEFT '$EXPR)))
|
||||
|
||||
|
||||
(DEFPROP $!! LED-$!! LED)
|
||||
(DEFPROP $!! 160. LBP)
|
||||
|
||||
(DEFUN LED-$!! (OP LEFT) OP ;Ignored
|
||||
(LIST '$EXPR '($GENFACT) (CONVERT LEFT '$EXPR)
|
||||
(LIST '(MQUOTIENT) (CONVERT LEFT '$EXPR) 2) 2))
|
||||
|
||||
|
||||
(DEFPROP $^ LED-$^ LED)
|
||||
(DEFPROP $^ 140. LBP)
|
||||
(DEFPROP $** LED-$^ LED)
|
||||
(DEFPROP $** 140. LBP)
|
||||
|
||||
(DEFUN LED-$^ (OP LEFT) OP ;Ignored
|
||||
(SETQ LEFT (LIST '(MEXPT) (CONVERT LEFT '$EXPR)
|
||||
(COND ((EQ '$- (FIRST-C)) (POP-C) (LIST '(MMINUS) (PARSE '$EXPR 139.)))
|
||||
(T (PARSE '$EXPR 139.)))))
|
||||
(CONS '$EXPR (COND ((CDR (ASSOL LEFT ALIASLIST))) (T LEFT))))
|
||||
|
||||
|
||||
(DEFPROP $^^ LED-$^^ LED)
|
||||
(DEFPROP $^^ 135. LBP)
|
||||
|
||||
(DEFUN LED-$^^ (OP LEFT) OP ;Ignored
|
||||
(SETQ LEFT (LIST '(MNCEXPT) (CONVERT LEFT '$EXPR)
|
||||
(IFN (EQ '$- (FIRST-C)) (PARSE '$EXPR 134.)
|
||||
(POP-C) (LIST '(MMINUS) (PARSE '$EXPR 134.)))))
|
||||
(CONS '$EXPR (COND ((CDR (ASSOL LEFT ALIASLIST))) (T LEFT))))
|
||||
|
||||
|
||||
(DEFPROP $/. LED-$/. LED)
|
||||
(DEFPROP $/. 110. LBP)
|
||||
|
||||
(DEFUN LED-$/. (OP LEFT) OP ;Ignored
|
||||
(LIST '$EXPR '(MNCTIMES) (CONVERT LEFT '$EXPR) (PARSE '$EXPR 109.)))
|
||||
|
||||
(DEFPROP $* LED-$* LED)
|
||||
(DEFPROP $* 120. LBP)
|
||||
|
||||
(DEFUN LED-$* (OP LEFT) OP ;Ignored
|
||||
(LIST* '$EXPR '(MTIMES) (CONVERT LEFT '$EXPR) (PRSNARY '$* '$EXPR 120.)))
|
||||
|
||||
|
||||
(DEFPROP $// LED-$// LED)
|
||||
(DEFPROP $// 120. LBP)
|
||||
|
||||
(DEFUN LED-$// (OP LEFT) OP ;Ignored
|
||||
(LIST '$EXPR '(MQUOTIENT) (CONVERT LEFT '$EXPR) (PARSE '$EXPR 120.)))
|
||||
|
||||
|
||||
(DEFPROP $+ NUD-$+ NUD)
|
||||
(DEFPROP $+ LED-$+ LED)
|
||||
(DEFPROP $+ 100. LBP)
|
||||
|
||||
(DEFUN NUD-$+ (OP) OP ;Ignored
|
||||
(COND ((MEMQ (FIRST-C) '($+ $-)) (PARSE-ERR))
|
||||
(T (LIST '$EXPR '(MPLUS) (PARSE '$EXPR 100.)))))
|
||||
|
||||
(DEFUN LED-$+ (OP LEFT) OP ;Ignored
|
||||
(DO ((NL (LIST (PARSE '$EXPR 100.) (CONVERT LEFT '$EXPR))))
|
||||
(NIL)
|
||||
(COND ((EQ '$+ (FIRST-C)) (POP-C) (SETQ NL (CONS (PARSE '$EXPR 100.) NL)))
|
||||
((EQ '$- (FIRST-C)) (POP-C)
|
||||
(SETQ NL (CONS (LIST '(MMINUS) (PARSE '$EXPR 100.)) NL)))
|
||||
(T (RETURN (CONS '$EXPR (CONS '(MPLUS) (NREVERSE NL))))))))
|
||||
|
||||
|
||||
(DEFPROP $- NUD-$- NUD)
|
||||
(DEFPROP $- LED-$- LED)
|
||||
(DEFPROP $- 100. LBP)
|
||||
|
||||
(DEFUN NUD-$- (OP) OP ;Ignored
|
||||
(IF (EQ '$+ (FIRST-C)) (PARSE-ERR)
|
||||
(LIST '$EXPR '(MMINUS) (PARSE '$EXPR 100.))))
|
||||
|
||||
(DEFUN LED-$- (OP LEFT) OP ;Ignored
|
||||
(DO ((NL (LIST (LIST '(MMINUS) (PARSE '$EXPR 100.)) (CONVERT LEFT '$EXPR)))) (NIL)
|
||||
(COND ((EQ '$+ (FIRST-C)) (POP-C)
|
||||
(SETQ NL (CONS (PARSE '$EXPR 100.) NL)))
|
||||
((EQ '$- (FIRST-C)) (POP-C)
|
||||
(SETQ NL (CONS (LIST '(MMINUS) (PARSE '$EXPR 100.)) NL)))
|
||||
(T (RETURN (CONS '$EXPR (CONS '(MPLUS) (NREVERSE NL))))))))
|
||||
|
||||
|
||||
(DEFPROP $= LED-$= LED)
|
||||
(DEFPROP $= 80. LBP)
|
||||
|
||||
(DEFUN LED-$= (OP LEFT) OP ;Ignored
|
||||
`($CLAUSE (MEQUAL) ,(CONVERT LEFT '$EXPR) ,(PARSE '$EXPR 80.)))
|
||||
|
||||
(DEFPROP $/# LED-$/# LED)
|
||||
(DEFPROP $/# 80. LBP)
|
||||
|
||||
(DEFUN LED-$/# (OP LEFT) OP ;Ignored
|
||||
`($CLAUSE (MNOTEQUAL) ,(CONVERT LEFT '$EXPR) ,(PARSE '$EXPR 80.)))
|
||||
|
||||
(DEFPROP $/> NUD-$/> NUD)
|
||||
|
||||
(DEFUN NUD-$/> (OP) OP ;Ignored
|
||||
'($ANY . $/>))
|
||||
|
||||
|
||||
(DEFPROP $/> LED-$/> LED)
|
||||
(DEFPROP $/> 80. LBP)
|
||||
|
||||
(DEFUN LED-$/> (OP LEFT) OP ;Ignored
|
||||
`($CLAUSE (MGREATERP) ,(CONVERT LEFT '$EXPR) ,(PARSE '$EXPR 80.)))
|
||||
|
||||
|
||||
(DEFPROP $/>= LED-$/>= LED)
|
||||
(DEFPROP $/>= 80. LBP)
|
||||
|
||||
(DEFUN LED-$/>= (OP LEFT) OP ;Ignored
|
||||
`($CLAUSE (MGEQP) ,(CONVERT LEFT '$EXPR) ,(PARSE '$EXPR 80.)))
|
||||
|
||||
|
||||
(DEFPROP $/< LED-$/< LED)
|
||||
(DEFPROP $/< 80. LBP)
|
||||
|
||||
(DEFUN LED-$/< (OP LEFT) OP ;Ignored
|
||||
`($CLAUSE (MLESSP) ,(CONVERT LEFT '$EXPR) ,(PARSE '$EXPR 80.)))
|
||||
|
||||
(DEFPROP $/<= LED-$/<= LED)
|
||||
(DEFPROP $/<= 80. LBP)
|
||||
|
||||
(DEFUN LED-$/<= (OP LEFT) OP ;Ignored
|
||||
`($CLAUSE (MLEQP) ,(CONVERT LEFT '$EXPR) ,(PARSE '$EXPR 80.)))
|
||||
|
||||
(DEFPROP $NOT NUD-$NOT NUD)
|
||||
(DEFUN NUD-$NOT (OP) OP ;Ignored
|
||||
`($CLAUSE (MNOT) ,(PARSE '$CLAUSE 70.)))
|
||||
|
||||
|
||||
(DEFPROP $AND LED-$AND LED)
|
||||
(DEFPROP $AND 60. LBP)
|
||||
|
||||
(DEFUN LED-$AND (OP LEFT) OP ;Ignored
|
||||
`($CLAUSE (MAND) ,(CONVERT LEFT '$CLAUSE) . ,(PRSNARY '$AND '$CLAUSE 60.)))
|
||||
|
||||
(DEFPROP $OR LED-$OR LED)
|
||||
(DEFPROP $OR 50. LBP)
|
||||
|
||||
(DEFUN LED-$OR (OP LEFT) OP ;Ignored
|
||||
`($CLAUSE (MOR) ,(CONVERT LEFT '$CLAUSE) . ,(PRSNARY '$OR '$CLAUSE 50.)))
|
||||
|
||||
(DEFPROP $/, LED-$/, LED)
|
||||
(DEFPROP $/, 10. LBP)
|
||||
|
||||
(DEFUN LED-$/, (OP LEFT) OP ;Ignored
|
||||
`($ANY ($EV) ,(CDR LEFT) . ,(PRSNARY '$/, '$ANY 10.)))
|
||||
|
||||
(DEFPROP $IF NUD-$IF NUD)
|
||||
(DEFPROP $THEN DELIM-ERR NUD)
|
||||
(DEFPROP $THEN 5. LBP)
|
||||
(DEFPROP $ELSE DELIM-ERR NUD)
|
||||
(DEFPROP $ELSE 5. LBP)
|
||||
|
||||
(DEFUN NUD-$IF (OP) OP ;Ignored
|
||||
(LIST '$ANY '(MCOND)
|
||||
(PARSE '$CLAUSE 45.)
|
||||
(COND ((EQ '$THEN (FIRST-C)) (POP-C) (PARSE '$ANY 25.))
|
||||
(T (TERPRI) (PRINC '|Missing "THEN"|) (PRSYNERR)))
|
||||
T
|
||||
(COND ((EQ '$ELSE (FIRST-C)) (POP-C) (PARSE '$ANY 25.)) (T '$FALSE))))
|
||||
|
||||
(DEFPROP $FOR NUD-$DO NUD)
|
||||
(DEFPROP $FOR 5. LBP)
|
||||
|
||||
(DEFPROP $FROM NUD-$DO NUD)
|
||||
(DEFPROP $FROM 5. LBP)
|
||||
|
||||
(DEFPROP $STEP NUD-$DO NUD)
|
||||
(DEFPROP $STEP 5. LBP)
|
||||
|
||||
(DEFPROP $NEXT NUD-$DO NUD)
|
||||
(DEFPROP $NEXT 5. LBP)
|
||||
|
||||
(DEFPROP $THRU NUD-$DO NUD)
|
||||
(DEFPROP $THRU 5. LBP)
|
||||
|
||||
(DEFPROP $UNLESS NUD-$DO NUD)
|
||||
(DEFPROP $UNLESS 5. LBP)
|
||||
|
||||
(DEFPROP $WHILE NUD-$DO NUD)
|
||||
(DEFPROP $WHILE 5. LBP)
|
||||
|
||||
(DEFPROP $DO NUD-$DO NUD)
|
||||
(DEFPROP $DO 5. LBP)
|
||||
|
||||
(DEFUN NUD-$DO (LEX)
|
||||
(DO ((OP LEX (POP-C)) (LEFT (MAKE-MDO)))
|
||||
((EQ '$DO OP) (SETF (MDO-BODY LEFT) (PARSE '$ANY 25.))
|
||||
(CONS '$ANY LEFT))
|
||||
(COND ((AND (EQ '$FOR OP) (NULL (MDO-FOR LEFT)))
|
||||
(SETF (MDO-FOR LEFT) (PARSE '$ANY 200.)))
|
||||
((AND (OR (EQ '$FROM OP) (EQ '$/: OP))
|
||||
(NULL (MDO-FROM LEFT))
|
||||
(EQ 'MDO (MDO-OP LEFT)))
|
||||
(SETF (MDO-FROM LEFT) (PARSE '$ANY 95.)))
|
||||
((AND (EQ '$IN OP) (NULL (MDO-STEP LEFT)) (NULL (MDO-NEXT LEFT)))
|
||||
(SETF (MDO-OP LEFT) 'MDOIN)
|
||||
(SETF (MDO-FROM LEFT) (PARSE '$ANY 95.)))
|
||||
((AND (EQ '$STEP OP) (NULL (MDO-STEP LEFT)) (NULL (MDO-NEXT LEFT))
|
||||
(EQ 'MDO (MDO-OP LEFT)))
|
||||
(SETF (MDO-STEP LEFT) (PARSE '$EXPR 95.)))
|
||||
((AND (EQ '$NEXT OP) (NULL (MDO-NEXT LEFT)) (NULL (MDO-STEP LEFT))
|
||||
(EQ 'MDO (MDO-OP LEFT)))
|
||||
(SETF (MDO-NEXT LEFT) (PARSE '$ANY 45.)))
|
||||
((AND (EQ '$THRU OP) (NULL (MDO-THRU LEFT)))
|
||||
(SETF (MDO-THRU LEFT) (PARSE '$EXPR 95.)))
|
||||
((EQ '$WHILE OP)
|
||||
(SETF (MDO-UNLESS LEFT)
|
||||
(COND ((NULL (MDO-UNLESS LEFT)) (LIST '(MNOT) (PARSE '$CLAUSE 45.)))
|
||||
(T (LIST '(MOR) (MDO-UNLESS LEFT)
|
||||
(LIST '(MNOT) (PARSE '$CLAUSE 45.)))))))
|
||||
((EQ '$UNLESS OP)
|
||||
(SETF (MDO-UNLESS LEFT)
|
||||
(COND ((NULL (MDO-UNLESS LEFT)) (PARSE '$CLAUSE 45.))
|
||||
(T (LIST '(MOR) (MDO-UNLESS LEFT) (PARSE '$CLAUSE 45.))))))
|
||||
(T (PARSE-ERR)))))
|
||||
|
||||
|
||||
(DEFPROP |$;| |NUD-$;| NUD)
|
||||
(DEFPROP |$;| |LED-$;| LED)
|
||||
(DEFPROP |$;| -1 LBP)
|
||||
|
||||
(DEFUN |NUD-$;| (OP) OP ;Ignored
|
||||
(MTELL-OPEN "Premature termination of input.")
|
||||
(PRSYNERR))
|
||||
|
||||
(DEFUN |LED-$;| (OP LEFT) OP ;Ignored
|
||||
(CDR LEFT))
|
||||
|
||||
|
||||
;; Local Modes:
|
||||
;; Mode: LISP
|
||||
;; Comment Col: 40
|
||||
;; END:
|
||||
|
||||
427
src/mrg/grind.153
Normal file
427
src/mrg/grind.153
Normal file
@@ -0,0 +1,427 @@
|
||||
;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;;
|
||||
;;; (c) Copyright 1976, 1983 Massachusetts Institute of Technology ;;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(macsyma-module grind)
|
||||
|
||||
(DECLARE (GENPREFIX GRI)
|
||||
(SPECIAL LOP ROP STRING CHRPS $ALIASES ALIASLIST LINEL)
|
||||
(FIXNUM (CHRCT*))
|
||||
(*EXPR LBP RBP))
|
||||
|
||||
(DEFUN CHRCT* () (- LINEL CHRPS))
|
||||
|
||||
(DEFVAR ALPHABET '(#/% #/_))
|
||||
(DEFVAR FORTRANP NIL)
|
||||
|
||||
(DEFMSPEC $GRIND (X) (SETQ X (CDR X))
|
||||
(LET (Y)
|
||||
(IF (NOT (ZEROP (CHARPOS T))) (MTERPRI))
|
||||
(COND ((OR (NULL X) (CDR X)) (WNA-ERR '$GRIND))
|
||||
((SYMBOLP (SETQ X (STRMEVAL (CAR X))))
|
||||
(SETQ X ($VERBIFY X))
|
||||
(COND ((SETQ Y (MGET X 'MEXPR))
|
||||
(MGRIND (LIST '(MDEFINE) (CONS (LIST X) (CDADR Y)) (CADDR Y)) NIL))
|
||||
((SETQ Y (MGET X 'MMACRO))
|
||||
(MGRIND (LIST '(MDEFMACRO) (CONS (LIST X) (CDADR Y)) (CADDR Y)) NIL))
|
||||
((SETQ Y (MGET X 'AEXPR))
|
||||
(MGRIND (LIST '(MDEFINE) (CONS (LIST X 'ARRAY) (CDADR Y)) (CADDR Y)) NIL))
|
||||
(T (MGRIND X NIL)))
|
||||
(TYO #/$ NIL))
|
||||
(T (MGRIND X NIL) (TYO #/$ NIL)))
|
||||
'$DONE))
|
||||
|
||||
(DEFUN MGRIND (X OUT)
|
||||
(SETQ CHRPS 0)
|
||||
(MPRINT (MSIZE X NIL NIL 'MPAREN 'MPAREN) OUT))
|
||||
|
||||
(DEFUN MPRINT (X OUT)
|
||||
(COND ((FIXP X) (SETQ CHRPS (1+ CHRPS)) (TYO X OUT))
|
||||
((< (CAR X) (CHRCT*)) (MAPC #'(LAMBDA (L) (MPRINT L OUT)) (CDR X)))
|
||||
(T (PROG (I) (SETQ I CHRPS)
|
||||
(MPRINT (CADR X) OUT)
|
||||
(COND ((NULL (CDDR X)) (RETURN NIL))
|
||||
((AND (OR (ATOM (CADR X)) (< (CAADR X) (CHRCT*)))
|
||||
(OR (> (CHRCT*) (// LINEL 2))
|
||||
(ATOM (CADDR X)) (< (CAADDR X) (CHRCT*))))
|
||||
(SETQ I CHRPS)
|
||||
(MPRINT (CADDR X) OUT))
|
||||
(T (SETQ I (1+ I)) (SETQ CHRPS 0) (TERPRI OUT)
|
||||
(MTYOTBSP I OUT) (MPRINT (CADDR X) OUT)))
|
||||
(DO L (CDDDR X) (CDR L) (NULL L)
|
||||
(IF (OR (ATOM (CAR L)) (< (CAAR L) (CHRCT*))) NIL
|
||||
(SETQ CHRPS 0) (TERPRI OUT) (MTYOTBSP I OUT))
|
||||
(MPRINT (CAR L) OUT))))))
|
||||
|
||||
(DEFUN MTYOTBSP (N OUT) (DECLARE (FIXNUM N))
|
||||
(SETQ CHRPS (+ N CHRPS))
|
||||
(DO () ((< N 8)) (TYO #\TAB OUT) (SETQ N (- N 8)))
|
||||
(DO () ((< N 1)) (TYO #\SP OUT) (SETQ N (1- N))))
|
||||
|
||||
(DEFUN STRGRIND (X)
|
||||
(LET (STRING (CHRPS 0))
|
||||
(STRPRINT (MSIZE X NIL NIL 'MPAREN 'MPAREN))
|
||||
(NREVERSE STRING)))
|
||||
|
||||
(DEFUN STRPRINT (X)
|
||||
(COND ((ATOM X) (STYO X))
|
||||
((< (CAR X) (CHRCT*)) (MAPC #'STRPRINT (CDR X)))
|
||||
(T (PROG (I)
|
||||
(SETQ I CHRPS)
|
||||
(STRPRINT (CADR X))
|
||||
(COND ((NULL (CDDR X)) (RETURN NIL))
|
||||
((AND (OR (ATOM (CADR X)) (< (CAADR X) (CHRCT*)))
|
||||
(OR (> (CHRCT*) (// LINEL 2))
|
||||
(ATOM (CADDR X)) (< (CAADDR X) (CHRCT*))))
|
||||
(SETQ I CHRPS)
|
||||
(STRPRINT (CADDR X)))
|
||||
(T (SETQ I (1+ I)) (SETQ CHRPS 0) (STERPRI)
|
||||
(STYOTBSP I) (STRPRINT (CADDR X))))
|
||||
(DO L (CDDDR X) (CDR L) (NULL L)
|
||||
(IF (OR (ATOM (CAR L)) (< (CAAR L) (CHRCT*))) NIL
|
||||
(SETQ CHRPS 0) (STERPRI) (STYOTBSP I))
|
||||
(STRPRINT (CAR L)))))))
|
||||
|
||||
(DEFUN STYO (X) (SETQ STRING (CONS X STRING) CHRPS (1+ CHRPS)))
|
||||
|
||||
(DEFUN STERPRI () (SETQ STRING (CONS #\NEWLINE STRING) CHRPS 0))
|
||||
|
||||
(DEFUN STYOTBSP (N) (DECLARE (FIXNUM N)) (SETQ CHRPS N)
|
||||
(DO () ((< N 8)) (SETQ STRING (CONS #\TAB STRING) N (- N 8)))
|
||||
(DO () ((< N 1)) (SETQ STRING (CONS #\SP STRING) N (1- N))))
|
||||
|
||||
(DEFMFUN MSTRING (X)
|
||||
(NREVERSE (STRING1 (MSIZE X NIL NIL 'MPAREN 'MPAREN) NIL)))
|
||||
|
||||
(DEFUN STRING1 (X L)
|
||||
(IF (ATOM X) (CONS X L)
|
||||
(SETQ X (CDR X))
|
||||
(DO () ((NULL X) L) (SETQ L (STRING1 (CAR X) L) X (CDR X)))))
|
||||
|
||||
(DEFUN MSIZE (X L R LOP ROP)
|
||||
(SETQ X (NFORMAT X))
|
||||
(COND ((ATOM X) (IF FORTRANP (MSZ (MAKESTRING X) L R) (MSIZE-ATOM X L R)))
|
||||
((OR (<= (LBP (CAAR X)) (RBP LOP)) (> (LBP ROP) (RBP (CAAR X))))
|
||||
(MSIZE-PAREN X L R))
|
||||
((MEMQ 'ARRAY (CDAR X)) (MSIZE-ARRAY X L R))
|
||||
((GET (CAAR X) 'GRIND) (FUNCALL (GET (CAAR X) 'GRIND) X L R))
|
||||
(T (MSIZE-FUNCTION X L R NIL))))
|
||||
|
||||
(DEFUN MSIZE-ATOM (X L R)
|
||||
(PROG (Y)
|
||||
(COND ((NUMBERP X) (SETQ Y (EXPLODEN X)))
|
||||
((AND (SETQ Y (GET X 'REVERSEALIAS))
|
||||
(NOT (AND (MEMQ X $ALIASES) (GET X 'NOUN))))
|
||||
(SETQ Y (EXPLODEN Y)))
|
||||
((SETQ Y (ASSQR X ALIASLIST)) (RETURN (MSIZE (CAR Y) L R LOP ROP)))
|
||||
((NULL (SETQ Y (IF (EQ '%DERIVATIVE X)
|
||||
(COPY-TOP-LEVEL '(#/% #/D #/I #/F #/F))
|
||||
(EXPLODEN X)))))
|
||||
((= #/$ (CAR Y)) (SETQ Y (SLASH (CDR Y))))
|
||||
((= #/% (CAR Y)) (SETQ Y (SLASH (CDR Y))))
|
||||
((= #/& (CAR Y))
|
||||
(DO L (CDR Y) (CDR L) (NULL L)
|
||||
(COND ((OR (MEMBER (CAR L) '(#/" #/\ #/; #/$))
|
||||
(AND (< (CAR L) 32.) (NOT (= (CAR L) 13.))))
|
||||
(RPLACD L (CONS (CAR L) (CDR L)))
|
||||
(RPLACA L #/\) (SETQ L (CDR L)))))
|
||||
(SETQ Y (CONS #/" (NCONC (CDR Y) (LIST #/")))))
|
||||
(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 SLASH (X)
|
||||
(DO L (CDR X) (CDR L) (NULL L)
|
||||
(IF (ALPHANUMP (CAR L)) NIL
|
||||
(RPLACD L (CONS (CAR L) (CDR L)))
|
||||
(RPLACA L #/\) (SETQ L (CDR L))))
|
||||
(IF (ALPHABETP (CAR X)) X (CONS #/\ X)))
|
||||
|
||||
(DEFUN ALPHANUMP (N) (DECLARE (FIXNUM N))
|
||||
(OR (ASCII-NUMBERP N) (ALPHABETP N)))
|
||||
|
||||
(DEFUN MSIZE-PAREN (X L R) (MSIZE X (CONS #/( L) (CONS #/) R) 'MPAREN 'MPAREN))
|
||||
|
||||
;; The variables LB and RB are not uses here syntactically, but for
|
||||
;; communication. The FORTRAN program rebinds them to #/( and #/) since
|
||||
;; Fortran array references are printed with parens instead of brackets.
|
||||
|
||||
(DEFVAR LB #/[)
|
||||
(DEFVAR RB #/])
|
||||
|
||||
(DEFUN MSIZE-ARRAY (X L R &AUX F)
|
||||
(IF (EQ 'MQAPPLY (CAAR X)) (SETQ F (CADR X) X (CDR X)) (SETQ F (CAAR X)))
|
||||
(COND ((AND (GET (CAAR X) 'VERB) (GET (CAAR X) 'ALIAS))
|
||||
(SETQ L (RECONC '(#/' #/') L)))
|
||||
((AND (GET (CAAR X) 'NOUN) (NOT (MEMQ (CAAR X) (CDR $ALIASES)))
|
||||
(NOT (GET (CAAR X) 'REVERSEALIAS)))
|
||||
(SETQ L (CONS #/' L))))
|
||||
(SETQ L (MSIZE F L (LIST LB) LOP 'MFUNCTION)
|
||||
R (MSIZE-LIST (CDR X) NIL (CONS RB R)))
|
||||
(CONS (+ (CAR L) (CAR R)) (CONS L (CDR R))))
|
||||
|
||||
(DEFUN MSIZE-FUNCTION (X L R OP)
|
||||
(COND ((AND (GET (CAAR X) 'VERB) (GET (CAAR X) 'ALIAS))
|
||||
(SETQ L (RECONC '(#/' #/') L)))
|
||||
((AND (GET (CAAR X) 'NOUN) (NOT (MEMQ (CAAR X) (CDR $ALIASES)))
|
||||
(NOT (GET (CAAR X) 'REVERSEALIAS)))
|
||||
(SETQ L (CONS #/' L))))
|
||||
(SETQ L (MSIZE (IF OP (GETOP (CAAR X)) (CAAR X)) L (NCONS #/( ) '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)
|
||||
(DECLARE (FIXNUM W))
|
||||
(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)))
|
||||
(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) (RECONC (STRSYM (CAAR X)) L) R (CAAR X) ROP))
|
||||
|
||||
(DEFUN MSIZE-INFIX (X L R)
|
||||
(IF (OR (NULL (CDDR X)) (CDDDR X)) (WNA-ERR (CAAR X)))
|
||||
(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-NARY (X L R) (MSZNARY X L R (STRSYM (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 MSZNARY (X L R DISSYM)
|
||||
(DECLARE (FIXNUM W))
|
||||
(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 DISSYM) R (CAAR X) ROP))
|
||||
(CONS (+ (CAR R) W) (NREVERSE (CONS R NL))))
|
||||
(SETQ NL (CONS (MSIZE (CAR OL) (REVERSE DISSYM) NIL (CAAR X) (CAAR X))
|
||||
NL)
|
||||
W (+ (CAAR NL) W))))))
|
||||
|
||||
(DEFUN STRSYM (X) (OR (GET X 'STRSYM) (GET X 'DISSYM)))
|
||||
|
||||
(DEFPROP BIGFLOAT MSZ-BIGFLOAT GRIND)
|
||||
|
||||
(DEFUN MSZ-BIGFLOAT (X L R)
|
||||
(MSZ (MAPCAR '(LAMBDA (L) (GETCHARN L 1)) (FPFORMAT X)) L R))
|
||||
|
||||
(DEFPROP MPROGN MSIZE-MATCHFIX GRIND)
|
||||
(DEFPROP MLIST MSIZE-MATCHFIX GRIND)
|
||||
|
||||
(DEFPROP MQAPPLY MSZ-MQAPPLY GRIND)
|
||||
|
||||
(DEFUN MSZ-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 MQUOTE 201. RBP)
|
||||
|
||||
(DEFPROP MSETQ MSIZE-INFIX GRIND)
|
||||
(DEFPROP MSETQ (#/:) STRSYM)
|
||||
(DEFPROP MSETQ 180. RBP)
|
||||
(DEFPROP MSETQ 20. RBP)
|
||||
|
||||
(DEFPROP MSET MSIZE-INFIX GRIND)
|
||||
(DEFPROP MSET (#/: #/:) STRSYM)
|
||||
(DEFPROP MSET 180. LBP)
|
||||
(DEFPROP MSET 20. RBP)
|
||||
|
||||
(DEFPROP MDEFINE MSZ-MDEF GRIND)
|
||||
(DEFPROP MDEFINE (#/: #/=) STRSYM)
|
||||
(DEFPROP MDEFINE 180. LBP)
|
||||
(DEFPROP MDEFINE 20. RBP)
|
||||
|
||||
(DEFPROP MDEFMACRO MSZ-MDEF GRIND)
|
||||
(DEFPROP MDEFMACRO (#/: #/: #/=) STRSYM)
|
||||
(DEFPROP MDEFMACRO 180. LBP)
|
||||
(DEFPROP MDEFMACRO 20. RBP)
|
||||
|
||||
(DEFUN MSZ-MDEF (X L R)
|
||||
(SETQ L (MSIZE (CADR X) L (COPY-TOP-LEVEL (STRSYM (CAAR X))) LOP (CAAR X))
|
||||
R (MSIZE (CADDR X) NIL R (CAAR X) ROP))
|
||||
(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)))))
|
||||
|
||||
|
||||
(DEFPROP MFACTORIAL MSIZE-POSTFIX GRIND)
|
||||
(DEFPROP MFACTORIAL 160. LBP)
|
||||
|
||||
(DEFPROP MEXPT MSZ-MEXPT GRIND)
|
||||
(DEFPROP MEXPT 140. LBP)
|
||||
(DEFPROP MEXPT 139. RBP)
|
||||
|
||||
(DEFUN MSZ-MEXPT (X L R)
|
||||
(SETQ L (MSIZE (CADR X) L NIL LOP 'MEXPT)
|
||||
R (IF (MMMINUSP (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 135. LBP)
|
||||
(DEFPROP MNCEXPT 134. RBP)
|
||||
|
||||
(DEFPROP MNCTIMES MSIZE-NARY GRIND)
|
||||
(DEFPROP MNCTIMES 110. LBP)
|
||||
(DEFPROP MNCTIMES 109. RBP)
|
||||
|
||||
(DEFPROP MTIMES MSZ-MTIMES GRIND)
|
||||
(DEFPROP MTIMES 120. LBP)
|
||||
(DEFPROP MTIMES 120. RBP)
|
||||
|
||||
(DEFUN MSZ-MTIMES (X L R) (MSZNARY X L R '(#/*)))
|
||||
|
||||
|
||||
(DEFPROP MQUOTIENT MSIZE-INFIX GRIND)
|
||||
(DEFPROP MQUOTIENT 120. LBP)
|
||||
(DEFPROP MQUOTIENT 121. RBP)
|
||||
(DEFPROP RAT MSIZE-INFIX GRIND)
|
||||
(DEFPROP RAT 120. LBP)
|
||||
(DEFPROP RAT 121. RBP)
|
||||
|
||||
(DEFPROP MPLUS MSZ-MPLUS GRIND)
|
||||
(DEFPROP MPLUS 100. LBP)
|
||||
(DEFPROP MPLUS 100. RBP)
|
||||
|
||||
(DEFUN MSZ-MPLUS (X L R)
|
||||
(DECLARE (FIXNUM W))
|
||||
(COND ((NULL (CDDR X))
|
||||
(IF (NULL (CDR X))
|
||||
(MSIZE-FUNCTION X L R T)
|
||||
(MSIZE (CADR X) (APPEND (NCONS #/+) 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 (MMMINUSP (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))))
|
||||
(IF (MMMINUSP (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-PREFIX GRIND)
|
||||
(DEFPROP MMINUS (#/-) STRSYM)
|
||||
(DEFPROP MMINUS 100. RBP)
|
||||
(DEFPROP MMINUS 100. LBP)
|
||||
|
||||
(DEFPROP MEQUAL MSIZE-INFIX GRIND)
|
||||
(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 60. LBP)
|
||||
(DEFPROP MAND 60. RBP)
|
||||
|
||||
(DEFPROP MOR MSIZE-NARY GRIND)
|
||||
(DEFPROP MOR 50. LBP)
|
||||
(DEFPROP MOR 50. RBP)
|
||||
|
||||
(DEFPROP MCOND MSZ-MCOND GRIND)
|
||||
(DEFPROP MCOND 25. LBP)
|
||||
(DEFPROP MCOND 25. RBP)
|
||||
|
||||
(DEFUN MSZ-MCOND (X L R &AUX IF)
|
||||
(SETQ IF (NRECONC L '(#/I #/F #\SP)) IF (CONS (LENGTH IF) IF)
|
||||
L (MSIZE (CADR X) NIL NIL 'MCOND 'MPAREN))
|
||||
(COND ((EQ '$FALSE (FIFTH X))
|
||||
(SETQ X (MSIZE (CADDR X)
|
||||
(REVERSE '(#\SP #/T #/H #/E #/N #\SP))
|
||||
R 'MCOND ROP))
|
||||
(LIST (+ (CAR IF) (CAR L) (CAR X)) IF L X))
|
||||
(T (SETQ R (MSIZE (FIFTH X)
|
||||
(REVERSE '(#\SP #/E #/L #/S #/E #\SP))
|
||||
R 'MCOND ROP)
|
||||
X (MSIZE (CADDR X)
|
||||
(REVERSE '(#\SP #/T #/H #/E #/N #\SP))
|
||||
NIL 'MCOND 'MPAREN))
|
||||
(LIST (+ (CAR IF) (CAR L) (CAR X) (CAR R)) IF L X R))))
|
||||
|
||||
|
||||
(DEFPROP MDO MSZ-MDO GRIND)
|
||||
(DEFPROP MDO 30. LBP)
|
||||
(DEFPROP MDO 30. RBP)
|
||||
(DEFPROP MDOIN MSZ-MDOIN GRIND)
|
||||
(DEFPROP MDOIN 30. RBP)
|
||||
|
||||
(DEFUN MSZ-MDO (X L R)
|
||||
(MSZNARY (CONS '(MDO) (STRMDO X)) L R '(#\SP)))
|
||||
|
||||
(DEFUN MSZ-MDOIN (X L R)
|
||||
(MSZNARY (CONS '(MDO) (STRMDOIN X)) L R '(#\SP)))
|
||||
|
||||
(DEFUN STRMDO (X)
|
||||
(NCONC (COND ((SECOND X) `($FOR ,(SECOND X))))
|
||||
(COND ((EQUAL 1 (THIRD X)) NIL)
|
||||
((THIRD X) `($FROM ,(THIRD X))))
|
||||
(COND ((EQUAL 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)
|
||||
((EQ 'MNOT (CAAR (SEVENTH X)))
|
||||
`($WHILE ,(CADR (SEVENTH X))))
|
||||
(T `($UNLESS ,(SEVENTH X))))
|
||||
`($DO ,(EIGHTH X))))
|
||||
|
||||
(DEFUN STRMDOIN (X)
|
||||
(NCONC `($FOR ,(SECOND X) $IN ,(THIRD X))
|
||||
(COND ((SIXTH X) `($THRU ,(SIXTH X))))
|
||||
(COND ((NULL (SEVENTH X)) NIL)
|
||||
((EQ 'MNOT (CAAR (SEVENTH X)))
|
||||
`($WHILE ,(CADR (SEVENTH X))))
|
||||
(T `($UNLESS ,(SEVENTH X))))
|
||||
`($DO ,(EIGHTH X))))
|
||||
|
||||
|
||||
118
src/mrg/nforma.18
Normal file
118
src/mrg/nforma.18
Normal file
@@ -0,0 +1,118 @@
|
||||
;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;;
|
||||
;;; (c) Copyright 1982 Massachusetts Institute of Technology ;;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(macsyma-module nforma)
|
||||
|
||||
(DECLARE (SPECIAL 1//2 -1//2 DISPLAYP ALIASLIST IN-P))
|
||||
|
||||
(DEFMVAR $POWERDISP NIL)
|
||||
(DEFMVAR $PFEFORMAT NIL)
|
||||
(DEFMVAR $%EDISPFLAG NIL)
|
||||
(DEFMVAR $EXPTDISPFLAG T)
|
||||
(DEFMVAR $SQRTDISPFLAG T)
|
||||
(DEFMVAR $NEGSUMDISPFLAG T)
|
||||
(SETQ IN-P NIL)
|
||||
|
||||
(DEFMFUN NFORMAT (FORM)
|
||||
(COND ((ATOM FORM)
|
||||
(COND ((AND (NUMBERP FORM) (MINUSP FORM)) (LIST '(MMINUS) (MINUS FORM)))
|
||||
((EQ T FORM) (IF IN-P T '$TRUE))
|
||||
((EQ NIL FORM) (IF IN-P NIL '$FALSE))
|
||||
((AND DISPLAYP (CAR (ASSQR FORM ALIASLIST))))
|
||||
(T FORM)))
|
||||
((ATOM (CAR FORM)) FORM)
|
||||
((EQ 'RAT (CAAR FORM))
|
||||
(COND ((MINUSP (CADR FORM))
|
||||
(LIST '(MMINUS) (LIST '(RAT) (MINUS (CADR FORM)) (CADDR FORM))))
|
||||
(T (CONS '(RAT) (CDR FORM)))))
|
||||
((EQ 'MMACROEXPANDED (CAAR FORM)) (NFORMAT (CADDR FORM)))
|
||||
((NULL (CDAR FORM)) FORM)
|
||||
((EQ 'MPLUS (CAAR FORM)) (FORM-MPLUS FORM))
|
||||
((EQ 'MTIMES (CAAR FORM)) (FORM-MTIMES FORM))
|
||||
((EQ 'MEXPT (CAAR FORM)) (FORM-MEXPT FORM))
|
||||
((EQ 'MRAT (CAAR FORM)) (FORM-MRAT FORM))
|
||||
((EQ 'MPOIS (CAAR FORM)) (NFORMAT ($OUTOFPOIS FORM)))
|
||||
((EQ 'BIGFLOAT (CAAR FORM))
|
||||
(IF (MINUSP (CADR FORM))
|
||||
(LIST '(MMINUS) (LIST (CAR FORM) (MINUS (CADR FORM)) (CADDR FORM)))
|
||||
(CONS (CAR FORM) (CDR FORM))))
|
||||
(T FORM)))
|
||||
|
||||
(DEFUN FORM-MPLUS (FORM &AUX ARGS TRUNC)
|
||||
(SETQ ARGS (MAPCAR #'NFORMAT (CDR FORM)))
|
||||
(SETQ TRUNC (MEMQ 'TRUNC (CDAR FORM)))
|
||||
(CONS (IF TRUNC '(MPLUS TRUNC) '(MPLUS))
|
||||
(COND ((AND (MEMQ 'RATSIMP (CDAR FORM)) (NOT (MEMQ 'SIMP (CDAR FORM))))
|
||||
(IF $POWERDISP (NREVERSE ARGS) ARGS))
|
||||
((AND TRUNC (NOT (MEMQ 'SIMP (CDAR FORM)))) (NREVERSE ARGS))
|
||||
((OR $POWERDISP TRUNC (MEMQ 'CF (CDAR FORM))) ARGS)
|
||||
((AND $NEGSUMDISPFLAG (NULL (CDDDR FORM)))
|
||||
(IF (AND (NOT (MMMINUSP (CAR ARGS)))
|
||||
(MMMINUSP (CADR ARGS)))
|
||||
ARGS
|
||||
(NREVERSE ARGS)))
|
||||
(T (NREVERSE ARGS)))))
|
||||
|
||||
(DEFUN FORM-MTIMES (FORM)
|
||||
(COND ((NULL (CDR FORM)) '((MTIMES)))
|
||||
((EQUAL -1 (CADR FORM)) (LIST '(MMINUS) (FORM-MTIMES (CDR FORM))))
|
||||
(T (PROG (NUM DEN MINUS FLAG)
|
||||
(DO ((L (CDR FORM) (CDR L)) (DUMMY)) ((NULL L))
|
||||
(SETQ DUMMY (NFORMAT (CAR L)))
|
||||
(COND ((ATOM DUMMY) (SETQ NUM (CONS DUMMY NUM)))
|
||||
((EQ 'MMINUS (CAAR DUMMY))
|
||||
(SETQ MINUS (NOT MINUS) L (APPEND DUMMY (CDR L))))
|
||||
((OR (EQ 'MQUOTIENT (CAAR DUMMY))
|
||||
(AND (NOT $PFEFORMAT) (EQ 'RAT (CAAR DUMMY))))
|
||||
(COND ((NOT (EQUAL 1 (CADR DUMMY)))
|
||||
(SETQ NUM (CONS (CADR DUMMY) NUM))))
|
||||
(SETQ DEN (CONS (CADDR DUMMY) DEN)))
|
||||
(T (SETQ NUM (CONS DUMMY 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 FORM-MEXPT (FORM &AUX EXP)
|
||||
(COND ((AND $SQRTDISPFLAG (ALIKE1 1//2 (CADDR FORM))) (LIST '(%SQRT) (CADR FORM)))
|
||||
((AND $SQRTDISPFLAG (ALIKE1 -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 EXP (NFORMAT (CADDR FORM)))))
|
||||
(EQ 'MMINUS (CAAR EXP)))
|
||||
(LIST '(MQUOTIENT) 1 (IF (EQUAL 1 (CADR EXP)) (CADR FORM)
|
||||
(LIST '(MEXPT) (CADR FORM) (CADR EXP)))))
|
||||
(T (CONS '(MEXPT) (CDR FORM)))))
|
||||
|
||||
(DEFUN FORM-MRAT (FORM)
|
||||
(LET ((TRUNC (MEMQ 'TRUNC (CDAR FORM))) EXACT)
|
||||
(IF (AND TRUNC (EQ (CADR FORM) 'PS))
|
||||
(SETQ EXACT (NULL (CAR (CADDDR FORM)))))
|
||||
(SETQ FORM (RATDISREPD FORM))
|
||||
(RDIS1 FORM)
|
||||
(IF (AND TRUNC (OR (ATOM FORM)
|
||||
;; A constant, e.g. ((mplus) $a 1)
|
||||
(not (member (car form)
|
||||
'((mplus exact) (mplus trunc))))))
|
||||
(CONS (IF EXACT '(MPLUS EXACT) '(MPLUS TRUNC)) (NCONS FORM))
|
||||
(NFORMAT FORM))))
|
||||
|
||||
(DEFUN RDIS1 (FORM)
|
||||
(COND ((OR (ATOM FORM) (SPECREPP FORM)))
|
||||
((NULL (CDAR FORM)) (RPLACA FORM (LIST (CAAR FORM) 'RATSIMP)))
|
||||
(T (MAPC #'RDIS1 (CDR FORM)))))
|
||||
|
||||
(DEFMFUN NFORMAT-ALL (FORM)
|
||||
(SETQ FORM (NFORMAT FORM))
|
||||
(IF (OR (ATOM FORM) (EQ (CAAR FORM) 'BIGFLOAT))
|
||||
FORM
|
||||
(CONS (DELSIMP (CAR FORM))
|
||||
(IF (MEMQ (CAAR FORM) '(MDO MDOIN))
|
||||
(MAPCAR #'(LAMBDA (U) (IF U (NFORMAT-ALL U))) (CDR FORM))
|
||||
(MAPCAR #'NFORMAT-ALL (CDR FORM))))))
|
||||
146
src/mrg/optim.16
Normal file
146
src/mrg/optim.16
Normal file
@@ -0,0 +1,146 @@
|
||||
;;; -*- Mode:LISP; Package:MACSYMA -*-
|
||||
|
||||
; ** (c) Copyright 1982 Massachusetts Institute of Technology **
|
||||
|
||||
(macsyma-module optim)
|
||||
|
||||
(DECLARE (SPECIAL VARS SETQS OPTIMCOUNT XVARS)
|
||||
(FIXNUM N (OPT-HASH))
|
||||
(ARRAY* (NOTYPE (SUBEXP 1)))
|
||||
(UNSPECIAL ARGS))
|
||||
|
||||
(ARRAY SUBEXP T 64.)
|
||||
|
||||
(DEFMVAR $OPTIMPREFIX '$%)
|
||||
|
||||
(DEFMVAR $OPTIMWARN T "warns if OPTIMIZE encounters a special form.")
|
||||
|
||||
;; $OPTIMIZE takes a Macsyma expression and returns a BLOCK form which is
|
||||
;; equivalent, but which uses local variables to store the results of computing
|
||||
;; common subexpressions. These subexpressions are found by hashing them.
|
||||
|
||||
(DEFMFUN $OPTIMIZE (X0)
|
||||
(LET (($OPTIMWARN $OPTIMWARN))
|
||||
(PROG (VARS SETQS OPTIMCOUNT XVARS X)
|
||||
(SETQ OPTIMCOUNT 0 XVARS (CDR ($LISTOFVARS X0)))
|
||||
(FILLARRAY 'SUBEXP '(NIL))
|
||||
(SETQ X (COLLAPSE (OPFORMAT (COLLAPSE X0))))
|
||||
(IF (ATOM X) (RETURN X))
|
||||
(COMEXP X)
|
||||
(SETQ X (OPTIM X))
|
||||
(RETURN (PROG1 (COND ((NULL VARS) X0)
|
||||
(T (IF (OR (NOT (EQ (CAAR X) 'MPROG))
|
||||
(AND ($LISTP (CADR X)) (CDADR X)))
|
||||
(SETQ X (NREVERSE (CONS X SETQS)))
|
||||
(SETQ X (NCONC (NREVERSE SETQS) (CDDR X))))
|
||||
`((MPROG SIMP) ((MLIST) . ,(NREVERSE VARS)) . ,X)))
|
||||
(FILLARRAY 'SUBEXP '(NIL)))))))
|
||||
|
||||
(DEFUN OPFORMAT (X)
|
||||
(COND ((ATOM X) X)
|
||||
((SPECREPP X) (OPFORMAT (SPECDISREP X)))
|
||||
((AND $OPTIMWARN
|
||||
(MSPECFUNP (CAAR X))
|
||||
(PROG2 (MTELL "OPTIMIZE has met up with a special form - ~
|
||||
answer may be wrong.")
|
||||
(SETQ $OPTIMWARN NIL))))
|
||||
((EQ (CAAR X) 'MEXPT) (OPMEXPT X))
|
||||
(T (LET ((NEWARGS (MAPCAR #'OPFORMAT (CDR X))))
|
||||
(IF (ALIKE NEWARGS (CDR X)) X (CONS (CAR X) NEWARGS))))))
|
||||
|
||||
(DEFUN OPMEXPT (X)
|
||||
(LET ((*BASE (OPFORMAT (CADR X))) (EXP (OPFORMAT (CADDR X))) XNEW NEGEXP)
|
||||
(SETQ NEGEXP
|
||||
(COND ((AND (NUMBERP EXP) (MINUSP EXP)) (MINUS EXP))
|
||||
((AND (RATNUMP EXP) (MINUSP (CADR EXP)))
|
||||
(LIST (CAR EXP) (MINUS (CADR EXP)) (CADDR EXP)))
|
||||
((AND (MTIMESP EXP) (NUMBERP (CADR EXP)) (MINUSP (CADR EXP)))
|
||||
(IF (EQUAL (CADR EXP) -1)
|
||||
(IF (NULL (CDDDR EXP)) (CADDR EXP)
|
||||
(CONS (CAR EXP) (CDDR EXP)))
|
||||
(LIST* (CAR EXP) (MINUS (CADR EXP)) (CDDR EXP))))
|
||||
((AND (MTIMESP EXP) (RATNUMP (CADR EXP)) (MINUSP (CADADR EXP)))
|
||||
(LIST* (CAR EXP)
|
||||
(LIST (CAADR EXP) (MINUS (CADADR EXP)) (CADDR (CADR EXP)))
|
||||
(CDDR EXP)))))
|
||||
(SETQ XNEW
|
||||
(COND (NEGEXP
|
||||
`((MQUOTIENT)
|
||||
1
|
||||
,(COND ((EQUAL NEGEXP 1) *BASE)
|
||||
(T (SETQ XNEW (LIST (CAR X) *BASE NEGEXP))
|
||||
(IF (AND (RATNUMP NEGEXP) (EQUAL (CADDR NEGEXP) 2))
|
||||
(OPMEXPT XNEW)
|
||||
XNEW)))))
|
||||
((AND (RATNUMP EXP) (EQUAL (CADDR EXP) 2))
|
||||
(SETQ EXP (CADR EXP))
|
||||
(IF (EQUAL EXP 1) `((%SQRT) ,*BASE)
|
||||
`((MEXPT) ((%SQRT) ,*BASE) ,EXP)))
|
||||
(T (LIST (CAR X) *BASE EXP))))
|
||||
(IF (ALIKE1 X XNEW) X XNEW)))
|
||||
|
||||
(DEFMFUN $COLLAPSE (X)
|
||||
(FILLARRAY 'SUBEXP '(NIL))
|
||||
(PROG1 (COLLAPSE X) (FILLARRAY 'SUBEXP '(NIL))))
|
||||
|
||||
(DEFUN COLLAPSE (X)
|
||||
(COND ((ATOM X) X)
|
||||
((SPECREPP X) (COLLAPSE (SPECDISREP X)))
|
||||
(T (LET ((N (OPT-HASH (CAAR X))))
|
||||
(DO ((L (CDR X) (CDR L)))
|
||||
((NULL L))
|
||||
(IF (NOT (EQ (COLLAPSE (CAR L)) (CAR L)))
|
||||
(RPLACA L (COLLAPSE (CAR L))))
|
||||
(SETQ N (\ (+ (OPT-HASH (CAR L)) N) 12553.)))
|
||||
(SETQ N (LOGAND 63. N))
|
||||
(DO ((L (SUBEXP N) (CDR L)))
|
||||
((NULL L) (STORE (SUBEXP N) (CONS (LIST X) (SUBEXP N))) X)
|
||||
(IF (ALIKE1 X (CAAR L)) (RETURN (CAAR L))))))))
|
||||
|
||||
(DEFUN COMEXP (X)
|
||||
(IF (NOT (OR (ATOM X) (EQ (CAAR X) 'RAT)))
|
||||
(LET ((N (OPT-HASH (CAAR X))))
|
||||
(DOLIST (U (CDR X)) (SETQ N (\ (+ (OPT-HASH U) N) 12553.)))
|
||||
(SETQ X (ASSOL X (SUBEXP (LOGAND 63. N))))
|
||||
(COND ((NULL (CDR X)) (RPLACD X 'SEEN) (MAPC #'COMEXP (CDAR X)))
|
||||
(T (RPLACD X 'COMEXP))))))
|
||||
|
||||
(DEFUN OPTIM (X)
|
||||
(COND ((ATOM X) X)
|
||||
((AND (MEMQ 'ARRAY (CDAR X))
|
||||
(NOT (EQ (CAAR X) 'MQAPPLY))
|
||||
(NOT (MGET (CAAR X) 'ARRAYFUN-MODE)))
|
||||
X)
|
||||
((EQ (CAAR X) 'RAT) X)
|
||||
(T (LET ((N (OPT-HASH (CAAR X))) (NX (LIST (CAR X))))
|
||||
(DOLIST (U (CDR X))
|
||||
(SETQ N (\ (+ (OPT-HASH U) N) 12553.)
|
||||
NX (CONS (OPTIM U) NX)))
|
||||
(SETQ X (ASSOL X (SUBEXP (LOGAND 63. N))) NX (NREVERSE NX))
|
||||
(COND ((EQ (CDR X) 'SEEN) NX)
|
||||
((EQ (CDR X) 'COMEXP)
|
||||
(RPLACD X (GETOPTIMVAR))
|
||||
(SETQ SETQS (CONS `((MSETQ) ,(CDR X) ,NX) SETQS))
|
||||
(CDR X))
|
||||
(T (CDR X)))))))
|
||||
|
||||
(DEFUN OPT-HASH (EXP) ; EXP is in general representation.
|
||||
(\ (IF (ATOM EXP)
|
||||
(SXHASH EXP)
|
||||
(DO ((N (OPT-HASH (CAAR EXP)))
|
||||
(ARGS (CDR EXP) (CDR ARGS)))
|
||||
((NULL ARGS) N)
|
||||
(SETQ N (\ (+ (OPT-HASH (CAR ARGS)) N) 12553.))))
|
||||
12553.)) ; a prime number < 2^14 ; = PRIME(1500)
|
||||
|
||||
(DEFUN GETOPTIMVAR ()
|
||||
(PROG (VAR)
|
||||
LOOP (INCREMENT OPTIMCOUNT)
|
||||
(SETQ VAR (INTERN #-Lispm (MAKNAM (NCONC (EXPLODEN $OPTIMPREFIX)
|
||||
(MEXPLODEN OPTIMCOUNT)))
|
||||
#+Lispm (MAKE-SYMBOL
|
||||
(FORMAT NIL "~A~D" $OPTIMPREFIX OPTIMCOUNT))))
|
||||
(IF (MEMQ VAR XVARS) (GO LOOP))
|
||||
(SETQ VARS (CONS VAR VARS))
|
||||
(RETURN VAR)))
|
||||
|
||||
55
src/mrg/scs.61
Normal file
55
src/mrg/scs.61
Normal file
@@ -0,0 +1,55 @@
|
||||
;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;;
|
||||
;;; (c) Copyright 1980 Massachusetts Institute of Technology ;;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(macsyma-module scs)
|
||||
|
||||
(DECLARE (*EXPR $RATSUBST CONSSIZE))
|
||||
|
||||
(DEFMFUN $SCSIMP N
|
||||
(DO ((I N (1- I)) (ZRS)) ((= 1 I) (SCS (ARG 1) ZRS))
|
||||
(SETQ ZRS (CONS (IFN (EQ 'MEQUAL (CAAR (ARG I))) (ARG I)
|
||||
(SUB (CADR (ARG I)) (CADDR (ARG I)))) ZRS))))
|
||||
|
||||
(DEFUN SCS (X ZRS)
|
||||
(DO ((FLAG T) (SZ (CONSSIZE X)) (NX) (NSZ)) ((NOT FLAG) X)
|
||||
(DO ((L ZRS (CDR L))) ((NULL L) (SETQ FLAG NIL))
|
||||
(SETQ NX (SUBSCS 0 (CAR L) X) NSZ (CONSSIZE NX))
|
||||
(IF (< NSZ SZ) (RETURN (SETQ X NX SZ NSZ))))))
|
||||
|
||||
(DEFUN SUBSCS (A B C)
|
||||
(COND ((ATOM B) (SUBSC A B C))
|
||||
((EQ 'MPLUS (CAAR B))
|
||||
(DO ((L (CDR B) (CDR L)) (SZ (CONSSIZE C)) (NL) (NC) (NSZ)) ((NULL L) C)
|
||||
(SETQ NC (SUBSCS (SUB A (ADDN (RECONC NL (CDR L)) T)) (CAR L) C)
|
||||
NSZ (CONSSIZE NC) NL (CONS (CAR L) NL))
|
||||
(IF (< NSZ SZ) (SETQ C NC SZ NSZ))))
|
||||
(T (SUBSC A B C))))
|
||||
|
||||
(DEFUN SUBSC (A B C) ($EXPAND ($RATSUBST A B C)))
|
||||
|
||||
(DEFMFUN $DISTRIB (EXP)
|
||||
(COND ((OR (MNUMP EXP) (SYMBOLP EXP)) EXP)
|
||||
((EQ 'MTIMES (CAAR EXP))
|
||||
(SETQ EXP (MAPCAR '$DISTRIB (CDR EXP)))
|
||||
(DO ((L (CDR EXP) (CDR L))
|
||||
(NL (IF (MPLUSP (CAR EXP)) (CDAR EXP) (LIST (CAR EXP)))))
|
||||
((NULL L) (ADDN NL T))
|
||||
(IF (MPLUSP (CAR L))
|
||||
(DO ((M (CDAR L) (CDR M)) (ML)) ((NULL M) (SETQ NL ML))
|
||||
(SETQ ML (DSTRB (CAR M) NL ML)))
|
||||
(SETQ NL (DSTRB (CAR L) NL NIL)))))
|
||||
((EQ 'MEQUAL (CAAR EXP))
|
||||
(LIST '(MEQUAL) ($DISTRIB (CADR EXP)) ($DISTRIB (CADDR EXP))))
|
||||
((EQ 'MRAT (CAAR EXP)) ($DISTRIB (RATDISREP EXP)))
|
||||
(T EXP)))
|
||||
|
||||
(DEFUN DSTRB (X L NL)
|
||||
(DO () ((NULL L) NL)
|
||||
(SETQ NL (CONS (MUL X (CAR L)) NL) L (CDR L))))
|
||||
|
||||
(DEFMFUN $FACOUT (X Y)
|
||||
(IFN (AND (NOT (ATOM Y))
|
||||
(EQ 'MPLUS (CAAR Y))) Y
|
||||
(MUL X (ADDN (MAPCAR #'(LAMBDA (L) (DIV L X)) (CDR Y)) T))))
|
||||
|
||||
636
src/mrg/trigi.358
Normal file
636
src/mrg/trigi.358
Normal file
@@ -0,0 +1,636 @@
|
||||
;; -*- Mode: Lisp; Package: Macsyma; -*-
|
||||
|
||||
;; (c) Copyright 1976, 1984 Massachusetts Institute of Technology
|
||||
;; All Rights Reserved.
|
||||
|
||||
;; Enhancements (c) Copyright 1984 Symbolics Inc.
|
||||
;; All Rights Reserved.
|
||||
|
||||
;; The data and information in the Enhancements are proprietary to, and
|
||||
;; a valuable trade secret of, SYMBOLICS, INC., a Delaware corporation.
|
||||
;; They are given in confidence by SYMBOLICS, pursuant to the license
|
||||
;; agreement between Symbolics and their recipient, and may not be used,
|
||||
;; reproduced, or copied, or distributed to any other party, in whole or
|
||||
;; in part, without the prior written consent of SYMBOLICS except as
|
||||
;; permitted by the license agreement.
|
||||
|
||||
(macsyma-module trigi)
|
||||
|
||||
(LOAD-MACSYMA-MACROS MRGMAC)
|
||||
|
||||
(DECLARE (GENPREFIX TRI)
|
||||
(SPECIAL VARLIST ERRORSW $DEMOIVRE)
|
||||
(FLONUM (TAN) (COT) (SEC) (CSC)
|
||||
(ATAN2) (ATAN1) (ACOT)
|
||||
(SINH) (COSH) (TANH) (COTH) (CSCH) (SECH)
|
||||
(ASINH) (ACSCH)
|
||||
(T//$ FLONUM FLONUM NOTYPE))
|
||||
(*EXPR $BFLOAT TEVAL SIGNUM1 ZEROP1 ISLINEAR EXPAND1
|
||||
TIMESK ADDK INTEGERP EVOD LOGARC
|
||||
MEVENP EQTEST HALFANGLE COEFF))
|
||||
|
||||
(DEFMVAR $%PIARGS T)
|
||||
(DEFMVAR $%IARGS T)
|
||||
(DEFMVAR $TRIGINVERSES '$ALL)
|
||||
(DEFMVAR $TRIGEXPAND NIL)
|
||||
(DEFMVAR $TRIGEXPANDPLUS T)
|
||||
(DEFMVAR $TRIGEXPANDTIMES T)
|
||||
(DEFMVAR $TRIGSIGN T)
|
||||
(DEFMVAR $EXPONENTIALIZE NIL)
|
||||
(DEFMVAR $LOGARC NIL)
|
||||
(DEFMVAR $HALFANGLES NIL)
|
||||
|
||||
(DEFMVAR 1//2 '((RAT SIMP) 1 2))
|
||||
(DEFMVAR -1//2 '((RAT SIMP) -1 2))
|
||||
(DEFMVAR %PI//4 '((MTIMES SIMP) ((RAT SIMP) 1 4.) $%PI))
|
||||
(DEFMVAR %PI//2 '((MTIMES SIMP) ((RAT SIMP) 1 2) $%PI))
|
||||
(DEFMVAR SQRT2//2 '((MTIMES SIMP) ((RAT SIMP) 1 2)
|
||||
((MEXPT SIMP) 2 ((RAT SIMP) 1 2))))
|
||||
(DEFMVAR -SQRT2//2 '((MTIMES SIMP) ((RAT SIMP) -1 2)
|
||||
((MEXPT SIMP) 2 ((RAT SIMP) 1 2))))
|
||||
(DEFMVAR SQRT3//2 '((MTIMES SIMP) ((RAT SIMP) 1 2)
|
||||
((MEXPT SIMP) 3 ((RAT SIMP) 1 2))))
|
||||
(DEFMVAR -SQRT3//2 '((MTIMES SIMP) ((RAT SIMP) -1 2)
|
||||
((MEXPT SIMP) 3 ((RAT SIMP) 1 2))))
|
||||
|
||||
;;; Arithmetic utilities.
|
||||
|
||||
(DEFMFUN SQRT1-X^2 (X) (POWER (SUB 1 (POWER X 2)) 1//2))
|
||||
|
||||
(DEFMFUN SQRT1+X^2 (X) (POWER (ADD 1 (POWER X 2)) 1//2))
|
||||
|
||||
(DEFMFUN SQRTX^2-1 (X) (POWER (ADD (POWER X 2) -1) 1//2))
|
||||
|
||||
(DEFMFUN SQ-SUMSQ (X Y) (POWER (ADD (POWER X 2) (POWER Y 2)) 1//2))
|
||||
|
||||
(DEFMFUN TRIGP (FUNC) (MEMQ FUNC '(%SIN %COS %TAN %CSC %SEC %COT
|
||||
%SINH %COSH %TANH %CSCH %SECH %COTH)))
|
||||
|
||||
(DEFMFUN ARCP (FUNC) (MEMQ FUNC '(%ASIN %ACOS %ATAN %ACSC %ASEC %ACOT
|
||||
%ASINH %ACOSH %ATANH %ACSCH %ASECH %ACOTH)))
|
||||
|
||||
(DEFPROP %SIN SIMP-%SIN OPERATORS)
|
||||
(DEFPROP %COS SIMP-%COS OPERATORS)
|
||||
(DEFPROP %TAN SIMP-%TAN OPERATORS)
|
||||
(DEFPROP %COT SIMP-%COT OPERATORS)
|
||||
(DEFPROP %CSC SIMP-%CSC OPERATORS)
|
||||
(DEFPROP %SEC SIMP-%SEC OPERATORS)
|
||||
(DEFPROP %SINH SIMP-%SINH OPERATORS)
|
||||
(DEFPROP %COSH SIMP-%COSH OPERATORS)
|
||||
(DEFPROP %TANH SIMP-%TANH OPERATORS)
|
||||
(DEFPROP %COTH SIMP-%COTH OPERATORS)
|
||||
(DEFPROP %CSCH SIMP-%CSCH OPERATORS)
|
||||
(DEFPROP %SECH SIMP-%SECH OPERATORS)
|
||||
(DEFPROP %ASIN SIMP-%ASIN OPERATORS)
|
||||
(DEFPROP %ACOS SIMP-%ACOS OPERATORS)
|
||||
(DEFPROP %ATAN SIMP-%ATAN OPERATORS)
|
||||
(DEFPROP %ACOT SIMP-%ACOT OPERATORS)
|
||||
(DEFPROP %ACSC SIMP-%ACSC OPERATORS)
|
||||
(DEFPROP %ASEC SIMP-%ASEC OPERATORS)
|
||||
(DEFPROP %ASINH SIMP-%ASINH OPERATORS)
|
||||
(DEFPROP %ACOSH SIMP-%ACOSH OPERATORS)
|
||||
(DEFPROP %ATANH SIMP-%ATANH OPERATORS)
|
||||
(DEFPROP %ACOTH SIMP-%ACOTH OPERATORS)
|
||||
(DEFPROP %ACSCH SIMP-%ACSCH OPERATORS)
|
||||
(DEFPROP %ASECH SIMP-%ASECH OPERATORS)
|
||||
|
||||
(DEFMFUN SIMP-%SIN (FORM Y Z)
|
||||
(ONEARGCHECK FORM)
|
||||
(SETQ Y (SIMPCHECK (CADR FORM) Z))
|
||||
(COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (SIN Y))
|
||||
(($BFLOATP Y) ($BFLOAT FORM))
|
||||
((AND $%PIARGS (COND ((ZEROP1 Y) 0) ((LINEARP Y '$%PI) (%PIARGS-SIN\COS Y)))))
|
||||
((AND $%IARGS (MULTIPLEP Y '$%I)) (MUL '$%I (CONS-EXP '%SINH (COEFF Y '$%I 1))))
|
||||
((AND $TRIGINVERSES (NOT (ATOM Y))
|
||||
(COND ((EQ '%ASIN (SETQ Z (CAAR Y))) (CADR Y))
|
||||
((EQ '%ACOS Z) (SQRT1-X^2 (CADR Y)))
|
||||
((EQ '%ATAN Z) (DIV (CADR Y) (SQRT1+X^2 (CADR Y))))
|
||||
((EQ '%ACOT Z) (DIV 1 (SQRT1+X^2 (CADR Y))))
|
||||
((EQ '%ASEC Z) (DIV (SQRTX^2-1 (CADR Y)) (CADR Y)))
|
||||
((EQ '%ACSC Z) (DIV 1 (CADR Y)))
|
||||
((EQ '$ATAN2 Z) (DIV (CADR Y) (SQ-SUMSQ (CADR Y) (CADDR Y)))))))
|
||||
((AND $TRIGEXPAND (TRIGEXPAND '%SIN Y)))
|
||||
($EXPONENTIALIZE (EXPONENTIALIZE '%SIN Y))
|
||||
((AND $HALFANGLES (HALFANGLE '%SIN Y)))
|
||||
((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%SIN (NEG Y))))
|
||||
(T (EQTEST (LIST '(%SIN) Y) FORM))))
|
||||
|
||||
(DEFMFUN SIMP-%COS (FORM Y Z)
|
||||
(ONEARGCHECK FORM)
|
||||
(SETQ Y (SIMPCHECK (CADR FORM) Z))
|
||||
(COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (COS Y))
|
||||
(($BFLOATP Y) ($BFLOAT FORM))
|
||||
((AND $%PIARGS (COND ((ZEROP1 Y) 1) ((LINEARP Y '$%PI) (%PIARGS-SIN\COS (ADD %PI//2 Y))))))
|
||||
((AND $%IARGS (MULTIPLEP Y '$%I)) (CONS-EXP '%COSH (COEFF Y '$%I 1)))
|
||||
((AND $TRIGINVERSES (NOT (ATOM Y))
|
||||
(COND ((EQ '%ACOS (SETQ Z (CAAR Y))) (CADR Y))
|
||||
((EQ '%ASIN Z) (SQRT1-X^2 (CADR Y)))
|
||||
((EQ '%ATAN Z) (DIV 1 (SQRT1+X^2 (CADR Y))))
|
||||
((EQ '%ACOT Z) (DIV (CADR Y) (SQRT1+X^2 (CADR Y))))
|
||||
((EQ '%ASEC Z) (DIV 1 (CADR Y)))
|
||||
((EQ '%ACSC Z) (DIV (SQRTX^2-1 (CADR Y)) (CADR Y)))
|
||||
((EQ '$ATAN2 Z) (DIV (CADDR Y) (SQ-SUMSQ (CADR Y) (CADDR Y)))))))
|
||||
((AND $TRIGEXPAND (TRIGEXPAND '%COS Y)))
|
||||
($EXPONENTIALIZE (EXPONENTIALIZE '%COS Y))
|
||||
((AND $HALFANGLES (HALFANGLE '%COS Y)))
|
||||
((AND $TRIGSIGN (MMINUSP* Y)) (CONS-EXP '%COS (NEG Y)))
|
||||
(T (EQTEST (LIST '(%COS) Y) FORM))))
|
||||
|
||||
(DEFUN %PIARGS-SIN\COS (X)
|
||||
(LET ($FLOAT COEFF RATCOEFF REM)
|
||||
(SETQ RATCOEFF (COEFFICIENT X '$%PI 1)
|
||||
COEFF (LINEARIZE RATCOEFF) REM (COEFFICIENT X '$%PI 0))
|
||||
(COND ((ZEROP1 REM) (%PIARGS COEFF RATCOEFF))
|
||||
((NOT (MEVENP (CAR COEFF))) NIL)
|
||||
((EQUAL 0 (SETQ X (MMOD (CDR COEFF) 2))) (CONS-EXP '%SIN REM))
|
||||
((EQUAL 1 X) (NEG (CONS-EXP '%SIN REM)))
|
||||
((ALIKE1 1//2 X) (CONS-EXP '%COS REM))
|
||||
((ALIKE1 '((RAT) 3 2) X) (NEG (CONS-EXP '%COS REM))))))
|
||||
|
||||
(DEFMFUN SIMP-%TAN (FORM Y Z)
|
||||
(ONEARGCHECK FORM)
|
||||
(SETQ Y (SIMPCHECK (CADR FORM) Z))
|
||||
(COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (TAN Y))
|
||||
(($BFLOATP Y) ($BFLOAT FORM))
|
||||
((AND $%PIARGS (COND ((ZEROP1 Y) 0) ((LINEARP Y '$%PI) (%PIARGS-TAN\COT Y)))))
|
||||
((AND $%IARGS (MULTIPLEP Y '$%I)) (MUL '$%I (CONS-EXP '%TANH (COEFF Y '$%I 1))))
|
||||
((AND $TRIGINVERSES (NOT (ATOM Y))
|
||||
(COND ((EQ '%ATAN (SETQ Z (CAAR Y))) (CADR Y))
|
||||
((EQ '%ASIN Z) (DIV (CADR Y) (SQRT1-X^2 (CADR Y))))
|
||||
((EQ '%ACOS Z) (DIV (SQRT1-X^2 (CADR Y)) (CADR Y)))
|
||||
((EQ '%ACOT Z) (DIV 1 (CADR Y)))
|
||||
((EQ '%ASEC Z) (SQRTX^2-1 (CADR Y)))
|
||||
((EQ '%ACSC Z) (DIV 1 (SQRTX^2-1 (CADR Y))))
|
||||
((EQ '$ATAN2 Z) (DIV (CADR Y) (CADDR Y))))))
|
||||
((AND $TRIGEXPAND (TRIGEXPAND '%TAN Y)))
|
||||
($EXPONENTIALIZE (EXPONENTIALIZE '%TAN Y))
|
||||
((AND $HALFANGLES (HALFANGLE '%TAN Y)))
|
||||
((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%TAN (NEG Y))))
|
||||
(T (EQTEST (LIST '(%TAN) Y) FORM))))
|
||||
|
||||
(DEFMFUN SIMP-%COT (FORM Y Z)
|
||||
(ONEARGCHECK FORM)
|
||||
(SETQ Y (SIMPCHECK (CADR FORM) Z))
|
||||
(COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (COT Y))
|
||||
(($BFLOATP Y) ($BFLOAT FORM))
|
||||
((AND $%PIARGS (COND ((ZEROP1 Y) (DBZ-ERR1 'COT))
|
||||
((AND (LINEARP Y '$%PI) (SETQ Z (%PIARGS-TAN\COT (ADD %PI//2 Y)))) (NEG Z)))))
|
||||
((AND $%IARGS (MULTIPLEP Y '$%I)) (MUL -1 '$%I (CONS-EXP '%COTH (COEFF Y '$%I 1))))
|
||||
((AND $TRIGINVERSES (NOT (ATOM Y))
|
||||
(COND ((EQ '%ACOT (SETQ Z (CAAR Y))) (CADR Y))
|
||||
((EQ '%ASIN Z) (DIV (SQRT1-X^2 (CADR Y)) (CADR Y)))
|
||||
((EQ '%ACOS Z) (DIV (CADR Y) (SQRT1-X^2 (CADR Y))))
|
||||
((EQ '%ATAN Z) (DIV 1 (CADR Y)))
|
||||
((EQ '%ASEC Z) (DIV 1 (SQRTX^2-1 (CADR Y))))
|
||||
((EQ '%ACSC Z) (SQRTX^2-1 (CADR Y)))
|
||||
((EQ '$ATAN2 Z) (DIV (CADDR Y) (CADR Y))))))
|
||||
((AND $TRIGEXPAND (TRIGEXPAND '%COT Y)))
|
||||
($EXPONENTIALIZE (EXPONENTIALIZE '%COT Y))
|
||||
((AND $HALFANGLES (HALFANGLE '%COT Y)))
|
||||
((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%COT (NEG Y))))
|
||||
(T (EQTEST (LIST '(%COT) Y) FORM))))
|
||||
|
||||
(DEFUN %PIARGS-TAN\COT (X)
|
||||
(PROG ($FLOAT COEFF REM)
|
||||
(SETQ COEFF (LINEARIZE (COEFFICIENT X '$%PI 1)) REM (COEFFICIENT X '$%PI 0))
|
||||
(RETURN (COND ((AND (ZEROP1 REM)
|
||||
(SETQ REM (%PIARGS COEFF NIL))
|
||||
(SETQ COEFF (%PIARGS (CONS (CAR COEFF) (RPLUS 1//2 (CDR COEFF)))
|
||||
NIL)))
|
||||
(DIV REM COEFF))
|
||||
((NOT (MEVENP (CAR COEFF))) NIL)
|
||||
((FIXP (SETQ X (MMOD (CDR COEFF) 2))) (CONS-EXP '%TAN REM))
|
||||
((OR (ALIKE1 1//2 X) (ALIKE1 '((RAT) 3 2) X)) (NEG (CONS-EXP '%COT REM)))))))
|
||||
|
||||
(DEFMFUN SIMP-%CSC (FORM Y Z)
|
||||
(ONEARGCHECK FORM)
|
||||
(SETQ Y (SIMPCHECK (CADR FORM) Z))
|
||||
(COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (CSC Y))
|
||||
(($BFLOATP Y) ($BFLOAT FORM))
|
||||
((AND $%PIARGS (COND ((ZEROP1 Y) (DBZ-ERR1 'CSC))
|
||||
((LINEARP Y '$%PI) (%PIARGS-CSC\SEC Y)))))
|
||||
((AND $%IARGS (MULTIPLEP Y '$%I)) (MUL -1 '$%I (CONS-EXP '%CSCH (COEFF Y '$%I 1))))
|
||||
((AND $TRIGINVERSES (NOT (ATOM Y))
|
||||
(COND ((EQ '%ACSC (SETQ Z (CAAR Y))) (CADR Y))
|
||||
((EQ '%ASIN Z) (DIV 1 (CADR Y)))
|
||||
((EQ '%ACOS Z) (DIV 1 (SQRT1-X^2 (CADR Y))))
|
||||
((EQ '%ATAN Z) (DIV (SQRT1+X^2 (CADR Y)) (CADR Y)))
|
||||
((EQ '%ACOT Z) (SQRT1+X^2 (CADR Y)))
|
||||
((EQ '%ASEC Z) (DIV (CADR Y) (SQRTX^2-1 (CADR Y))))
|
||||
((EQ '$ATAN2 Z) (DIV (SQ-SUMSQ (CADR Y) (CADDR Y)) (CADR Y))))))
|
||||
((AND $TRIGEXPAND (TRIGEXPAND '%CSC Y)))
|
||||
($EXPONENTIALIZE (EXPONENTIALIZE '%CSC Y))
|
||||
((AND $HALFANGLES (HALFANGLE '%CSC Y)))
|
||||
((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%CSC (NEG Y))))
|
||||
|
||||
(T (EQTEST (LIST '(%CSC) Y) FORM))))
|
||||
|
||||
(DEFMFUN SIMP-%SEC (FORM Y Z)
|
||||
(ONEARGCHECK FORM)
|
||||
(SETQ Y (SIMPCHECK (CADR FORM) Z))
|
||||
(COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (SEC Y))
|
||||
(($BFLOATP Y) ($BFLOAT FORM))
|
||||
((AND $%PIARGS (COND ((ZEROP1 Y) 1) ((LINEARP Y '$%PI) (%PIARGS-CSC\SEC (ADD %PI//2 Y))))))
|
||||
((AND $%IARGS (MULTIPLEP Y '$%I)) (CONS-EXP '%SECH (COEFF Y '$%I 1)))
|
||||
((AND $TRIGINVERSES (NOT (ATOM Y))
|
||||
(COND ((EQ '%ASEC (SETQ Z (CAAR Y))) (CADR Y))
|
||||
((EQ '%ASIN Z) (DIV 1 (SQRT1-X^2 (CADR Y))))
|
||||
((EQ '%ACOS Z) (DIV 1 (CADR Y)))
|
||||
((EQ '%ATAN Z) (SQRT1+X^2 (CADR Y)))
|
||||
((EQ '%ACOT Z) (DIV (SQRT1+X^2 (CADR Y)) (CADR Y)))
|
||||
((EQ '%ACSC Z) (DIV (CADR Y) (SQRTX^2-1 (CADR Y))))
|
||||
((EQ '$ATAN2 Z) (DIV (SQ-SUMSQ (CADR Y) (CADDR Y)) (CADDR Y))))))
|
||||
((AND $TRIGEXPAND (TRIGEXPAND '%SEC Y)))
|
||||
($EXPONENTIALIZE (EXPONENTIALIZE '%SEC Y))
|
||||
((AND $HALFANGLES (HALFANGLE '%SEC Y)))
|
||||
((AND $TRIGSIGN (MMINUSP* Y)) (CONS-EXP '%SEC (NEG Y)))
|
||||
|
||||
(T (EQTEST (LIST '(%SEC) Y) FORM))))
|
||||
|
||||
(DEFUN %PIARGS-CSC\SEC (X)
|
||||
(PROG ($FLOAT COEFF REM)
|
||||
(SETQ COEFF (LINEARIZE (COEFFICIENT X '$%PI 1)) REM (COEFFICIENT X '$%PI 0))
|
||||
(RETURN (COND ((AND (ZEROP1 REM) (SETQ REM (%PIARGS COEFF NIL))) (DIV 1 REM))
|
||||
((NOT (MEVENP (CAR COEFF))) NIL)
|
||||
((EQUAL 0 (SETQ X (MMOD (CDR COEFF) 2))) (CONS-EXP '%CSC REM))
|
||||
((EQUAL 1 X) (NEG (CONS-EXP '%CSC REM)))
|
||||
((ALIKE1 1//2 X) (CONS-EXP '%SEC REM))
|
||||
((ALIKE1 '((RAT) 3 2) X) (NEG (CONS-EXP '%SEC REM)))))))
|
||||
|
||||
(DEFMFUN SIMP-%ATAN (FORM Y Z)
|
||||
(ONEARGCHECK FORM)
|
||||
(SETQ Y (SIMPCHECK (CADR FORM) Z))
|
||||
(COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (ATAN1 Y))
|
||||
(($BFLOATP Y) ($BFLOAT FORM))
|
||||
((AND $%PIARGS
|
||||
(COND ((ZEROP1 Y) 0)
|
||||
((EQUAL Y 1) (SIMPLIFY FOURTH%PI))
|
||||
((EQUAL Y -1) (NEG (SIMPLIFY FOURTH%PI))))))
|
||||
((AND $%IARGS (MULTIPLEP Y '$%I))
|
||||
(MUL '$%I (CONS-EXP '%ATANH (COEFF Y '$%I 1))))
|
||||
((AND (EQ $TRIGINVERSES '$ALL) (NOT (ATOM Y))
|
||||
(COND ((EQ (CAAR Y) '%TAN) (CADR Y))
|
||||
((EQ (CAAR Y) '%COT) (SUB (SIMPLIFY HALF%PI) (CADR Y))))))
|
||||
($LOGARC (LOGARC '%ATAN Y))
|
||||
((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%ATAN (NEG Y))))
|
||||
(T (EQTEST (LIST '(%ATAN) Y) FORM))))
|
||||
|
||||
(DEFUN %PIARGS (X RATCOEFF)
|
||||
(COND ((AND (FIXP (CAR X)) (FIXP (CDR X))) 0)
|
||||
((NOT (MEVENP (CAR X)))
|
||||
(COND ((NULL RATCOEFF) NIL)
|
||||
((ALIKE1 (CDR X) '((RAT) 1 2))
|
||||
(POWER -1 (ADD RATCOEFF -1//2)))))
|
||||
((OR (ALIKE1 '((RAT) 1 6) (SETQ X (MMOD (CDR X) 2))) (ALIKE1 '((RAT) 5 6) X))
|
||||
1//2)
|
||||
((OR (ALIKE1 '((RAT) 1 4) X) (ALIKE1 '((RAT) 3 4) X))
|
||||
(DIV (POWER 2 1//2) 2))
|
||||
((OR (ALIKE1 '((RAT) 1 3) X) (ALIKE1 '((RAT) 2 3) X))
|
||||
(DIV (POWER 3 1//2) 2))
|
||||
((ALIKE1 1//2 X) 1)
|
||||
((OR (ALIKE1 '((RAT) 7 6) X) (ALIKE1 '((RAT) 11 6) X)) -1//2)
|
||||
((OR (ALIKE1 '((RAT) 4 3) X) (ALIKE1 '((RAT) 5 3) X))
|
||||
(DIV (POWER 3 1//2) -2))
|
||||
((OR (ALIKE1 '((RAT) 5 4) X) (ALIKE1 '((RAT) 7 4) X))
|
||||
(MUL -1//2 (POWER 2 1//2)))
|
||||
((ALIKE1 '((RAT) 3 2) X) -1)))
|
||||
|
||||
(DEFUN LINEARIZE (FORM)
|
||||
(COND ((FIXP FORM) (CONS 0 FORM))
|
||||
((NUMBERP FORM) NIL)
|
||||
((ATOM FORM)
|
||||
(LET (DUM)
|
||||
(COND ((SETQ DUM (EVOD FORM))
|
||||
(IF (EQ '$EVEN DUM) '(2 . 0) '(2 . 1)))
|
||||
((INTEGERP FORM) '(1 . 0)))))
|
||||
((EQ 'RAT (CAAR FORM)) (CONS 0 FORM))
|
||||
((EQ 'MPLUS (CAAR FORM)) (LIN-MPLUS FORM))
|
||||
((EQ 'MTIMES (CAAR FORM)) (LIN-MTIMES FORM))
|
||||
((EQ 'MEXPT (CAAR FORM)) (LIN-MEXPT FORM))))
|
||||
|
||||
(DEFUN LIN-MPLUS (FORM)
|
||||
(DO ((TL (CDR FORM) (CDR TL)) (DUMMY) (COEFF 0) (REM 0))
|
||||
((NULL TL) (IF (FIXNUMP COEFF) (CONS COEFF (MMOD REM COEFF))))
|
||||
(SETQ DUMMY (LINEARIZE (CAR TL)))
|
||||
(IF (NULL DUMMY)
|
||||
(RETURN NIL)
|
||||
(SETQ COEFF (RGCD (CAR DUMMY) COEFF) REM (RPLUS (CDR DUMMY) REM)))))
|
||||
|
||||
(DEFUN LIN-MTIMES (FORM)
|
||||
(DO ((FL (CDR FORM) (CDR FL)) (DUMMY) (COEFF 0) (REM 1))
|
||||
((NULL FL) (IF (FIXNUMP COEFF) (CONS COEFF (MMOD REM COEFF))))
|
||||
(SETQ DUMMY (LINEARIZE (CAR FL)))
|
||||
(IF (NULL DUMMY)
|
||||
(RETURN NIL)
|
||||
(SETQ COEFF (RGCD (RTIMES COEFF (CAR DUMMY))
|
||||
(RGCD (RTIMES COEFF (CDR DUMMY))
|
||||
(RTIMES REM (CAR DUMMY))))
|
||||
REM (RTIMES (CDR DUMMY) REM)))))
|
||||
|
||||
(DEFUN LIN-MEXPT (FORM)
|
||||
(LET (DUMMY)
|
||||
(IF (AND (FIXNUMP (CADDR FORM))
|
||||
(NOT (MINUSP (CADDR FORM)))
|
||||
(NOT (NULL (SETQ DUMMY (LINEARIZE (CADR FORM))))))
|
||||
(CONS (CAR DUMMY) (MMOD (CDR DUMMY) (CADDR FORM))))))
|
||||
|
||||
|
||||
(DEFUN LCM (X Y) (QUOTIENT (TIMES X Y) (GCD X Y)))
|
||||
|
||||
(DEFUN RGCD (X Y)
|
||||
(COND ((FIXP X)
|
||||
(COND ((FIXP Y) (GCD X Y))
|
||||
(T (LIST '(RAT) (GCD X (CADR Y)) (CADDR Y)))))
|
||||
((FIXP Y) (LIST '(RAT) (GCD (CADR X) Y) (CADDR X)))
|
||||
(T (LIST '(RAT) (GCD (CADR X) (CADR Y)) (LCM (CADDR X) (CADDR Y))))))
|
||||
|
||||
(DEFUN REDUCE (X Y)
|
||||
(PROG (GCD)
|
||||
(SETQ GCD (GCD X Y) X (QUOTIENT X GCD) Y (QUOTIENT Y GCD))
|
||||
(IF (MINUSP Y) (SETQ X (MINUS X) Y (MINUS Y)))
|
||||
(RETURN (IF (EQUAL Y 1) X (LIST '(RAT SIMP) X Y)))))
|
||||
|
||||
;; The following four functions are generated in code by TRANSL. - JPG 2/1/81
|
||||
|
||||
(DEFMFUN RPLUS (X Y) (ADDK X Y))
|
||||
|
||||
(DEFMFUN RDIFFERENCE (X Y) (ADDK X (TIMESK -1 Y)))
|
||||
|
||||
(DEFMFUN RTIMES (X Y) (TIMESK X Y))
|
||||
|
||||
(DEFMFUN RREMAINDER (X Y)
|
||||
(COND ((EQUAL 0 Y) (DBZ-ERR))
|
||||
((FIXP X)
|
||||
(COND ((FIXP Y) (REDUCE X Y))
|
||||
(T (REDUCE (TIMES X (CADDR Y)) (CADR Y)))))
|
||||
((FIXP Y) (REDUCE (CADR X) (TIMES (CADDR X) Y)))
|
||||
(T (REDUCE (TIMES (CADR X) (CADDR Y)) (TIMES (CADDR X) (CADR Y))))))
|
||||
|
||||
(DEFMFUN $EXPONENTIALIZE (EXP)
|
||||
(LET ($DEMOIVRE)
|
||||
(COND ((ATOM EXP) EXP)
|
||||
((TRIGP (CAAR EXP))
|
||||
(EXPONENTIALIZE (CAAR EXP) ($EXPONENTIALIZE (CADR EXP))))
|
||||
(T (RECUR-APPLY #'$EXPONENTIALIZE EXP)))))
|
||||
|
||||
(DEFMFUN EXPONENTIALIZE (OP ARG)
|
||||
(COND ((EQ '%SIN OP)
|
||||
(DIV (SUB (POWER '$%E (MUL '$%I ARG)) (POWER '$%E (MUL -1 '$%I ARG)))
|
||||
(MUL 2 '$%I)))
|
||||
((EQ '%COS OP)
|
||||
(DIV (ADD (POWER '$%E (MUL '$%I ARG)) (POWER '$%E (MUL -1 '$%I ARG))) 2))
|
||||
((EQ '%TAN OP)
|
||||
(DIV (SUB (POWER '$%E (MUL '$%I ARG)) (POWER '$%E (MUL -1 '$%I ARG)))
|
||||
(MUL '$%I (ADD (POWER '$%E (MUL '$%I ARG))
|
||||
(POWER '$%E (MUL -1 '$%I ARG))))))
|
||||
((EQ '%COT OP)
|
||||
(DIV (MUL '$%I (ADD (POWER '$%E (MUL '$%I ARG))
|
||||
(POWER '$%E (MUL -1 '$%I ARG))))
|
||||
(SUB (POWER '$%E (MUL '$%I ARG)) (POWER '$%E (MUL -1 '$%I ARG)))))
|
||||
((EQ '%CSC OP)
|
||||
(DIV (MUL 2 '$%I)
|
||||
(SUB (POWER '$%E (MUL '$%I ARG)) (POWER '$%E (MUL -1 '$%I ARG)))))
|
||||
((EQ '%SEC OP)
|
||||
(DIV 2 (ADD (POWER '$%E (MUL '$%I ARG)) (POWER '$%E (MUL -1 '$%I ARG)))))
|
||||
((EQ '%SINH OP)
|
||||
(DIV (SUB (POWER '$%E ARG) (POWER '$%E (NEG ARG))) 2))
|
||||
((EQ '%COSH OP)
|
||||
(DIV (ADD (POWER '$%E ARG) (POWER '$%E (MUL -1 ARG))) 2))
|
||||
((EQ '%TANH OP)
|
||||
(DIV (SUB (POWER '$%E ARG) (POWER '$%E (NEG ARG)))
|
||||
(ADD (POWER '$%E ARG) (POWER '$%E (MUL -1 ARG)))))
|
||||
((EQ '%COTH OP)
|
||||
(DIV (ADD (POWER '$%E ARG) (POWER '$%E (MUL -1 ARG)))
|
||||
(SUB (POWER '$%E ARG) (POWER '$%E (NEG ARG)))))
|
||||
((EQ '%CSCH OP)
|
||||
(DIV 2 (SUB (POWER '$%E ARG) (POWER '$%E (NEG ARG)))))
|
||||
((EQ '%SECH OP)
|
||||
(DIV 2 (ADD (POWER '$%E ARG) (POWER '$%E (MUL -1 ARG)))))))
|
||||
|
||||
(DEFUN COEFFICIENT (EXP VAR POW)
|
||||
(LET ($NUMER $FLOAT) (COEFF (EXPAND1 EXP 1 0) VAR POW)))
|
||||
|
||||
(DEFUN LINEARP (EXP VAR)
|
||||
(LET ($NUMER $FLOAT)
|
||||
(AND (SETQ EXP (ISLINEAR (EXPAND1 EXP 1 0) VAR))
|
||||
(NOT (EQUAL (CAR EXP) 0)))))
|
||||
|
||||
(DEFUN MMOD (X MOD)
|
||||
(COND ((FIXNUMP X)
|
||||
(IF (MINUSP (SETQ X (- X (* MOD (// X MOD))))) (+ X MOD) X))
|
||||
((RATNUMP X)
|
||||
(LIST '(RAT) (MMOD (CADR X) (* MOD (CADDR X))) (CADDR X)))))
|
||||
|
||||
(DEFUN MULTIPLEP (EXP VAR)
|
||||
(AND (NOT (ZEROP1 EXP)) (ZEROP1 (SUB EXP (MUL VAR (COEFF EXP VAR 1))))))
|
||||
|
||||
(DEFMFUN MMINUSP (X) (= -1 (SIGNUM1 X)))
|
||||
|
||||
(DEFMFUN MMINUSP* (X) (MMINUSP X)) ;; This could be done by a macro in
|
||||
;; LIBMAX;MAXMAC . - JPG
|
||||
|
||||
;; The following definition for MMINUSP* was used experimentally to test
|
||||
;; for e.g. SIN(-X) -> -SIN(X) using the Macsyma database. However, this
|
||||
;; approach was found to be very slow in many cases. Instead the syntactic
|
||||
;; check offered by MMINUSP should be quite sufficient. - JPG
|
||||
|
||||
;;(DEFMFUN MMINUSP* (X)
|
||||
;; (LET (SIGN)
|
||||
;; (SETQ SIGN (CSIGN X))
|
||||
;; (OR (MEMQ SIGN '($NEG $NZ))
|
||||
;; (AND (MMINUSP X) (NOT (MEMQ SIGN '($POS $PZ)))))))
|
||||
|
||||
(DEFUN DBZ-ERR ()
|
||||
(IF (NOT ERRORSW) (MERROR "Division by zero") (*THROW 'ERRORSW T)))
|
||||
|
||||
(DEFUN DBZ-ERR1 (FUNC)
|
||||
(IF (NOT ERRORSW) (MERROR "Division by zero in ~A function" FUNC)
|
||||
(*THROW 'ERRORSW T)))
|
||||
|
||||
;; Only used by LAP code right now.
|
||||
|
||||
#+PDP10
|
||||
(DEFUN NUMERIC-ERR (X MSG) (MERROR "~A in ~A function" MSG X))
|
||||
|
||||
;; Trig, hyperbolic functions, and inverses, which take real floating args
|
||||
;; and return real args. Checks made for overflow and out of range args.
|
||||
;; The following are read-time constants.
|
||||
;; This seems bogus. Probably want (FSC (LSH 1 26.) 0) for the PDP10. -cwh
|
||||
|
||||
#.(SETQ EPS #+PDP10 (FSC 1.0 -26.)
|
||||
#+LispM (ASH 1.0 #+3600 -24. #-3600 -31.)
|
||||
#-(or PDP10 LispM) 1.4E-8)
|
||||
|
||||
#.(SETQ PI (ATAN 0.0 -1.0) PIBY2 (//$ PI 2.0))
|
||||
|
||||
;; This function is in LAP for PDP10 systems. On the Lisp Machine and
|
||||
;; in NIL, this should CONDITION-BIND the appropriate arithmetic overflow
|
||||
;; signals and do whatever NUMERIC-ERR or DBZ-ERR does. Fix later.
|
||||
|
||||
#-(OR PDP10 LISPM) (DEFMACRO T//$ (X Y FUNCTION) FUNCTION ;Ignored
|
||||
`(//$ ,X ,Y))
|
||||
#+LISPM
|
||||
(DEFMACRO T//$ (X Y FUNCTION)
|
||||
(IF (EQUAL Y 0.0)
|
||||
;; DEFEAT INCOMPETENTLY DONE COMPILER:OPTIMIZATION.
|
||||
`(T//$-FOO ,X ,Y ,FUNCTION)
|
||||
`(//$ ,X ,Y)))
|
||||
#+LISPM
|
||||
(DEFUN T//$-FOO (X Y FUNCTION) FUNCTION
|
||||
(//$ X Y))
|
||||
|
||||
#+PDP10 (LAP-A-LIST '(
|
||||
|
||||
(LAP T//$ SUBR)
|
||||
(ARGS T//$ (NIL . 3))
|
||||
(PUSH P (% 0 0 FLOAT1))
|
||||
(JRST 2 @ (% 0 0 NEXTA))
|
||||
NEXTA (MOVE TT 0 A)
|
||||
(FDVR TT 0 B) ;DIVIDE TT BY SECOND ARG
|
||||
(JFCL 10 UFLOW)
|
||||
ANS (POPJ P)
|
||||
UFLOW (MOVE A C)
|
||||
(SKIPN 0 0 B)
|
||||
(JCALL 1 'DBZ-ERR1)
|
||||
(MOVEI B 'OVERFLOW)
|
||||
(JSP T NEXTB)
|
||||
NEXTB (TLNN T 64.)
|
||||
(JCALL 2 'NUMERIC-ERR)
|
||||
(MOVEI B 'UNDERFLOW)
|
||||
(SKIPN 0 (SPECIAL ZUNDERFLOW))
|
||||
(JCALL 2 'NUMERIC-ERR)
|
||||
(MOVEI TT 0)
|
||||
(JRST 0 ANS)
|
||||
NIL ))
|
||||
|
||||
;; Numeric functions (SIN, COS, LOG, EXP are built in to Lisp).
|
||||
|
||||
(DEFMFUN TAN (X) (T//$ (SIN X) (COS X) 'TAN))
|
||||
|
||||
(DEFMFUN COT (X) (T//$ (COS X) (SIN X) 'COT))
|
||||
|
||||
(DEFMFUN SEC (X) (T//$ 1.0 (COS X) 'SEC))
|
||||
|
||||
(DEFMFUN CSC (X) (T//$ 1.0 (SIN X) 'CSC))
|
||||
|
||||
;; #.<form> means to evaluate <form> at read-time.
|
||||
|
||||
(DECLARE (FLONUM YY YFLO))
|
||||
|
||||
;; We don't use the built-in Franz definitions of ASIN and ACOS because
|
||||
;; they obviously don't know about LOGARC. - JPG
|
||||
|
||||
(DEFMFUN ASIN (NUM)
|
||||
(LET ((YFLO (FLOAT NUM)))
|
||||
(COND ((> (ABS YFLO) 1.0) (LOGARC '%ASIN YFLO))
|
||||
((< (ABS YFLO) #.(SQRT EPS)) YFLO)
|
||||
(T (*$ (ATAN (ABS YFLO) (SQRT (-$ 1.0 (*$ YFLO YFLO))))
|
||||
(IF (< YFLO 0.0) -1.0 1.0))))))
|
||||
|
||||
(DEFMFUN ACOS (NUM)
|
||||
(LET ((YFLO (FLOAT NUM)))
|
||||
(COND ((> (ABS YFLO) 1.0) (LOGARC '%ACOS YFLO))
|
||||
((< (ABS YFLO) #.(SQRT EPS)) (-$ #.PIBY2 YFLO))
|
||||
(T (ATAN (SQRT (-$ 1.0 (*$ YFLO YFLO))) YFLO)))))
|
||||
#-LispM
|
||||
(DEFMFUN ATAN2 (Y X)
|
||||
(LET ((YFLO (ATAN (ABS Y) X))) (IF (MINUSP Y) (-$ YFLO) YFLO)))
|
||||
|
||||
(DEFMFUN ATAN1 (NUM)
|
||||
(LET ((YFLO (FLOAT NUM)))
|
||||
(*$ (ATAN (ABS YFLO) 1.0) (IF (MINUSP YFLO) -1.0 1.0))))
|
||||
|
||||
(DEFMFUN ACOT (NUM)
|
||||
(LET ((YFLO (FLOAT NUM)))
|
||||
(*$ (ATAN 1.0 (ABS YFLO)) (IF (MINUSP YFLO) -1.0 1.0))))
|
||||
|
||||
(DEFMFUN ASEC (NUM)
|
||||
(LET ((YFLO (FLOAT NUM)))
|
||||
(IF (< (ABS YFLO) 1.0) (LOGARC '%ASEC YFLO)) (ACOS (//$ YFLO))))
|
||||
|
||||
(DEFMFUN ACSC (NUM)
|
||||
(LET ((YFLO (FLOAT NUM)))
|
||||
(IF (< (ABS YFLO) 1.0) (LOGARC '%ACSC YFLO)) (ASIN (//$ YFLO))))
|
||||
|
||||
(DEFMFUN SINH (NUM)
|
||||
(LET ((YY (FLOAT NUM)) (YFLO 0.0))
|
||||
(COND ((< (ABS YY) #.(SQRT EPS)) YY)
|
||||
(T (SETQ YFLO (EXP (ABS YY)) YFLO (//$ (-$ YFLO (//$ YFLO)) 2.0))
|
||||
(IF (< YY 0.0) (-$ YFLO) YFLO)))))
|
||||
|
||||
(DEFMFUN COSH (NUM)
|
||||
(LET ((YFLO (FLOAT NUM)))
|
||||
(SETQ YFLO (EXP (ABS YFLO))) (//$ (+$ YFLO (//$ YFLO)) 2.0)))
|
||||
|
||||
#-Lispm
|
||||
(DEFMFUN TANH (NUM)
|
||||
(LET ((YY (FLOAT NUM)) (YFLO 0.0))
|
||||
(COND ((< (ABS YY) #.(SQRT EPS)) YY)
|
||||
(T (SETQ YFLO (EXP (*$ -2.0 (ABS YY)))
|
||||
YFLO (//$ (1-$ YFLO) (1+$ YFLO)))
|
||||
(IF (PLUSP YY) (-$ YFLO) YFLO)))))
|
||||
|
||||
#+Lispm
|
||||
(DEFMFUN TANH (NUM)
|
||||
(LET ((YY (FLOAT NUM)) (YFLO 0.0))
|
||||
(COND ((< (ABS YY) #.(SQRT EPS)) YY)
|
||||
(T (LET ((ANSWER 0.0))
|
||||
(SETQ ANSWER
|
||||
(COND ((> (ABS YY) #.(//$ (-$ (LOG EPS)) 2.0)) -1.0)
|
||||
(T (SETQ YFLO (EXP (*$ -2.0 (ABS YY)))
|
||||
ANSWER (//$ (1-$ YFLO) (1+$ YFLO))))))
|
||||
(IF (PLUSP YY) (-$ ANSWER) ANSWER))))))
|
||||
|
||||
(DEFMFUN COTH (NUM)
|
||||
(LET ((YY (FLOAT NUM)) (YFLO 0.0))
|
||||
(COND ((< (ABS YY) #.(SQRT EPS)) (T//$ 1.0 YY 'COTH))
|
||||
(T (SETQ YFLO (EXP (*$ -2.0 (ABS YY)))
|
||||
YFLO (T//$ (1+$ YFLO) (1-$ YFLO) 'COTH))
|
||||
(IF (PLUSP YY) (-$ YFLO) YFLO)))))
|
||||
|
||||
(DEFMFUN CSCH (NUM)
|
||||
(LET ((YY (FLOAT NUM)) (YFLO 0.0))
|
||||
(COND ((< (ABS YY) #.(SQRT EPS)) (//$ YY))
|
||||
(T (SETQ YFLO (EXP (-$ (ABS YY)))
|
||||
YFLO (T//$ (*$ 2.0 YFLO)
|
||||
(1-$ (IF (< YFLO #.(SQRT EPS)) 0.0 (*$ YFLO YFLO))) 'CSCH))
|
||||
(IF (PLUSP YY) (-$ YFLO) YFLO)))))
|
||||
|
||||
(DEFMFUN SECH (NUM)
|
||||
(LET ((YFLO (FLOAT NUM))) (SETQ YFLO (EXP (-$ (ABS YFLO))))
|
||||
(//$ YFLO 0.5 (1+$ (IF (< YFLO #.(SQRT EPS)) 0.0 (*$ YFLO YFLO))))))
|
||||
|
||||
(DEFMFUN ACOSH (NUM)
|
||||
(LET ((YFLO (FLOAT NUM)))
|
||||
(COND ((< YFLO 1.0) (LOGARC '%ACOSH YFLO))
|
||||
((> YFLO #.(SQRT (//$ EPS))) (LOG (*$ 2.0 YFLO)))
|
||||
(T (LOG (+$ (SQRT (1-$ (*$ YFLO YFLO))) YFLO))))))
|
||||
|
||||
(DEFMFUN ASINH (NUM)
|
||||
(LET* ((YY (FLOAT NUM))
|
||||
(YFLO (ABS YY)))
|
||||
(COND ((< YFLO #.(SQRT EPS)) YFLO)
|
||||
(T (SETQ YFLO (LOG (COND ((> YFLO #.(SQRT (//$ EPS))) (*$ 2.0 YFLO))
|
||||
(T (+$ (SQRT (1+$ (*$ YFLO YFLO))) YFLO)))))
|
||||
(COND ((MINUSP YY) (-$ YFLO)) (T YFLO))))))
|
||||
|
||||
(DEFMFUN ATANH (NUM)
|
||||
(LET ((YFLO (FLOAT NUM)))
|
||||
(COND ((< (ABS YFLO) #.(SQRT EPS)) YFLO)
|
||||
((< (ABS YFLO) 1.0) (//$ (LOG (T//$ (1+$ YFLO) (-$ 1.0 YFLO) 'ATANH)) 2.0))
|
||||
((= 1.0 (ABS YFLO)) (T//$ 1.0 0.0 'ATANH))
|
||||
(T (LOGARC '%ATANH YFLO)))))
|
||||
|
||||
(DEFMFUN ACOTH (NUM)
|
||||
(LET ((YFLO (FLOAT NUM)))
|
||||
(COND ((> (ABS YFLO) 1.0) (//$ (LOG (//$ (-$ 1.0 YFLO) (1+$ YFLO))) 2.0))
|
||||
((= 1.0 (ABS YFLO)) (T//$ 1.0 0.0 'ACOTH))
|
||||
(T (LOGARC '%ACOTH YFLO)))))
|
||||
|
||||
(DEFMFUN ASECH (NUM)
|
||||
(LET ((YFLO (FLOAT NUM)))
|
||||
(COND ((OR (MINUSP YFLO) (> YFLO 1.0)) (LOGARC '%ASECH YFLO)))
|
||||
(ACOSH (T//$ 1.0 YFLO 'ASECH))))
|
||||
|
||||
(DEFMFUN ACSCH (NUM) (ASINH (T//$ 1.0 (FLOAT NUM) 'ACSCH)))
|
||||
|
||||
378
src/mrg/trigo.333
Normal file
378
src/mrg/trigo.333
Normal file
@@ -0,0 +1,378 @@
|
||||
;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;;
|
||||
;;; (c) Copyright 1982 Massachusetts Institute of Technology ;;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(macsyma-module trigo)
|
||||
|
||||
(LOAD-MACSYMA-MACROS MRGMAC)
|
||||
|
||||
(DECLARE (GENPREFIX TRI)
|
||||
(SPECIAL VARLIST ERRORSW)
|
||||
(FLONUM (TAN) (COT) (SEC) (CSC)
|
||||
(ATAN2) (ATAN1) (ACOT)
|
||||
(SINH) (COSH) (TANH) (COTH) (CSCH) (SECH)
|
||||
(ASINH) (ACSCH)
|
||||
(T//$ FLONUM FLONUM NOTYPE))
|
||||
(*EXPR $BFLOAT TEVAL SIGNUM1 ZEROP1 ISLINEAR
|
||||
TIMESK ADDK INTEGERP EVOD LOGARC MEVENP HALFANGLE COEFF))
|
||||
|
||||
(DECLARE (SPLITFILE HYPER))
|
||||
|
||||
(DEFMFUN SIMP-%SINH (FORM Y Z)
|
||||
(ONEARGCHECK FORM)
|
||||
(SETQ Y (SIMPCHECK (CADR FORM) Z))
|
||||
(COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (SINH Y))
|
||||
(($BFLOATP Y) ($BFLOAT FORM))
|
||||
((AND $%PIARGS (IF (ZEROP1 Y) 0)))
|
||||
((AND $%IARGS (MULTIPLEP Y '$%I)) (MUL '$%I (CONS-EXP '%SIN (COEFF Y '$%I 1))))
|
||||
((AND $TRIGINVERSES (NOT (ATOM Y)) (IF (EQ '%ASINH (CAAR Y)) (CADR Y))))
|
||||
((AND $TRIGEXPAND (TRIGEXPAND '%SINH Y)))
|
||||
($EXPONENTIALIZE (EXPONENTIALIZE '%SINH Y))
|
||||
((AND $HALFANGLES (HALFANGLE '%SINH Y)))
|
||||
((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%SINH (NEG Y))))
|
||||
(T (EQTEST (LIST '(%SINH) Y) FORM))))
|
||||
|
||||
(DEFMFUN SIMP-%COSH (FORM Y Z)
|
||||
(ONEARGCHECK FORM)
|
||||
(SETQ Y (SIMPCHECK (CADR FORM) Z))
|
||||
(COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (COSH Y))
|
||||
(($BFLOATP Y) ($BFLOAT FORM))
|
||||
((AND $%PIARGS (IF (ZEROP1 Y) 1)))
|
||||
((AND $%IARGS (MULTIPLEP Y '$%I)) (CONS-EXP '%COS (COEFF Y '$%I 1)))
|
||||
((AND $TRIGINVERSES (NOT (ATOM Y)) (IF (EQ '%ACOSH (CAAR Y)) (CADR Y))))
|
||||
((AND $TRIGEXPAND (TRIGEXPAND '%COSH Y)))
|
||||
($EXPONENTIALIZE (EXPONENTIALIZE '%COSH Y))
|
||||
((AND $HALFANGLES (HALFANGLE '%COSH Y)))
|
||||
((AND $TRIGSIGN (MMINUSP* Y)) (CONS-EXP '%COSH (NEG Y)))
|
||||
(T (EQTEST (LIST '(%COSH) Y) FORM))))
|
||||
|
||||
(DEFMFUN SIMP-%TANH (FORM Y Z)
|
||||
(ONEARGCHECK FORM)
|
||||
(SETQ Y (SIMPCHECK (CADR FORM) Z))
|
||||
(COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (TANH Y))
|
||||
(($BFLOATP Y) ($BFLOAT FORM))
|
||||
((AND $%PIARGS (IF (ZEROP1 Y) 0)))
|
||||
((AND $%IARGS (MULTIPLEP Y '$%I)) (MUL '$%I (CONS-EXP '%TAN (COEFF Y '$%I 1))))
|
||||
((AND $TRIGINVERSES (NOT (ATOM Y)) (IF (EQ '%ATANH (SETQ Z (CAAR Y))) (CADR Y))))
|
||||
((AND $TRIGEXPAND (TRIGEXPAND '%TANH Y)))
|
||||
($EXPONENTIALIZE (EXPONENTIALIZE '%TANH Y))
|
||||
((AND $HALFANGLES (HALFANGLE '%TANH Y)))
|
||||
((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%TANH (NEG Y))))
|
||||
(T (EQTEST (LIST '(%TANH) Y) FORM))))
|
||||
|
||||
(DEFMFUN SIMP-%COTH (FORM Y Z)
|
||||
(ONEARGCHECK FORM)
|
||||
(SETQ Y (SIMPCHECK (CADR FORM) Z))
|
||||
(COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (COTH Y))
|
||||
(($BFLOATP Y) ($BFLOAT FORM))
|
||||
((AND $%PIARGS (IF (ZEROP1 Y) (DBZ-ERR1 'COTH))))
|
||||
((AND $%IARGS (MULTIPLEP Y '$%I)) (MUL -1 '$%I (CONS-EXP '%COTH (COEFF Y '$%I 1))))
|
||||
((AND $TRIGINVERSES (NOT (ATOM Y)) (IF (EQ '%ACOTH (CAAR Y)) (CADR Y))))
|
||||
((AND $TRIGEXPAND (TRIGEXPAND '%COTH Y)))
|
||||
($EXPONENTIALIZE (EXPONENTIALIZE '%COTH Y))
|
||||
((AND $HALFANGLES (HALFANGLE '%COTH Y)))
|
||||
((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%COTH (NEG Y))))
|
||||
(T (EQTEST (LIST '(%COTH) Y) FORM))))
|
||||
|
||||
(DEFMFUN SIMP-%CSCH (FORM Y Z)
|
||||
(ONEARGCHECK FORM)
|
||||
(SETQ Y (SIMPCHECK (CADR FORM) Z))
|
||||
(COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (CSCH Y))
|
||||
(($BFLOATP Y) ($BFLOAT FORM))
|
||||
((AND $%PIARGS (COND ((ZEROP1 Y) (DBZ-ERR1 'CSCH)))))
|
||||
((AND $%IARGS (MULTIPLEP Y '$%I)) (MUL -1 '$%I (CONS-EXP '%CSC (COEFF Y '$%I 1))))
|
||||
((AND $TRIGINVERSES (NOT (ATOM Y)) (IF (EQ '%ACSCH (CAAR Y)) (CADR Y))))
|
||||
((AND $TRIGEXPAND (TRIGEXPAND '%CSCH Y)))
|
||||
($EXPONENTIALIZE (EXPONENTIALIZE '%CSCH Y))
|
||||
((AND $HALFANGLES (HALFANGLE '%CSCH Y)))
|
||||
((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%CSCH (NEG Y))))
|
||||
(T (EQTEST (LIST '(%CSCH) Y) FORM))))
|
||||
|
||||
(DEFMFUN SIMP-%SECH (FORM Y Z)
|
||||
(ONEARGCHECK FORM)
|
||||
(SETQ Y (SIMPCHECK (CADR FORM) Z))
|
||||
(COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (SECH Y))
|
||||
(($BFLOATP Y) ($BFLOAT FORM))
|
||||
((AND $%PIARGS (ZEROP1 Y)) 1)
|
||||
((AND $%IARGS (MULTIPLEP Y '$%I)) (CONS-EXP '%SEC (COEFF Y '$%I 1)))
|
||||
((AND $TRIGINVERSES (NOT (ATOM Y)) (IF (EQ '%ASECH (CAAR Y)) (CADR Y))))
|
||||
((AND $TRIGEXPAND (TRIGEXPAND '%SECH Y)))
|
||||
($EXPONENTIALIZE (EXPONENTIALIZE '%SECH Y))
|
||||
((AND $HALFANGLES (HALFANGLE '%SECH Y)))
|
||||
((AND $TRIGSIGN (MMINUSP* Y)) (CONS-EXP '%SECH (NEG Y)))
|
||||
(T (EQTEST (LIST '(%SECH) Y) FORM))))
|
||||
|
||||
(DECLARE (SPLITFILE ATRIG))
|
||||
|
||||
(DEFMFUN SIMP-%ASIN (FORM Y Z)
|
||||
(ONEARGCHECK FORM)
|
||||
(SETQ Y (SIMPCHECK (CADR FORM) Z))
|
||||
(COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (ASIN Y))
|
||||
(($BFLOATP Y) ($BFLOAT FORM))
|
||||
((AND $%PIARGS
|
||||
(COND ((ZEROP1 Y) 0) ((EQUAL 1 Y) %PI//2) ((EQUAL -1 Y) (NEG %PI//2))
|
||||
((ALIKE1 Y 1//2) (MUL '((RAT SIMP) 1 6) '$%PI)))))
|
||||
((AND $%IARGS (MULTIPLEP Y '$%I)) (MUL '$%I (CONS-EXP '%ASINH (COEFF Y '$%I 1))))
|
||||
((AND (EQ $TRIGINVERSES '$ALL) (NOT (ATOM Y)) (IF (EQ '%SIN (CAAR Y)) (CADR Y))))
|
||||
($LOGARC (LOGARC '%ASIN Y))
|
||||
((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%ASIN (NEG Y))))
|
||||
(T (EQTEST (LIST '(%ASIN) Y) FORM))))
|
||||
|
||||
(DEFMFUN SIMP-%ACOS (FORM Y Z)
|
||||
(ONEARGCHECK FORM)
|
||||
(SETQ Y (SIMPCHECK (CADR FORM) Z))
|
||||
(COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (ACOS Y))
|
||||
(($BFLOATP Y) ($BFLOAT FORM))
|
||||
((AND $%PIARGS
|
||||
(COND ((ZEROP1 Y) %PI//2) ((EQUAL 1 Y) 0) ((EQUAL -1 Y) '$%PI)
|
||||
((ALIKE1 Y 1//2) (MUL '((RAT SIMP) 1 3) '$%PI)))))
|
||||
((AND (EQ $TRIGINVERSES '$ALL) (NOT (ATOM Y))
|
||||
(IF (EQ '%COS (CAAR Y)) (CADR Y))))
|
||||
($LOGARC (LOGARC '%ACOS Y))
|
||||
((AND $TRIGSIGN (MMINUSP* Y)) (SUB '$%PI (CONS-EXP '%ACOS (NEG Y))))
|
||||
(T (EQTEST (LIST '(%ACOS) Y) FORM))))
|
||||
|
||||
(DEFMFUN SIMP-%ACOT (FORM Y Z)
|
||||
(ONEARGCHECK FORM)
|
||||
(SETQ Y (SIMPCHECK (CADR FORM) Z))
|
||||
(COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (ACOT Y))
|
||||
(($BFLOATP Y) ($BFLOAT FORM))
|
||||
((AND $%PIARGS
|
||||
(COND ((ZEROP1 Y) %PI//2) ((EQUAL 1 Y) %PI//4) ((EQUAL -1 Y) (NEG %PI//4)))))
|
||||
((AND $%IARGS (MULTIPLEP Y '$%I)) (MUL -1 '$%I (CONS-EXP '%ACOTH (COEFF Y '$%I 1))))
|
||||
((AND (EQ $TRIGINVERSES '$ALL) (NOT (ATOM Y))
|
||||
(IF (EQ '%COT (CAAR Y)) (CADR Y))))
|
||||
($LOGARC (LOGARC '%ACOT Y))
|
||||
((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%ACOT (NEG Y))))
|
||||
(T (EQTEST (LIST '(%ACOT) Y) FORM))))
|
||||
|
||||
(DEFMFUN SIMP-%ACSC (FORM Y Z)
|
||||
(ONEARGCHECK FORM)
|
||||
(SETQ Y (SIMPCHECK (CADR FORM) Z))
|
||||
(COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (ACSC Y))
|
||||
(($BFLOATP Y) ($BFLOAT FORM))
|
||||
((AND $%PIARGS
|
||||
(COND ((EQUAL 1 Y) %PI//2) ((EQUAL -1 Y) (NEG %PI//2)))))
|
||||
((AND $%IARGS (MULTIPLEP Y '$%I)) (MUL -1 '$%I (CONS-EXP '%ACSCH (COEFF Y '$%I 1))))
|
||||
((AND (EQ $TRIGINVERSES '$ALL) (NOT (ATOM Y))
|
||||
(IF (EQ '%CSC (CAAR Y)) (CADR Y))))
|
||||
($LOGARC (LOGARC '%ACSC Y))
|
||||
((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%ACSC (NEG Y))))
|
||||
(T (EQTEST (LIST '(%ACSC) Y) FORM))))
|
||||
|
||||
(DEFMFUN SIMP-%ASEC (FORM Y Z)
|
||||
(ONEARGCHECK FORM)
|
||||
(SETQ Y (SIMPCHECK (CADR FORM) Z))
|
||||
(COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (ASEC Y))
|
||||
(($BFLOATP Y) ($BFLOAT FORM))
|
||||
((AND $%PIARGS
|
||||
(COND ((EQUAL 1 Y) 0) ((EQUAL -1 Y) '$%PI))))
|
||||
((AND (EQ $TRIGINVERSES '$ALL) (NOT (ATOM Y))
|
||||
(IF (EQ '%SEC (CAAR Y)) (CADR Y))))
|
||||
($LOGARC (LOGARC '%ASEC Y))
|
||||
((AND $TRIGSIGN (MMINUSP* Y)) (SUB '$%PI (CONS-EXP '%ASEC (NEG Y))))
|
||||
(T (EQTEST (LIST '(%ASEC) Y) FORM))))
|
||||
|
||||
(DECLARE (SPLITFILE AHYPER))
|
||||
|
||||
(DEFMFUN SIMP-%ASINH (FORM Y Z)
|
||||
(ONEARGCHECK FORM)
|
||||
(SETQ Y (SIMPCHECK (CADR FORM) Z))
|
||||
(COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (ASINH Y))
|
||||
(($BFLOATP Y) ($BFLOAT FORM))
|
||||
((AND $%PIARGS (IF (ZEROP1 Y) Y)))
|
||||
((AND $%IARGS (MULTIPLEP Y '$%I)) (MUL '$%I (CONS-EXP '%ASIN (COEFF Y '$%I 1))))
|
||||
((AND (EQ $TRIGINVERSES '$ALL) (NOT (ATOM Y))
|
||||
(IF (EQ '%SINH (CAAR Y)) (CADR Y))))
|
||||
($LOGARC (LOGARC '%ASINH Y))
|
||||
((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%ASINH (NEG Y))))
|
||||
(T (EQTEST (LIST '(%ASINH) Y) FORM))))
|
||||
|
||||
(DEFMFUN SIMP-%ACOSH (FORM Y Z)
|
||||
(ONEARGCHECK FORM)
|
||||
(SETQ Y (SIMPCHECK (CADR FORM) Z))
|
||||
(COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (ACOSH Y))
|
||||
(($BFLOATP Y) ($BFLOAT FORM))
|
||||
((AND $%PIARGS (IF (EQUAL Y 1) 0)))
|
||||
((AND (EQ $TRIGINVERSES '$ALL) (NOT (ATOM Y))
|
||||
(IF (EQ '%COSH (CAAR Y)) (CADR Y))))
|
||||
($LOGARC (LOGARC '%ACOSH Y))
|
||||
(T (EQTEST (LIST '(%ACOSH) Y) FORM))))
|
||||
|
||||
(DEFMFUN SIMP-%ATANH (FORM Y Z)
|
||||
(ONEARGCHECK FORM)
|
||||
(SETQ Y (SIMPCHECK (CADR FORM) Z))
|
||||
(COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (ATANH Y))
|
||||
(($BFLOATP Y) ($BFLOAT FORM))
|
||||
((AND $%PIARGS (COND ((ZEROP1 Y) 0)
|
||||
((OR (EQUAL Y 1) (EQUAL Y -1)) (DBZ-ERR1 'ATANH)))))
|
||||
((AND $%IARGS (MULTIPLEP Y '$%I)) (MUL '$%I (CONS-EXP '%ATAN (COEFF Y '$%I 1))))
|
||||
((AND (EQ $TRIGINVERSES '$ALL) (NOT (ATOM Y))
|
||||
(IF (EQ '%TANH (CAAR Y)) (CADR Y))))
|
||||
($LOGARC (LOGARC '%ATANH Y))
|
||||
((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%ATANH (NEG Y))))
|
||||
(T (EQTEST (LIST '(%ATANH) Y) FORM))))
|
||||
|
||||
(DEFMFUN SIMP-%ACOTH (FORM Y Z)
|
||||
(ONEARGCHECK FORM)
|
||||
(SETQ Y (SIMPCHECK (CADR FORM) Z))
|
||||
(COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (ACOTH Y))
|
||||
(($BFLOATP Y) ($BFLOAT FORM))
|
||||
((AND $%PIARGS (IF (OR (EQUAL Y 1) (EQUAL Y -1)) (DBZ-ERR1 'ACOTH))))
|
||||
((AND $%IARGS (MULTIPLEP Y '$%I)) (MUL -1 '$%I (CONS-EXP '%ACOT (COEFF Y '$%I 1))))
|
||||
((AND (EQ $TRIGINVERSES '$ALL) (NOT (ATOM Y))
|
||||
(IF (EQ '%COTH (CAAR Y)) (CADR Y))))
|
||||
($LOGARC (LOGARC '%ACOTH Y))
|
||||
((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%ACOTH (NEG Y))))
|
||||
(T (EQTEST (LIST '(%ACOTH) Y) FORM))))
|
||||
|
||||
(DEFMFUN SIMP-%ACSCH (FORM Y Z)
|
||||
(ONEARGCHECK FORM)
|
||||
(SETQ Y (SIMPCHECK (CADR FORM) Z))
|
||||
(COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (ACSCH Y))
|
||||
(($BFLOATP Y) ($BFLOAT FORM))
|
||||
((AND $%PIARGS (IF (ZEROP1 Y) (DBZ-ERR1 'ACSCH))))
|
||||
((AND $%IARGS (MULTIPLEP Y '$%I)) (MUL -1 '$%I (CONS-EXP '%ACSC (COEFF Y '$%I 1))))
|
||||
((AND (EQ $TRIGINVERSES '$ALL) (NOT (ATOM Y))
|
||||
(IF (EQ '%CSCH (CAAR Y)) (CADR Y))))
|
||||
($LOGARC (LOGARC '%ACSCH Y))
|
||||
((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%ACSCH (NEG Y))))
|
||||
(T (EQTEST (LIST '(%ACSCH) Y) FORM))))
|
||||
|
||||
(DEFMFUN SIMP-%ASECH (FORM Y Z)
|
||||
(ONEARGCHECK FORM)
|
||||
(SETQ Y (SIMPCHECK (CADR FORM) Z))
|
||||
(COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (ASECH Y))
|
||||
(($BFLOATP Y) ($BFLOAT FORM))
|
||||
((AND $%PIARGS (COND ((EQUAL Y 1) 0)
|
||||
((ZEROP1 Y) (DBZ-ERR1 'ASECH)))))
|
||||
((AND (EQ $TRIGINVERSES '$ALL) (NOT (ATOM Y))
|
||||
(IF (EQ '%SECH (CAAR Y)) (CADR Y))))
|
||||
($LOGARC (LOGARC '%ASECH Y))
|
||||
((AND $TRIGSIGN (MMINUSP* Y)) (CONS-EXP '%ASECH (NEG Y)))
|
||||
(T (EQTEST (LIST '(%ASECH) Y) FORM))))
|
||||
|
||||
(DECLARE (SPLITFILE TRIGEX) (SPECIAL $TRIGEXPANDPLUS $TRIGEXPANDTIMES))
|
||||
|
||||
(DEFMFUN $TRIGEXPAND (E)
|
||||
(COND ((ATOM E) E)
|
||||
((SPECREPP E) ($TRIGEXPAND (SPECDISREP E)))
|
||||
((TRIGEXPAND (CAAR E) (CADR E)))
|
||||
(T (RECUR-APPLY #'$TRIGEXPAND E))))
|
||||
|
||||
(DEFMFUN TRIGEXPAND (OP ARG)
|
||||
(COND ((ATOM ARG) NIL)
|
||||
((AND $TRIGEXPANDPLUS (EQ 'MPLUS (CAAR ARG)))
|
||||
(COND ((EQ '%SIN OP) (SIN\COS-PLUS (CDR ARG) 1 '%SIN '%COS -1))
|
||||
((EQ '%COS OP) (SIN\COS-PLUS (CDR ARG) 0 '%SIN '%COS -1))
|
||||
((EQ '%TAN OP) (TAN-PLUS (CDR ARG) '%TAN -1))
|
||||
((EQ '%COT OP) (COT-PLUS (CDR ARG) '%COT -1))
|
||||
((EQ '%CSC OP) (CSC\SEC-PLUS (CDR ARG) 1 '%CSC '%SEC -1))
|
||||
((EQ '%SEC OP) (CSC\SEC-PLUS (CDR ARG) 0 '%CSC '%SEC -1))
|
||||
((EQ '%SINH OP) (SIN\COS-PLUS (CDR ARG) 1 '%SINH '%COSH 1))
|
||||
((EQ '%COSH OP) (SIN\COS-PLUS (CDR ARG) 0 '%SINH '%COSH 1))
|
||||
((EQ '%TANH OP) (TAN-PLUS (CDR ARG) '%TANH 1))
|
||||
((EQ '%COTH OP) (COT-PLUS (CDR ARG) '%COTH 1))
|
||||
((EQ '%CSCH OP) (CSC\SEC-PLUS (CDR ARG) 1 '%CSCH '%SECH 1))
|
||||
((EQ '%SECH OP) (CSC\SEC-PLUS (CDR ARG) 0 '%CSCH '%SECH 1))))
|
||||
((AND $TRIGEXPANDTIMES (EQ 'MTIMES (CAAR ARG)) (EQ (TYPEP (CADR ARG)) 'FIXNUM))
|
||||
(COND ((EQ '%SIN OP) (SIN\COS-TIMES (CDDR ARG) 1 (CADR ARG) '%SIN '%COS -1))
|
||||
((EQ '%COS OP) (SIN\COS-TIMES (CDDR ARG) 0 (CADR ARG) '%SIN '%COS -1))
|
||||
((EQ '%TAN OP) (TAN-TIMES (CDDR ARG) (CADR ARG) '%TAN -1))
|
||||
((EQ '%COT OP) (COT-TIMES (CDDR ARG) (CADR ARG) '%COT -1))
|
||||
((EQ '%CSC OP) (CSC\SEC-TIMES (CDDR ARG) 1 (CADR ARG) '%CSC '%SEC -1))
|
||||
((EQ '%SEC OP) (CSC\SEC-TIMES (CDDR ARG) 0 (CADR ARG) '%CSC '%SEC -1))
|
||||
((EQ '%SINH OP) (SIN\COS-TIMES (CDDR ARG) 1 (CADR ARG) '%SINH '%COSH 1))
|
||||
((EQ '%COSH OP) (SIN\COS-TIMES (CDDR ARG) 0 (CADR ARG) '%SINH '%COSH 1))
|
||||
((EQ '%TANH OP) (TAN-TIMES (CDDR ARG) (CADR ARG) '%TANH 1))
|
||||
((EQ '%COTH OP) (COT-TIMES (CDDR ARG) (CADR ARG) '%COTH 1))
|
||||
((EQ '%CSCH OP) (CSC\SEC-TIMES (CDDR ARG) 1 (CADR ARG) '%CSCH '%SECH 1))
|
||||
((EQ '%SECH OP) (CSC\SEC-TIMES (CDDR ARG) 0 (CADR ARG) '%CSCH '%SECH 1))))))
|
||||
|
||||
|
||||
(DEFUN SIN\COS-PLUS (L N F1 F2 FLAG)
|
||||
(DO ((I N (+ 2 I)) (LEN (LENGTH L)) (SIGN 1 (* FLAG SIGN)) (RESULT))
|
||||
((> I LEN) (SIMPLIFY (CONS '(MPLUS) RESULT)))
|
||||
(SETQ RESULT (MPC (COND ((MINUSP SIGN) '(-1 (MTIMES))) (T '((MTIMES)))) L RESULT F1 F2 LEN I))))
|
||||
|
||||
(DEFUN TAN-PLUS (L F FLAG)
|
||||
(DO ((I 1 (+ 2 I)) (SIGN 1 (* FLAG SIGN)) (LEN (LENGTH L)) (NUM) (DEN (LIST 1)))
|
||||
((> I LEN) (DIV* (CONS '(MPLUS) NUM) (CONS '(MPLUS) DEN)))
|
||||
(SETQ NUM (MPC1 (LIST SIGN '(MTIMES)) L NUM F LEN I)
|
||||
DEN (COND ((= LEN I) DEN)
|
||||
(T (MPC1 (LIST (* FLAG SIGN) '(MTIMES)) L DEN F LEN (1+ I)))))))
|
||||
|
||||
(DEFUN COT-PLUS (L F FLAG)
|
||||
(DO ((I (LENGTH L) (- I 2)) (LEN (LENGTH L)) (SIGN 1 (* FLAG SIGN)) (NUM) (DEN))
|
||||
((< I 0) (DIV* (CONS '(MPLUS) NUM) (CONS '(MPLUS) DEN)))
|
||||
(SETQ NUM (MPC1 (LIST SIGN '(MTIMES)) L NUM F LEN I)
|
||||
DEN (COND ((= 0 I) DEN)
|
||||
(T (MPC1 (LIST SIGN '(MTIMES)) L DEN F LEN (1- I)))))))
|
||||
|
||||
(DEFUN CSC\SEC-PLUS (L N F1 F2 FLAG)
|
||||
(DIV* (DO ((L L (CDR L)) (RESULT)) ((NULL L) (CONS '(MTIMES) RESULT))
|
||||
(SETQ RESULT (CONS (CONS-EXP F1 (CAR L)) (CONS (CONS-EXP F2 (CAR L)) RESULT))))
|
||||
(SIN\COS-PLUS L N F1 F2 FLAG)))
|
||||
|
||||
(DEFUN SIN\COS-TIMES (L M N F1 F2 FLAG)
|
||||
;; Assume m,n < 2^17, but Binom may become big
|
||||
;; Flag is 1 or -1
|
||||
(SETQ F1 (CONS-EXP F1 (CONS '(MTIMES) L)) F2 (CONS-EXP F2 (CONS '(MTIMES) L)))
|
||||
(DO ((I M (+ 2 I)) (END (ABS N)) (RESULT)
|
||||
(BINOM (COND ((= 0 M) 1) (T (ABS N))) (quotient (times (* FLAG (- END I 1) (- END I)) BINOM) (* (+ 2 I) (1+ I)))))
|
||||
((> I END) (SETQ RESULT (SIMPLIFY (CONS '(MPLUS) RESULT)))
|
||||
(COND ((AND (= 1 M) (MINUSP N)) (NEG RESULT)) (T RESULT)))
|
||||
(SETQ RESULT (CONS (MUL BINOM (POWER F1 I) (POWER F2 (- END I))) RESULT))))
|
||||
|
||||
(DEFUN TAN-TIMES (L N F FLAG)
|
||||
(SETQ F (CONS-EXP F (CONS '(MTIMES) L)))
|
||||
(DO ((I 1 (+ 2 I)) (END (ABS N)) (NUM) (DEN (LIST 1))
|
||||
(BINOM (ABS N) (quotient (times (- END I 1) BINOM) (+ 2 I))))
|
||||
((> I END) (SETQ NUM (DIV* (CONS '(MPLUS) NUM) (CONS '(MPLUS) DEN)))
|
||||
(COND ((MINUSP N) (NEG NUM)) (T NUM)))
|
||||
(SETQ NUM (CONS (MUL BINOM (POWER F I)) NUM)
|
||||
DEN (COND ((= END I) DEN)
|
||||
(T (CONS (MUL (SETQ BINOM (quotient (times (* FLAG (- END I)) BINOM) (1+ I)))
|
||||
(POWER F (1+ I)))
|
||||
DEN))))))
|
||||
|
||||
(DEFUN COT-TIMES (L N F FLAG)
|
||||
(SETQ F (CONS-EXP F (CONS '(MTIMES) L)))
|
||||
(DO ((I (ABS N) (- I 2)) (END (ABS N)) (NUM) (DEN)
|
||||
(BINOM 1 (quotient (times (* FLAG (1- I)) BINOM) (- END I -2))))
|
||||
((< I 0) (SETQ NUM (DIV* (CONS '(MPLUS) NUM) (CONS '(MPLUS) DEN)))
|
||||
(IF (MINUSP N) (NEG NUM) NUM))
|
||||
(SETQ NUM (CONS (MUL BINOM (POWER F I)) NUM)
|
||||
DEN (IF (= 0 I) DEN
|
||||
(CONS (MUL (SETQ BINOM (quotient (times I BINOM) (- END I -1))) (POWER F (1- I))) DEN)))))
|
||||
|
||||
(DEFUN CSC\SEC-TIMES (L M N F1 F2 FLAG)
|
||||
(DIV* (MUL (POWER (CONS-EXP F1 (CONS '(MTIMES) L)) (ABS N))
|
||||
(POWER (CONS-EXP F2 (CONS '(MTIMES) L)) (ABS N)))
|
||||
(SIN\COS-TIMES L M N F1 F2 FLAG)))
|
||||
|
||||
(DEFUN MPC (DL UL RESULT F1 F2 DI UI)
|
||||
(COND ((= 0 UI)
|
||||
(CONS (RECONC DL (MAPCAR #'(LAMBDA (L) (CONS-EXP F2 L)) UL))
|
||||
RESULT))
|
||||
((= DI UI)
|
||||
(CONS (RECONC DL (MAPCAR #'(LAMBDA (L) (CONS-EXP F1 L)) UL))
|
||||
RESULT))
|
||||
(T (MPC (CONS (CONS-EXP F1 (CAR UL)) DL) (CDR UL)
|
||||
(MPC (CONS (CONS-EXP F2 (CAR UL)) DL)
|
||||
(CDR UL) RESULT F1 F2 (1- DI) UI) F1 F2
|
||||
(1- DI) (1- UI)))))
|
||||
|
||||
(DEFUN MPC1 (DL UL RESULT F DI UI)
|
||||
(COND ((= 0 UI) (CONS (REVERSE DL) RESULT))
|
||||
((= DI UI)
|
||||
(CONS (RECONC DL (MAPCAR #'(LAMBDA (L) (CONS-EXP F L)) UL)) RESULT))
|
||||
(T (MPC1 (CONS (CONS-EXP F (CAR UL)) DL) (CDR UL)
|
||||
(MPC1 DL (CDR UL) RESULT F (1- DI) UI) F
|
||||
(1- DI) (1- UI)))))
|
||||
|
||||
;; Local Modes:
|
||||
;; Mode: LISP
|
||||
;; Comment Col: 40
|
||||
;; End:
|
||||
|
||||
Reference in New Issue
Block a user