mirror of
https://github.com/PDP-10/its.git
synced 2026-02-08 17:31:17 +00:00
85994ed770
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.
279 lines
8.6 KiB
Common Lisp
Executable File
279 lines
8.6 KiB
Common Lisp
Executable File
;; -*- 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 result)
|
||
|
||
(DECLARE (SPECIAL VARLIST GENVAR $RATFAC $KEEPFLOAT MODULUS *ALPHA XV))
|
||
|
||
(LOAD-MACSYMA-MACROS RATMAC)
|
||
|
||
(DECLARE (SPLITFILE MRESUL))
|
||
|
||
(DEFMFUN $POLY_DISCRIMINANT (POLY VAR)
|
||
(LET* ((VARLIST (LIST VAR))
|
||
(GENVAR ())
|
||
(RFORM (RFORM POLY))
|
||
(RVAR (CAR (LAST GENVAR)))
|
||
(N (PDEGREE (SETQ POLY (CAR RFORM)) RVAR)))
|
||
(COND ((= N 1) 1)
|
||
((OR (= N 0) (NOT (EQUAL (CDR RFORM) 1)))
|
||
(MERROR "Argument must be a polynomial in var"))
|
||
(T (PDIS (PRESIGN
|
||
(// (* N (1- N)) 2)
|
||
(PQUOTIENT (RESULTANT POLY (PDERIVATIVE POLY RVAR))
|
||
(P-LC POLY))))))))
|
||
|
||
(DEFMFUN $RESULTANT (A B MAINVAR)
|
||
(PROG (VARLIST GENVAR $RATFAC $KEEPFLOAT RES ANS)
|
||
(SETQ VARLIST (NCONS MAINVAR) $RATFAC T ANS 1)
|
||
(IF ($RATP A) (SETQ A (RATDISREP A)))
|
||
(IF ($RATP B) (SETQ B (RATDISREP B)))
|
||
(NEWVAR A)
|
||
(NEWVAR B)
|
||
(SETQ A (LMAKE2 (CADR (RATREP* A)) NIL))
|
||
(SETQ B (LMAKE2 (CADR (RATREP* B)) NIL))
|
||
(SETQ MAINVAR (CAADR (RATREP* MAINVAR)))
|
||
(DO L1 A (CDR L1) (NULL L1)
|
||
(DO L2 B (CDR L2) (NULL L2)
|
||
(SETQ RES (RESULT1 (CAAR L1) (CAAR L2) MAINVAR))
|
||
(SETQ ANS (PTIMES ANS (PEXPT
|
||
(COND ((ZEROP (CADDR RES)) (CAR RES))
|
||
(T (PTIMESCHK (CAR RES)
|
||
(PEXPT (MAKPROD (CADR RES) NIL)
|
||
(CADDR RES)))))
|
||
(TIMES (CDAR L1) (CDAR L2)))))))
|
||
(RETURN (PDIS ANS))))
|
||
|
||
(DEFUN RESULT1 (P1 P2 VAR)
|
||
(COND ((OR (PCOEFP P1) (POINTERGP VAR (CAR P1)))
|
||
(LIST 1 P1 (pdegree P2 VAR)))
|
||
((OR (PCOEFP P2) (POINTERGP VAR (CAR P2)))
|
||
(LIST 1 P2 (pdegree P1 VAR)))
|
||
((NULL (CDDDR P1))
|
||
(COND ((NULL (CDDDR P2)) (LIST 0 0 1))
|
||
(T (LIST (PEXPT (CADDR P1) (CADR P2))
|
||
(PCSUBSTY 0 VAR P2)
|
||
(CADR P1)))))
|
||
((NULL (CDDDR P2))
|
||
(LIST (PEXPT (CADDR P2) (CADR P1))
|
||
(PCSUBSTY 0 VAR P1)
|
||
(CADR P2)))
|
||
((> (SETQ VAR (GCD (PGCDEXPON P1) (PGCDEXPON P2))) 1)
|
||
(LIST 1 (RESULTANT (PEXPON*// P1 VAR NIL)
|
||
(PEXPON*// P2 VAR NIL)) VAR))
|
||
(T (LIST 1 (RESULTANT P1 P2) 1))))
|
||
|
||
(DEFMVAR $RESULTANT '$SUBRES "Designates which resultant algorithm")
|
||
|
||
(DEFVAR *resultlist '($subres $mod $red))
|
||
|
||
(DEFMFUN RESULTANT (P1 P2) ;assumes same main var
|
||
(IF (> (P-LE P2) (P-LE P1))
|
||
(PRESIGN (* (P-LE P1) (P-LE P2)) (RESULTANT P2 P1))
|
||
(CASEQ $RESULTANT
|
||
($SUBRES (SUBRESULT P1 P2))
|
||
($MOD (MODRESULT P1 P2))
|
||
($RED (REDRESULT P1 P2))
|
||
(T (MERROR "No such resultant algorithm")))))
|
||
|
||
(DECLARE (SPLITFILE SUBRES))
|
||
;computes resultant using subresultant p.r.s. TOMS Sept. 1978
|
||
|
||
(defun subresult (p q)
|
||
(loop for g = 1 then (p-lc p)
|
||
for h = 1 then (pquotient (pexpt g d) h^1-d)
|
||
for degq = (pdegree q (p-var p))
|
||
for d = (- (p-le p) degq)
|
||
for h^1-d = (if (equal h 1) 1 (pexpt h (1- d)))
|
||
if (zerop degq) return (if (pzerop q) q (pquotient (pexpt q d) h^1-d))
|
||
do (psetq p q
|
||
q (presign (1+ d) (pquotient (prem p q)
|
||
(ptimes g (ptimes h h^1-d)))))))
|
||
|
||
(DECLARE (SPLITFILE REDRES))
|
||
|
||
; PACKAGE FOR CALCULATING MULTIVARIATE POLYNOMIAL RESULTANTS
|
||
; USING MODIFIED REDUCED P.R.S.
|
||
|
||
(DEFUN REDRESULT (U V)
|
||
(PROG (A R SIGMA C)
|
||
(SETQ A 1)
|
||
(SETQ SIGMA 0)
|
||
(SETQ C 1)
|
||
A (IF (PZEROP (SETQ R (PREM U V))) (RETURN (PZERO)))
|
||
(SETQ C (PTIMESCHK C (PEXPT (P-LC V)
|
||
(* (- (P-LE U) (P-LE V))
|
||
(- (P-LE V) (PDEGREE R (P-VAR U))
|
||
1)))))
|
||
(SETQ SIGMA (+ SIGMA (* (P-LE U) (P-LE V))))
|
||
(IF (ZEROP (PDEGREE R (P-VAR U)))
|
||
(RETURN
|
||
(PRESIGN SIGMA
|
||
(PQUOTIENT (PEXPT (PQUOTIENTCHK R A) (P-LE V)) C))))
|
||
(PSETQ U V
|
||
V (PQUOTIENTCHK R A)
|
||
A (PEXPT (P-LC V) (+ (P-LE U) 1 (- (P-LE V)))))
|
||
(GO A)))
|
||
|
||
|
||
(DECLARE (SPLITFILE MODRES))
|
||
|
||
; PACKAGE FOR CALCULATING MULTIVARIATE POLYNOMIAL RESULTANTS
|
||
; USING MODULAR AND EVALUATION HOMOMORPHISMS.
|
||
|
||
(DEFUN MODRESULT (A B)
|
||
(MODRESULT1 A B (SORT (UNION* (LISTOVARS A) (LISTOVARS B))
|
||
(FUNCTION POINTERGP))))
|
||
|
||
(DEFUN MODRESULT1 (X Y VARL)
|
||
(COND ((NULL MODULUS) (PRES X Y (CAR VARL) (CDR VARL)))
|
||
(T (CPRES X Y (CAR VARL) (CDR VARL))) ))
|
||
|
||
(DEFUN PRES (A B XR1 VARL)
|
||
(PROG (M N F A* B* C* P Q C MODULUS HMODULUS)
|
||
(SETQ M (CADR A))
|
||
(SETQ N (CADR B))
|
||
(SETQ F (COEFBOUND M N (MAXNORM (CDR A)) (MAXNORM (CDR B)) ))
|
||
(SETQ Q 1)
|
||
(SETQ C 0)
|
||
(SETQ P *ALPHA)
|
||
(GO STEP3)
|
||
STEP2 (SETQ P (NEWPRIME P))
|
||
STEP3 (SETQMODULUS P)
|
||
(SETQ A* (PMOD A))
|
||
(SETQ B* (PMOD B))
|
||
(COND ((OR (REJECT A* M XR1) (REJECT B* N XR1)) (GO STEP2)))
|
||
(SETQ C* (CPRES A* B* XR1 VARL))
|
||
(SETQMODULUS NIL)
|
||
(SETQ C (LAGRANGE3 C C* P Q))
|
||
(SETQ Q (TIMES P Q))
|
||
(COND ((GREATERP Q F) (RETURN C))
|
||
(T (GO STEP2)) ) ))
|
||
|
||
(DEFUN REJECT (A M XV)
|
||
(NOT (EQN (PDEGREE A XV) M)))
|
||
|
||
(DEFUN COEFBOUND (M N D E)
|
||
(TIMES 2 (EXPT (1+ M) (// N 2))
|
||
(EXPT (1+ N) (// M 2))
|
||
(COND ((ODDP N) (1+ ($ISQRT (1+ M))))
|
||
(T 1))
|
||
(COND ((ODDP M) (1+ ($ISQRT (1+ N))))
|
||
(T 1))
|
||
; (FACTORIAL (PLUS M N)) USED TO REPLACE PREV. 4 LINES. KNU II P. 375
|
||
(EXPT D N)
|
||
(EXPT E M) ))
|
||
|
||
(DEFUN MAIN2 (A VAR EXP TOT)
|
||
(COND ((NULL A) (CONS EXP TOT))
|
||
(T (MAIN2 (CDDR A) VAR
|
||
(MAX (SETQ VAR (PDEGREE (CADR A) VAR)) EXP)
|
||
(MAX (+ (CAR A) VAR) TOT))) ))
|
||
|
||
(DEFUN CPRES (A B XR1 VARL) ;XR1 IS MAIN VAR WHICH
|
||
(COND ((NULL VARL) (CPRES1 (CDR A) (CDR B))) ;RESULTANT ELIMINATES
|
||
(T (PROG (M1 M2 N1 N2 K C D A* B* C* BP XV);XV IS INTERPOLATED VAR
|
||
(DECLARE (FIXNUM M1 N1 K))
|
||
(SETQ M1 (CADR A))
|
||
(SETQ N1 (CADR B))
|
||
STEP2
|
||
(SETQ XV (CAR VARL))
|
||
(SETQ VARL (CDR VARL))
|
||
(SETQ M2 (MAIN2 (CDR A) XV 0 0)) ;<XV DEG . TOTAL DEG>
|
||
(SETQ N2 (MAIN2 (CDR B) XV 0 0))
|
||
(COND ((ZEROP (+ (CAR M2) (CAR N2)))
|
||
(COND ((NULL VARL) (RETURN (CPRES1 (CDR A) (CDR B))))
|
||
(T (GO STEP2)) ) ))
|
||
(SETQ K (1+ (MIN (+ (* M1 (CAR N2)) (* N1 (CAR M2)))
|
||
(+ (* M1 (CDR N2)) (* N1 (CDR M2))
|
||
(- (* M1 N1))) )))
|
||
(SETQ C 0)
|
||
(SETQ D 1)
|
||
(SETQ M2 (CAR M2) N2 (CAR N2))
|
||
(SETQ BP (MINUS 1))
|
||
STEP3
|
||
(COND ((EQUAL (SETQ BP (ADD1 BP)) MODULUS)
|
||
(merror "Resultant primes too small."))
|
||
((ZEROP M2) (SETQ A* A))
|
||
(T (SETQ A* (PCSUBST A BP XV))
|
||
(COND ((REJECT A* M1 XR1)(GO STEP3)) )) )
|
||
(COND ((ZEROP N2) (SETQ B* B))
|
||
(T (SETQ B* (PCSUBST B BP XV))
|
||
(COND ((REJECT B* N1 XR1) (GO STEP3))) ))
|
||
(SETQ C* (CPRES A* B* XR1 VARL))
|
||
(SETQ C (LAGRANGE33 C C* D BP))
|
||
(SETQ D (PTIMESCHK D (LIST XV 1 1 0 (CMINUS BP))))
|
||
(COND ((> (CADR D) K) (RETURN C))
|
||
(T (GO STEP3))) )) ))
|
||
|
||
|
||
(DECLARE (SPLITFILE BEZOUT))
|
||
|
||
;; Note that the matrix produced is always symmetric about the minor diagonal.
|
||
|
||
(DEFMFUN $BEZOUT (P Q VAR)
|
||
(LET ((VARLIST (LIST VAR)) GENVAR)
|
||
(NEWVAR P)
|
||
(NEWVAR Q)
|
||
(SETQ P (RATREP* P) Q (RATREP* Q))
|
||
(IF (NOT (AND (EQUAL (CDDR P) 1)
|
||
(> (PDEGREE (CADR P) (CAR (LAST GENVAR))) 0)))
|
||
(IMPROPER-ARG-ERR P '$BEZOUT))
|
||
(IF (NOT (AND (EQUAL (CDDR Q) 1)
|
||
(> (PDEGREE (CADR Q) (CAR (LAST GENVAR))) 0)))
|
||
(IMPROPER-ARG-ERR Q '$BEZOUT))
|
||
(SETQ P (CADR P) Q (CADR Q))
|
||
(SETQ P (IF (> (CADR Q) (CADR P)) (BEZOUT Q P) (BEZOUT P Q)))
|
||
(CONS '($MATRIX)
|
||
(MAPCAR #'(LAMBDA (L) (CONS '(MLIST) (MAPCAR #'PDIS L))) P))))
|
||
|
||
(DEFUN VMAKE (POLY N *L)
|
||
(DO I (1- N) (1- I) (MINUSP I)
|
||
(COND ((OR (NULL POLY) (< (CAR POLY) I))
|
||
(SETQ *L (CONS 0 *L)))
|
||
(T (SETQ *L (CONS (CADR POLY) *L))
|
||
(SETQ POLY (CDDR POLY)))))
|
||
(NREVERSE *L))
|
||
|
||
(DEFUN BEZOUT (P Q)
|
||
(LET* ((N (1+ (P-LE P)))
|
||
(N2 (- N (P-LE Q)))
|
||
(A (VMAKE (P-TERMS P) N NIL))
|
||
(B (VMAKE (P-TERMS Q) N NIL))
|
||
(AR (REVERSE (NTHCDR N2 A)))
|
||
(BR (REVERSE (NTHCDR N2 B)))
|
||
(L (NZEROS N NIL)))
|
||
(RPLACD (NTHCDR (1- (P-LE P)) A) NIL)
|
||
(RPLACD (NTHCDR (1- (P-LE P)) B) NIL)
|
||
(NCONC
|
||
(MAPCAR
|
||
#'(LAMBDA (AR BR)
|
||
(SETQ L (MAPCAR #'(LAMBDA (A B L)
|
||
(PPLUSCHK L (PDIFFERENCE
|
||
(PTIMES BR A) (PTIMES AR B))))
|
||
A B (CONS 0 L))))
|
||
AR BR)
|
||
(AND (PZEROP (CAR B))
|
||
(DO ((B (VMAKE (CDR Q) (CADR P) NIL) (ROT* B))
|
||
(M NIL (CONS B M)))
|
||
((NOT (PZEROP (CAR B))) (CONS B M))))) ))
|
||
|
||
(DEFUN ROT* (B) (SETQ B (COPY1 B)) (PROG2 (NCONC B B) (CDR B) (RPLACD B NIL)))
|
||
|
||
(DEFUN PPLUSCHK (P Q) (COND ((PZEROP P) Q) (T (PPLUS P Q))))
|
||
|
||
|
||
|