mirror of
https://github.com/PDP-10/its.git
synced 2026-05-04 15:16:32 +00:00
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.
This commit is contained in:
Eric Swenson
279
src/rat/result.34
Executable file
279
src/rat/result.34
Executable file
@@ -0,0 +1,279 @@
|
||||
;; -*- 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))))
|
||||
|
||||
|
||||
|
||||
Reference in New Issue
Block a user