github.com/PDP-10.its
1
0
Fork 0
mirror of https://github.com/PDP-10/its.git synced 2026-03-25 01:47:08 +00:00
Code Issues Releases Wiki Activity
Files
190ffa27bdce042bb81dae1b441ecf61076906c8
PDP-10.its/src/paulw/eez.62
Eric Swenson 85994ed770 Added files to support building and running Macsyma. 
Resolves #284.

Commented out uses of time-origin in maxtul; mcldmp (init) until we
can figure out why it gives arithmetic overflows under the emulators.

Updated the expect script statements in build_macsyma_portion to not
attempt to match expected strings, but simply sleep for some time
since in some cases the matching appears not to work.
2018-03-11 13:10:19 -07:00

310 lines
11 KiB
Common Lisp
Raw Blame History

This file contains invisible Unicode characters
This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.
;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma; Ibase: 10 -*- ;;;;;;;;;;;;;
;;; (c) Copyright 1980 Massachusetts Institute of Technology ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(macsyma-module eez)
;; This is the new EEZ-GCD package. It needs the new factoring
;; routines contained in PAULW;NEWFAC >
(EVAL-WHEN (EVAL COMPILE)
(SETQ OLD-IBASE IBASE OLD-BASE BASE)
(SETQ IBASE 10. BASE 10.))
(DECLARE (*LEXPR $FACTOR)
(SPECIAL *OD* *SIGN PRIMELIST* $GCD LAST-GOOD-PRIME
*DL LCFV* V/# *VBV* FL1
GV* BLIST* VECL BIGPRIMES *VBV* BLIST* *FL1 *PL1
POLY FACFUD*
$PAL $PAQ BLIST* *BOUND *ABL* *INI1* *ABLN* *FMSQ* *WIN* *MIN* *MX* *EXTRA *PL1 *FL1 *ODR* SMALLPRIMES MP* *OLDL NL* POLY UPOLY FACFUD* NPOLY* POL* LCV* LC LCD* LCF* *AB *PRODL *FACTL DFL *FPT LOW* MXD* *STOP* THR* TRA* TRL* *XN $FACTORFLAG /#CONT SUBVAR1
SUBVAL1 TELLRATLIST GAUSS VAR MPLC* MCFLAG
MONIC* ALGFAC* INTBS* ADN* MM* MINPOLY* ALPHA
$FACTORFLAG *PRIME *G* ADEG* MODULU* FEEDBACK NEGFLAG PQ PLIM
LISTELM $EZGCDSWITCH MANY* *INL3 LIMK SPLIT* ALC
MPRIME *MOSESFLAG ALFLAG IND ERRRJFFLAG MODULUS
HMODULUS VARLIST GENVAR $ALGEBRAIC TH L DOSIMP *ALPHA)
(ARRAY* (FIXNUM AFIXN 2 FCTCFIXN 1 INVCFIXN 1))
(FIXNUM ADEG*)
(GENPREFIX FCT) (FIXNUM (LOG2)))
(SETQ *FMSQ* NIL GAUSS NIL *F* NIL G%I NIL M%I NIL MINPOLY* NIL MPLC* NIL)
(DECLARE (SPECIAL MODULUS HMODULUS MPRIME *I* MCFLAG NN*-1 ELM NE RES FACT1
FACT2 SUBVAR SUBVAL OVARLIST VALIST VARLIST DLP NN* ZL
GENVAR DBL))
(DECLARE (SPECIAL *BCOEF *PRIME NN* DN* FCS* MODULU* NEGFLAG OVARLIST VALIST
DLP ERRRJFFLAG MPRIME MANY* UU* LIMK MODULUS HMODULUS VAR XX
VARLIST GENVAR MCFLAG PLIM)
(GENPREFIX NFA))
(DEFUN EEZGCD(P1 P2)
(PROG (GCC GC P1C P2C)
(COND ((AND (ONEVARP P1) (ONEVARP P2))(RETURN(NEWGCD P1 P2 MODULUS)))
(MODULUS (merror "EEZ-GCD CURRENTLY ONLY TAKES GCD OVER THE INTEGERS")))
(SETQ P1 (FACTOROUT P1) P2 (FACTOROUT P2))
(COND ((OR (NULL (CAR P1)) (NULL (CAR P2))) (SETQ GCC 1.))
(T (SETQ GCC(OUTGCD (CAR P1) (CAR P2)))))
(SETQ P1 (CADR P1) P2 (CADR P2))
(SETQ P1 (EZCONTENT P1 (CAR P1))P2 (EZCONTENT P2 (CAR P2)))
(SETQ P1C (CAR P1) P1 (CADR P1) P2C (CAR P2) P2 (CADR P2))
(COND ((NOT(OR (EQUAL P1C 1.)(EQUAL P2C 1.))) (SETQ GCC (PTIMES GCC(PGCD P1C P2C)))))
(COND ((AND (ONEVARP P1)(ONEVARP P2))(SETQ GC (CAR(NEWGCD P1 P2 MODULUS))))
(T (SETQ GC (CAR(EEZGCDM P1 P2 GENVAR)))))
(RETURN (LIST(PTIMES GCC GC)))))
(DEFUN EEZGCDM (P1 P2 GENVAR)
(PROG (MONIC* *SIGN GCDRULE L COMD MANY* ALGFAC* MODULU* MODULUS /#CONT *MIN* *MX* *STOP* *ODR* NL* ONE LCD* LCF* LCV* MXD* LOW* *PRIME LC1 LC2 GCDLC P0 UFAC *INL3 *I* NN* LC LIMK ELM LISTELM PLIM NE VAR VALIST VAL1
OVARLIST POL* SUBVAR SUBVAL DLP)
(COND ((EQUAL P1 P2)(RETURN (LIST P1)))
((OR (ONEVARP P1) (ONEVARP P2)) (SETQ ONE T)))
(SETQ VAR (CAR P1) ELM (UNION* (LISTOVARS P1) (LISTOVARS P2))
GENVAR (INTERSECT GENVAR ELM)
OVARLIST (REVERSE (CDR (REVERSE GENVAR)))
NN* (1+ (LENGTH OVARLIST)))
(SETQ /#CONT 1. MANY* T)
(SETQ LISTELM 0.)
(SETQ LC1 (CADDR P1) LC2 (CADDR P2))
(COND ((AND (EQUAL LC1 1.)(EQUAL LC2 1))(SETQ MONIC* T)))
(SETQ GCDLC (PGCD LC1 LC2))
(COND((NUMBERP GCDLC) (SETQ NL* GCDLC))
(T (SETQ LCF*(PFACTOR GCDLC) LCD* (ODDELM (CDR LCF*)) LCF* (ODDELM LCF*))))
(COND((NUMBERP (CAR LCF*))(SETQ NL*(CAR LCF*) LCF* (CDR LCF*) LCD* (CDR LCD*)))
((NULL NL*) (SETQ NL* 1)))
(SETQ ELM 1. *I* 1. NE 1.)
(SETQ *ODR*(PUTODR (REVERSE OVARLIST)))
(SETQ SUBVAR OVARLIST)
(SETQ SUBVAL(EEZSUBST LCF* P1 P2 LC1 LC2))
(COND ((NULL SUBVAL) (RETURN (LIST 1.)))
((NULL (CDR SUBVAL)) (RETURN SUBVAL)))
(SETQ /#CONT (CADR SUBVAL) UFAC (CADDR SUBVAL)*PRIME (CADDDR SUBVAL) SUBVAL (CAR SUBVAL))
(COND ((= (LENGTH UFAC) 3.)(SETQ COMD T)
(SETQ P0 (CAAR UFAC) POLY (CADAR UFAC) L (CADR UFAC) GCDRULE (CADDR UFAC)
UFAC (EXTR L)))
(T (SETQ P0 (CAR UFAC)POLY(CADR UFAC) UFAC (CDDR UFAC))))
(COND(ONE (RETURN (LIST (CAR UFAC)))))
(FIXVL0 SUBVAR SUBVAL (REVERSE OVARLIST))
(COND (LCF* (SETQ VAL1(MAPCAR (FUNCTION CADDR) UFAC))
(LCSP /#CONT(CONS (CAR VAL1) (CDDR VAL1)))
; IMPOSE LC OF "COFACTOR" (SHOULD WORK FOR COMD CASE ALSO)
(SETQ LCF*(CONS (CAR LCF*) (CONS (PQHK (CADDR POLY) LCF*)(CDR LCF*))))
(SETQ LCV*(MAPCAR (FUNCTION(LAMBDA(X)(PCSUBSTY VALIST OVARLIST X))) LCF*))
(SETQ VAL1(MAPCAR(FUNCTION CQUOTIENT) LCV* VAL1))
(SETQ UFAC(MAPCAR(FUNCTION PCTIMES) VAL1 UFAC))))
(SETQ LCV* NIL VAL1 NIL)
(SETQ LIMK (KLIM P0 *PRIME))
(SETQ POLY (NCPBER3
(COND (*SIGN (PCTIMES -1 POLY))(T POLY)) UFAC /#CONT LC))
(COND (COMD (SETQ POLY (LIST(MAKGCD POLY L GCDRULE))))
(T (SETQ POLY (LIST (CAR POLY)))))
(RETURN POLY)))
(DEFUN OUTGCD (L1 L2)
(PROG (GC A)
(SETQ GC 1.)
LOOP (COND ((NULL L1) (RETURN GC))
((SETQ A (MEMBER (CAR L1) L2))
(SETQ GC (PTIMES GC (PEXPT (CAR L1) (MIN (CADR L1) (CADR A)))))))
(SETQ L1 (CDDR L1))(GO LOOP)))
(DEFUN PQHK (A L)
(PROG ()
LOOP (COND ((NULL L) (RETURN A)))
(SETQ A (PQUOTIENT A (CAR L)) L (CDR L))
(GO LOOP)))
(DEFUN INIVEC (N)
(NCDR (REVERSE SMALLPRIMES) (1+(-(LENGTH SMALLPRIMES) N))))
(DEFUN EEZSUBST (LCF P1 P2 LC1 LC2)
(PROG (NM U1 /#CONT U2 UPL TRBL NTERMS NTERMSMX L GCDRULE NOTRBL D1 D2 D0 *OLDL Q1 Q2 A B LC MP* LCV UFAC POSS CONT *INL3 M N MODULUS)
(SETQ A (INIVEC(LENGTH SUBVAR)) B SUBVAR)
(SETQ MP* 3. *OLDL (CONS A *OLDL))
(SETQ NM(1+ (CADR P1)) )
(SETQ *INL3 T N (LENGTH A))
LOOP
(COND ((OR(EQUAL 0. (PCSUBSTY A B LC1))
(EQUAL 0. (PCSUBSTY A B LC2)))(GO INL)))
(COND((OR MONIC*(NULL LCF)) (GO ON))
((SETQ LCV (LCCHECK A B LCF))NIL)(T (GO INL)))
ON ((LAMBDA (MODULUS) (SETQ U1 (PCSUBSTY A B P1) U2 (PCSUBSTY A B P2))) NIL)
(COND (MONIC* (SETQ /#CONT 1.))
((EQUAL(SETQ /#CONT(CGCD (CAR(OLDCONTENT U1)) (CAR(OLDCONTENT U2)))) 1.)NIL)
(T(SETQ U1 (PCQUOTIENT U1 /#CONT) U2 (PCQUOTIENT U2 /#CONT))))
(COND ((AND LCF(NOT(CNTCHK (TIMES /#CONT NL*) LCV)))(GO INL)))
(GO UNI)
INL (SETQ A (NINCREASELIST A N))
(GO LOOP)
UNI
(SETQ D0((LAMBDA($GCD GENVAR)(PGCDCOFACTS U1 U2))'$MOD (LIST VAR)))
(SETQ Q1 (CADR D0) Q2 (CADDR D0) D0 (CAR D0))
(COND ((NUMBERP D0)(RETURN (LIST 1)))
((NUMBERP Q1)(COND((TESTDIVIDE P2 P1)(RETURN (LIST P1)))(T (GO INL))))
((NUMBERP Q2)(COND((TESTDIVIDE P1 P2)(RETURN (LIST P2)))(T (GO INL)))))
(COND ((EQUAL 1.(CAR((LAMBDA(GENVAR $GCD) (SETQ D1(PGCDCOFACTS D0 Q1)))(LIST VAR) '$MOD))) (SETQ NOTRBL T)(SETQ UFAC (LIST U1 P1 D0 Q1)))
((EQUAL 1.(CAR((LAMBDA(GENVAR $GCD) (SETQ D2(PGCDCOFACTS D0 Q2)))(LIST VAR) '$MOD)))(SETQ NOTRBL T) (SETQ UFAC (LIST U2 P2 D0 Q2)))
(NOTRBL (GO INL))
((> (CADR (CAR D2)) (CADR (CAR D1)))(SETQ UFAC (LIST U1 P1 D1) TRBL T))
(T(SETQ UFAC (LIST U2 P2 D2) TRBL T)))
(SETQ M (CADR D0)NTERMS (+ (LENGTH D0) (LENGTH (CADDDR UFAC))))
(COND
((< M NM)(SETQ NM M NTERMSMX NTERMS POSS (LIST LCV A /#CONT UFAC LAST-GOOD-PRIME) CONT 1))
((= M NM)(SETQ CONT (1+ CONT))
(COND((AND TRBL NOTRBL) (SETQ TRBL NIL POSS (LIST LCV A /#CONT UFAC LAST-GOOD-PRIME)))
(( > NTERMS NTERMSMX)(SETQ NTERMSMX NTERMS POSS (LIST LCV A /#CONT UFAC LAST-GOOD-PRIME)))
((GREATERP (CADDR POSS) /#CONT)(SETQ POSS(LIST LCV A /#CONT UFAC LAST-GOOD-PRIME))))
(COND ((= CONT 2.)
(COND (NOTRBL (SETQ LCV*(CAR POSS))(RETURN (CDR POSS)))(T (GO SPCASE)))))))
(SETQ A (MAPCAR (FUNCTION MINUS) A))
(COND ((MEMBER A *OLDL)(GO INL))(T (GO LOOP)))
SPCASE
(SETQ UFAC (CADDDR POSS) UPL (LIST(CAR UFAC) (CADR UFAC)) UFAC (CADDR UFAC))
(SETQ L (LIST (CONS(CADR UFAC) 1)
(CONS(CADDR UFAC) 1) (CONS (CAR UFAC) 2)))
(SETQ GCDRULE (LIST (CONS 1 1) (CONS 3 1)))
(MAKEPRIME L GCDRULE)
(SETQ LCV* (CAR POSS)POSS (CDR POSS))
(RPLACA (CDDR POSS) (LIST UPL L GCDRULE))
(RETURN POSS)))
(DEFUN MAKGCD (ML L RULE)
(PROG (ANS E I EXP Q)
(SETQ ANS 1. I 0.)
LOOP (COND ((NULL L)(RETURN ANS)))
(SETQ E (CAR L) I (1+ I))
(COND ((EQUAL (CAR E) 1.)NIL)
((EQUAL (CAR E) -1)NIL)
(T
(COND ((SETQ EXP (CDR (ASSOC I RULE)))
(SETQ Q (COND ((= (REMAINDER (CDR E) EXP) 0.) (PNTHROOT (CAR ML) (// (CDR E) EXP)))
(T (PEXPT(PNTHROOT(CAR ML)(CDR E))EXP))))
(SETQ ANS (PTIMES ANS Q))))
(SETQ ML (CDR ML))))
(SETQ L (CDR L))
(GO LOOP)))
;(DEFUN EEZMODSET (P A B)
;(PROG(L *BOUND)
;(SETQ L BIGPRIMES *BOUND 400.)
;LOOP
;(SETQ MODULUS (CAR L)L (CDR L))
;(COND ((EQUAL 1. (PGCDU A B))(GO ON)))
;(GO LOOP)
;ON(NFCOEFBOUND P)
;(SETQ *PRIME MODULUS)
;(SETQ LIMK(KLIM *PRIME))))
;(DEFUN NFCOEFBOUND(U) ;redefines func in rat3c?
; (PROG ()
; (SETQ *BOUND (MAXCOEFFICIENT U))
; (SETQ *BOUND (TIMES 5. *BOUND))
; (COND (ALGFAC*(SETQ *BOUND (TIMES *BOUND INTBS*))))
; (COND ((LESSP *BOUND 1000.) (SETQ *BOUND 1000.)))))
; INITIAL VALUE OF L IS ((D1 . 1) (A1 . 1)(D2 . 2))
; AND GCDRULE IS ((1(POSITION) . 1(POWER))(3 . 1))
(DEFUN MAKEPRIME(L GCDRULE)
(PROG(N PR PRIMELIST* A B R S DVS M)
(SETQ N (LENGTH L) M N)
LOOP(SETQ PR (CONS N N))
NEXTPR
(COND ((NEXTPAIR PR) NIL)
((> M N) (SETQ N M) (GO LOOP))
(T (RETURN L)))
(SETQ A (NTH (1-(CAR PR))L ) B (NTH (1-(CDR PR))L ))
(COND ((OR (EQUAL (CAR A) 1.) (EQUAL (CAR B) 1.)) (GO ON)))
(SETQ DVS ((LAMBDA(GENVAR $GCD)(PGCDCOFACTS (CAR A) (CAR B))) (LIST VAR) '$MOD))
(COND ((EQUAL(CAR DVS) 1.) (GO ON)))
(RPLACA A (CADR DVS))
(RPLACA B (CADDR DVS))(SETQ DVS (CAR DVS))
(NCONC L (LIST (CONS DVS (+ (CDR A) (CDR B)))))
(SETQ M (1+ M))
(SETQ R (CDR (ASSOC (CAR PR) GCDRULE)) S (CDR (ASSOC (CDR PR) GCDRULE)))
(COND ((NULL R) (SETQ R 0.)))
(COND ((NULL S)(SETQ S 0.)))
(NCONC GCDRULE (LIST (CONS M (+ R S))))
ON (SETQ PRIMELIST* (CONS (COPY PR) PRIMELIST*))
(GO NEXTPR)))
(DEFUN NEXTPAIR(PR)
(PROG()
LOOP
(COND((> (CDR PR) 1.)
(RPLACD PR (1- (CDR PR))))
((> (CAR PR) 2.)
(RPLACD PR (1-(1-(CAR PR))))
(RPLACA PR (1- (CAR PR))))
(T (RETURN NIL)))
(COND((MEMBER PR PRIMELIST*)(GO LOOP))
(T(RETURN PR)))))
(DEFUN EXTR(L)
(PROG(ANS E IND)
LOOP
(COND ((NULL L)(SETQ *SIGN IND)(RETURN (NREVERSE ANS))))
(SETQ E (CAR L) L (CDR L))
(COND ((EQUAL (CAR E) 1.)NIL)
((EQUAL (CAR E) -1)(SETQ IND (NOT IND)))
(T (SETQ ANS (CONS(PEXPT(CAR E) (CDR E)) ANS))))
(GO LOOP)))
(DEFUN UNEXTR(ML L)
(PROG(DL E)
(SETQ DL L)
LOOP
(COND ((NULL L)(RETURN DL)))
(SETQ E (CAR L))
(COND ((EQUAL (CAR E) 1.)NIL)
((EQUAL (CAR E) -1)NIL)
(T(RPLACA L (LIST(PNTHROOT(CAR ML)(CDR E))))(SETQ ML (CDR ML))))
(SETQ L (CDR L))
(GO LOOP)))
(DEFUN EZCONTENT (P V) ;NOT CALLED CURRENTLY
(PROG (R COEFL DEGL ALLVARS) ;Actually look at PAULW;EEZ
(COND ((NUMBERP P) (RETURN (LIST P 1)))
((EQUAL V (CAR P)) NIL) (T (RETURN (LIST P 1.))))
(SETQ ALLVARS (LISTOVARS P))
(DELETE V ALLVARS)
(COND ((< (LENGTH ALLVARS) 2) (RETURN (OLDCONTENT P))))
(COND ((EQUAL 1 (CADDR P))
(RETURN (LIST 1 P))))
(SETQ R (CDDDR P)
DEGL (LIST (CADR P))
COEFL (LIST (CADDR P)))
(COND ((NULL R)
(RETURN (LIST (CAR COEFL)
(LIST V (CAR DEGL) 1)))))
LOOP (COND ((EQUAL 1 (CADR R)) (RETURN (LIST 1 P))))
(SETQ DEGL (CONS (CAR R) DEGL))
(SETQ COEFL (CONS (CADR R) COEFL))
(COND ((SETQ R (CDDR R)) (GO LOOP)))
(SETQ ALLVARS (REVERSE (INTERSECT GENVAR ALLVARS)))
(SETQ COEFL (EZGCD COEFL ALLVARS MODULUS))
(DO ((L (CDR COEFL) (CDR L))
(DEGL DEGL (CDR DEGL)))
((NULL L) (SETQ R (CONS V R)))
(SETQ R (CONS (CAR DEGL) (CONS (CAR L) R))))
(COND ((PMINUSP R) (RETURN (LIST (PMINUS (CAR COEFL))
(PMINUS R))))
(T (RETURN (LIST (CAR COEFL) R))))))
(EVAL-WHEN (EVAL COMPILE)
(SETQ BASE OLD-BASE IBASE OLD-IBASE))
Reference in New Issue View Git Blame Copy Permalink