github.com/PDP-10.its
1
0
Fork 0
mirror of https://github.com/PDP-10/its.git synced 2026-01-28 21:01:16 +00:00
Code Issues Releases Wiki Activity

Resolves #977: ALGSYS updated with correct version.

Browse Source
This commit is contained in:
Eric Swenson
2018-06-18 15:29:51 -07:00
parent 8972415bc1
commit e6b5d81f40
2 changed files with 16 additions and 951 deletions
Download Patch File Download Diff File Expand all files Collapse all files

19
src/rat/algsys.1 → src/rat/algsys.150 Normal file → Executable file
View File

@@ -1,6 +1,18 @@
;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;;
;;; (c) Copyright 1981 Massachusetts Institute of Technology ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; -*- 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 algsys)
(load-macsyma-macros ratmac)
@@ -500,3 +512,4 @@
(cond ((null l2) nil)
((member (car l2) l1) (exclude l1 (cdr l2)))
(t (append (list (car l2)) (exclude l1 (cdr l2))))))


948
src/rat/algsys.480
View File

@@ -1,948 +0,0 @@
;;*(SETSYNTAX '/" 322. NIL)
(DECLARE (SPECIAL $GRINDSWITCH MAXNOFTRS BAKEQNS $ALGDELTA EQUATIONS $RATEPSILON
$ALGEPSILON B DN UP VARXLIST $KEEPFLOAT PARAM VAR GENVAR
VARLIST EPS *MAX *VAR EXTRAPARAM TVARXLIST *ROOTS *FAILURES
$RATPRINT FTRDFLAG $NUMER $RATFAC)
(*FEXPR $EV )
(GENPREFIX ALG))
(SETQ BAKEQNS NIL)
(DEFUN PZEROP MACRO (L) (LIST 'SIGNP 'E (CADR L)))
(DEFUN ERLIST MACRO (L)
(PROG (X)
(COND ((NOT (EQ (CAADR L) 'QUOTE))
(RETURN (CONS 'ERLIST1 (CDR L))))
((NOT (ATOM (SETQ X (CADADR L))))
(SETQ X (MAPCAR
'(LAMBDA (Y) (LIST 'QUOTE
(CONS '/ (EXPLODEC Y))))
X))
(SETQ X (MAKNAM (CDR (EVAL (CONS 'NCONC X)))))))
(RETURN (LIST 'PROG2
(LIST 'PRINC (LIST 'QUOTE X))
'(ERR)))))
(DEFUN DELET MACRO (Q)
(LIST 'DELETE (CADR Q) (LIST 'APPEND (CADDR Q) NIL)))
(DEFUN $ALGSYS (LHSLIST VARXLIST)
(PROG (TLHSLIST TVARXLIST EXTRAPARAM TEMPSOLNL SOLNLIST $RATPRINT
$RATEPSILON FTRDFLAG $KEEPFLOAT VARLIST GENVAR $RATFAC)
(SETQ GENVAR (LIST 0))
(COND ((OR (AND (NOT ($LISTP LHSLIST))
(PROG2 (DISPLA LHSLIST) T))
(AND (NOT ($LISTP VARXLIST))
(PROG2 (DISPLA VARXLIST) T)))
(ERLIST '(WRONG TYPE ARG TO ALGSYS))))
(SETQ LHSLIST (MAPCAR 'MEQHK LHSLIST))
(SETQ $RATEPSILON 1.0E-7 )
(SETQ TLHSLIST (MAPCAR (FUNCTION CADR)
(MAPCAR (FUNCTION RATF) (CDR LHSLIST))))
(DO VARL (CDR VARXLIST) (CDR VARL) (NULL VARL)
(COND ((MNUMP (CAR VARL))
(DISPLA (CAR VARL)) (ERLIST '(UNACCEPTABLE VARIABLE TO ALGSYS)))))
(SETQ TVARXLIST (MAPCAR (FUNCTION CAADR)
(MAPCAR (FUNCTION RATF) (CDR VARXLIST))))
(SETQ EXTRAPARAM (EXCLUDE VARXLIST (ALLVARS (CDR LHSLIST))))
(COND ($GRINDSWITCH (GO GRIND)))
(COND
(EXTRAPARAM
(DISPLA
(LIST '(MTEXT)
'UNDETERMINED/ PARAMETER/(S/)/ IN/ THE/ SYSTEM/ :/
(CONS '(MLIST) EXTRAPARAM)))
(PRINC '/
REDUCED/ SYSTEM/(S/):/
) (RETURN (REDUCESYS TLHSLIST TVARXLIST))))
GRIND (SETQ TEMPSOLNL (ALGSYS TLHSLIST TVARXLIST))
(SETQ TEMPSOLNL (MAPCAR (FUNCTION ROUNDROOTS1) TEMPSOLNL))
(SETQ TEMPSOLNL (CONDENSESOLNL TEMPSOLNL NIL))
(SETQ TEMPSOLNL (MAPCAR (FUNCTION ADDPARAM) TEMPSOLNL))
(PUTORDER TVARXLIST)
(SETQ TEMPSOLNL (MAPCAR (FUNCTION BBSORTEQNS) TEMPSOLNL))
(REMORDER TVARXLIST)
(SETQ SOLNLIST (MAPCAR (FUNCTION ADDMLIST) TEMPSOLNL))
;*** REMOVED CALL TO TRUESOLNS
;*** (SETQ SOLNLIST (CONDENSEY SOLNLIST)) NO LONGER NEEDED
(COND ((AND SOLNLIST (NULL (CDR SOLNLIST)))
(SETQ SOLNLIST (LIST (CAR SOLNLIST)))))
(SETQ SOLNLIST (ADDMLIST SOLNLIST))
(RETURN SOLNLIST)))
(DEFUN SUBSET (S1 S2)
(COND ((NULL S1) T)
((MEMBER (CAR S1) S2)
(SUBSET (CDR S1) S2))
(T NIL)))
(DEFUN CONDENSESOLNL (TEMPSOLNL SOLNL)
(SETQ TEMPSOLNL (SORT TEMPSOLNL '(LAMBDA (A B) (> (LENGTH A) (LENGTH B)))))
(DO A TEMPSOLNL (CDR A) (NULL A)
(DO ((B (CDR A) (CDR B)))
((NULL B) (SETQ SOLNL (CONS (CAR A) SOLNL)))
(COND ((SUBSET (CAR B) (CAR A)) (RETURN NIL)))))
SOLNL)
(DEFUN ALGSYS (TLHSLIST TVARXLIST)
(COND
((NULL TLHSLIST) NIL)
(T (PROG (LINEQN LINLHS LINVAR LINSOLN NLHSLIST TSOLNLIST
SOLNLIST TSOLN SOLN MAXNOFTRS TGENVAR TVARLIST)
(SETQ LINEQN (FINDLINVAR TLHSLIST TVARXLIST))
(COND ((NULL LINEQN)
(COND (FTRDFLAG (RETURN (RESULTANTCASE TLHSLIST
TVARXLIST)))
(T (RETURN (FACTORCASE TLHSLIST TVARXLIST))))))
(SETQ LINLHS (CAR LINEQN))
(SETQ LINVAR (CADR LINEQN))
(SETQ TGENVAR GENVAR TVARLIST VARLIST)
(SETQ LINSOLN (ISLINEAR (PDIS LINLHS)(PDIS (LIST LINVAR 1 1))))
(OR LINSOLN (ERLIST '(ALGSYS ERROR - GENERATED NON LINEAR EQUATION)))
(AND (EQUAL (CAR LINSOLN) 0)(ERLIST '(ALGSYS ERROR - GENERATED CONSTANT EQUATION)))
(SETQ LINSOLN (LIST '(MEQUAL)
(PDIS (LIST LINVAR 1 1))
(SIMPTIMES (LIST '(MTIMES) -1 (CDR LINSOLN)
(LIST '(MEXPT) (CAR LINSOLN) -1))
1 NIL)))
(SETQ GENVAR TGENVAR VARLIST TVARLIST)
(SETQ TLHSLIST (REMOVE LINLHS TLHSLIST))
(SETQ TVARXLIST (REMOVE LINVAR TVARXLIST))
(COND ((NULL TLHSLIST) (GO PARAMETRIC)))
(SETQ NLHSLIST (LINSUBST LINSOLN TLHSLIST))
(COND ((NULL NLHSLIST) (GO PARAMETRIC)))
(SETQ FTRDFLAG NIL)
(SETQ TSOLNLIST (ALGSYS NLHSLIST TVARXLIST))
(SETQ SOLNLIST NIL)
LINSOLNLOOP
(COND ((NULL TSOLNLIST) (RETURN SOLNLIST)))
(SETQ TSOLN (APPEND (LIST '(MLIST)) (CAR TSOLNLIST)))
((LAMBDA ($KEEPFLOAT) (SETQ SOLN
(EVAL (CONS '$EV
(LIST LINSOLN
TSOLN
'$RADCAN)))))
T)
(SETQ SOLN (APPEND (LIST SOLN) (CDR TSOLN)))
(SETQ SOLNLIST (APPEND SOLNLIST (LIST SOLN)))
(SETQ TSOLNLIST (CDR TSOLNLIST))
(GO LINSOLNLOOP)
PARAMETRIC
(SETQ SOLNLIST (LIST (LIST LINSOLN)))
(RETURN SOLNLIST)))))
(DEFUN FACTORCASE (TLHSLIST TVARXLIST)
(PROG (NLHSL LHSL LOLHSL SOLNLIST SOLN)
(SETQ NLHSL NIL)
(SETQ MAXNOFTRS 1.)
(SETQ LHSL TLHSLIST)
FTRLOOP
(COND ((NULL LHSL) (GO DIVIDESYS))
(T (SETQ NLHSL (APPEND NLHSL
(LIST (LOFACTORS (CAR LHSL)))))))
(SETQ LHSL (CDR LHSL))
(GO FTRLOOP)
DIVIDESYS
(SETQ FTRDFLAG T)
(COND ((EQUAL MAXNOFTRS 1.) (GO RSTNTCASE)))
(SETQ LOLHSL (DISTREP NLHSL))
(SETQ SOLNLIST NIL)
FACTORSOLNLOOP
(COND ((NULL LOLHSL) (RETURN SOLNLIST)))
(SETQ SOLN (ALGSYS (CAR LOLHSL) TVARXLIST))
(SETQ SOLNLIST (APPEND SOLNLIST SOLN))
(SETQ LOLHSL (CDR LOLHSL))
(GO FACTORSOLNLOOP)
RSTNTCASE
(RETURN (RESULTANTCASE (MAPCAR (FUNCTION CAR) NLHSL)
TVARXLIST))))
(DEFUN RESULTANTCASE (TLHSLIST TVARXLIST)
(PROG (EQNS EQN VARTORID RSTNT NEXTLEVEL SOLN SOLNLIST LOFTRS LOLHSL
VAR MINDEG TVAR TDEG *ROOTS *FAILURES TGENVAR TVARLIST)
(SETQ VARTORID (CAR TVARXLIST))
(SETQ EQN (LEASTDEG TLHSLIST VARTORID))
(SETQ EQNS (DELET EQN TLHSLIST))
(COND ((EQUAL (LENGTH TVARXLIST) 1.)
(RETURN (UNIVARSOLN TLHSLIST VARTORID)))
((NULL EQNS) (GO SOLVEEQNINONEOFTHEVARS)))
RSTNTLOOP
(SETQ RSTNT (PRESULTANT EQN (CAR EQNS) VARTORID))
(COND ((NUMBERP RSTNT)
(COND ((ZEROP RSTNT) (GO GCASE)) (T (GO SKIP)))))
(SETQ NEXTLEVEL (CONS RSTNT NEXTLEVEL))
SKIP (SETQ EQNS (CDR EQNS))
(COND ((NULL EQNS) (GO NEXT)))
(GO RSTNTLOOP)
NEXT (SETQ NEXTLEVEL (REVERSE NEXTLEVEL))
(SETQ NEXTLEVEL (MAPCAR (FUNCTION PSQFR) NEXTLEVEL))
(SETQ NEXTLEVEL (MAPCAR (FUNCTION PTIMEFTRS) NEXTLEVEL))
(SETQ FTRDFLAG NIL)
(SETQ SOLNLIST (ALGSYS NEXTLEVEL (CDR TVARXLIST)))
(RETURN (BAKALEVEL SOLNLIST TLHSLIST VARTORID))
SOLVEEQNINONEOFTHEVARS
(SETQ VAR (CAR TVARXLIST))
(SETQ TVARXLIST (CDR TVARXLIST))
(SETQ MINDEG (PDEGREEY EQN VAR))
LOOP (COND (TVARXLIST (SETQ TVAR (CAR TVARXLIST))
(SETQ TVARXLIST (CDR TVARXLIST))
(SETQ TDEG (PDEGREEY EQN TVAR))
(COND ((LESSP TDEG MINDEG)
(SETQ VAR TVAR)
(SETQ MINDEG TDEG)
(GO LOOP))
(T (GO LOOP)))))
(SETQ EQN (PDIS EQN))
(SETQ VAR (PDIS (LIST VAR 1. 1.)))
(SETQ TGENVAR GENVAR)
(SETQ TVARLIST VARLIST)
(SOLVE EQN VAR 1.)
(SETQ GENVAR TGENVAR)
(SETQ VARLIST TVARLIST)
(COND ((NULL *ROOTS) (RETURN NIL)))
(RETURN (MAPCAR (FUNCTION LIST) (DELETMULT *ROOTS)))
GCASE(SETQ LOFTRS (APPEND (LIST (LOFACTORS EQN))
(LIST (LOFACTORS (CAR EQNS)))))
(SETQ EQNS (MAPCAR (FUNCTION LIST)
(DELET EQN (DELET (CAR EQNS) TLHSLIST))))
(SETQ LOFTRS (APPEND LOFTRS EQNS))
(SETQ LOLHSL (DISTREP LOFTRS))
(SETQ SOLNLIST NIL)
RSTNTSOLNLOOP
(COND ((NULL LOLHSL) (RETURN SOLNLIST)))
(SETQ FTRDFLAG NIL)
(SETQ SOLN (ALGSYS (CAR LOLHSL) TVARXLIST))
(SETQ SOLNLIST (APPEND SOLNLIST SOLN))
(SETQ LOLHSL (CDR LOLHSL))
(GO RSTNTSOLNLOOP)))
(DEFUN REDUCESYS (TLHSLIST TVARXLIST)
(PROG (RDCSYSL USERCMAND SUBSYS PARAML PARAM PARAMVAL PVALUEL I)
(SETQ RDCSYSL (FTRSYS TLHSLIST TVARXLIST))
(DISPLAL RDCSYSL)
(PRINC
'THE/ FOLLOWING/ OPTIONS/ ARE/ AVAILABLE:/
/ / /(1/)/ TYPE/ /"SUBST/;/"/ TO/ SUBSTITUTE/ NUMERICAL/ VALUE/(S/)/ FOR/ THE/
/ / / / / / PARAMETER/(S/)/ AND/ SOLVE/ THE/ SYSTEM/(S/)/ AGAIN/./
/ / /(2/)/ TYPE/ THE/ NUMBER/ N/ /(/"N/;/"/)/,/ CORRESPONDING/ TO/ THE/ N/(TH/)/ SUBSYSTEM/,/
/ / / / / / OR/ /"ALL/;/"/ SO/ THAT/ THE/ N/(TH/)/ OR/ ALL/ OF/ THE/ SUBSYSTEM/(S/)/ WILL/ BE/
/ / / / / / GROUND/ OUT/./
/ / /(3/)/ OTHERWISE/ TYPE/ /"QUIT/;/"/.)
(MTERPRI)
TESTCMAND
(MTERPRI)
(SETQ USERCMAND (RETRIEVE NIL NIL))
(COND ((EQ '$QUIT USERCMAND) (RETURN '$DONE))
((NUMBERP USERCMAND) (GO NTHSUBSYS))
((EQ '$ALL USERCMAND) (GO BAKSOVALL))
((EQ '$SUBSTITUTE USERCMAND) (GO SUBSTPARAM))
(T (RETURN '$DONE)))
NTHSUBSYS
(COND ((> USERCMAND (LENGTH RDCSYSL))
(ERLIST '(INCORRECT RESPONSE - ALGSYS))))
(SETQ SUBSYS (NTH RDCSYSL USERCMAND))
(OUTSOLNS (BAKSOLVE SUBSYS TVARXLIST))
(PRINC
'ARE/ THERE/ ANY/ OTHER/ SUBSYSTEMS/ TO/ BE/ SOLVED?/
IF/ SO/,/ TYPE/ THE/ CORRESPONDING/ SUBSYSTEM/ NUMBER/ FOLLOWED/ BY/ A/ /"/;/"/.)
(GO TESTCMAND)
BAKSOVALL
(SETQ I 0.)
LOOP (COND ((NULL RDCSYSL) (RETURN '$DONE)))
(SETQ SUBSYS (CAR RDCSYSL) RDCSYSL (CDR RDCSYSL))
(MTERPRI)
(PRINC 'SOLUTION/ TO/ SUBSYSTEM/ )
(PRINC (SETQ I (1+ I)))
(PRINC ':)
(MTERPRI)
(OUTSOLNS (BAKSOLVE SUBSYS TVARXLIST))
(GO LOOP)
SUBSTPARAM
(SETQ PARAML EXTRAPARAM)
LOOP1(COND ((NULL PARAML) (GO EVALUATE)))
(MTERPRI)
(SETQ PARAM (CAR PARAML))
(SETQ PARAML (CDR PARAML))
(PRINC 'WHAT/ IS/ THE/ VALUE/ OF/ THE/ UNDETERMINED/ PARAMETER/ )
(COND ((ATOM PARAM) (PRINC (STRIPDOLLAR PARAM)))
(T (DISPLA PARAM)))
(PRINC '/ ?)
(MTERPRI)
(SETQ PARAMVAL (RETRIEVE NIL NIL))
(MTERPRI)
(COND ((NUMBERP PARAMVAL) NIL)
(T (PRINC 'PARAMETER/ VALUE/ SHOULD/ BE/ NUMERICAL)
(MTERPRI)
(SETQ PARAMVAL (RETRIEVE NIL NIL))
(MTERPRI)))
(SETQ PVALUEL (CONS PARAMVAL PVALUEL))
(GO LOOP1)
EVALUATE
(SETQ PVALUEL (REVERSE PVALUEL))
(MBIND EXTRAPARAM PVALUEL)
(SETQ RDCSYSL NIL)
EVLOOP
(COND ((NULL BAKEQNS) (MUNBIND EXTRAPARAM) (GO BAKSOVALL)))
(SETQ SUBSYS (CAR BAKEQNS))
(SETQ BAKEQNS (CDR BAKEQNS))
(SETQ SUBSYS (MAPCAR (FUNCTION RATFEVL) SUBSYS))
(SETQ RDCSYSL (APPEND RDCSYSL (LIST SUBSYS)))
(GO EVLOOP)))
(DEFUN FTRSYS (TLHSLIST TVARXLIST)
(PROG (SUBSYSL NLHSL LHSL LOLHSL SUBSOLN)
(SETQ NLHSL NIL)
(SETQ MAXNOFTRS 1.)
(SETQ LHSL TLHSLIST)
FTRLOOP
(COND ((NULL LHSL) (GO DIVIDESYS))
(T (SETQ NLHSL (APPEND NLHSL
(LIST (LOFACTORS (CAR LHSL)))))))
(SETQ LHSL (CDR LHSL))
(GO FTRLOOP)
DIVIDESYS
(COND ((EQUAL MAXNOFTRS 1.) (GO RSTNTCASE)))
(SETQ LOLHSL (DISTREP NLHSL))
SUBSYSLOOP
(COND ((NULL LOLHSL) (RETURN SUBSYSL)))
(SETQ SUBSOLN (RSTNTSYS (CAR LOLHSL) TVARXLIST))
(SETQ SUBSYSL (APPEND SUBSYSL SUBSOLN))
(SETQ LOLHSL (CDR LOLHSL))
(GO SUBSYSLOOP)
RSTNTCASE
(SETQ NLHSL (MAPCAR (FUNCTION CAR) NLHSL))
(RETURN (RSTNTSYS NLHSL TVARXLIST))))
(DEFUN RSTNTSYS (TLHSLIST TVARXLIST)
(PROG (EQN EQNS VARTORID REDUSYSL RSTNT NEXTLEVEL LOFTRS LOLHSL
SUBSOLN SUBCASES)
(COND ((OR (NULL (CDR TLHSLIST)) (NULL (CDR TVARXLIST)))
(RETURN (LIST (LIST TLHSLIST)))))
(SETQ VARTORID (CAR TVARXLIST))
(SETQ EQN (LEASTDEG TLHSLIST VARTORID))
(SETQ EQNS (DELET EQN TLHSLIST))
(SETQ REDUSYSL (LIST TLHSLIST))
RSTNTLOOP
(SETQ RSTNT (PRESULTANT EQN (CAR EQNS) VARTORID))
(COND ((MEMBER RSTNT NEXTLEVEL) (GO SKIP)))
(COND ((NUMBERP RSTNT)
(COND ((ZEROP RSTNT) (GO GCASE)) (T (GO SKIP)))))
(SETQ NEXTLEVEL (CONS RSTNT NEXTLEVEL))
SKIP (SETQ EQNS (CDR EQNS))
(COND ((NULL EQNS) (GO NEXT)))
(GO RSTNTLOOP)
NEXT (SETQ NEXTLEVEL (REVERSE NEXTLEVEL))
(SETQ NEXTLEVEL (MAPCAR (FUNCTION PSQFR) NEXTLEVEL))
(SETQ NEXTLEVEL (MAPCAR (FUNCTION PTIMEFTRS) NEXTLEVEL))
(RETURN (MAPCAR (FUNCTION (LAMBDA (G) (APPEND REDUSYSL G)))
(RSTNTSYS NEXTLEVEL (CDR TVARXLIST))))
GCASE(SETQ LOFTRS (APPEND (LIST (LOFACTORS EQN))
(LIST (LOFACTORS (CAR EQNS)))))
(SETQ EQNS (MAPCAR (FUNCTION LIST)
(DELET EQN (DELET (CAR EQNS) TLHSLIST))))
(SETQ LOFTRS (APPEND LOFTRS EQNS))
(SETQ LOLHSL (DISTREP LOFTRS))
RSTNTSUBSYS
(COND ((NULL LOLHSL) (RETURN SUBCASES)))
(SETQ EQNS (CAR LOLHSL))
(COND ((NULL (CDR EQNS))
(SETQ SUBSOLN (LIST (LIST EQNS)))
(GO JUMPOVER)))
(SETQ SUBSOLN (RSTNTSYS EQNS TVARXLIST))
(SETQ SUBSOLN
(MAPCAR (FUNCTION (LAMBDA (H) (APPEND (LIST EQNS) H)))
SUBSOLN))
JUMPOVER
(SETQ SUBCASES (APPEND SUBCASES SUBSOLN))
(SETQ LOLHSL (CDR LOLHSL))
(GO RSTNTSUBSYS)))
(DEFUN ADDMLIST (L) (CONS '(MLIST) L))
(DEFUN ROOTSP (ASOLNSET EQN) ;EQN IS ((MLIST) EQ DERIV)
(PROG (RR $KEEPFLOAT $NUMER)
(SETQ $KEEPFLOAT T $NUMER (NOT EXTRAPARAM))
(SETQ RR (EVAL (CONS '$EV
(LIST EQN ASOLNSET )))) ;RATSIMMP?
(COND ((AND (NUMBERP (CADR RR)) (NUMBERP (CADDR RR)))
(RETURN (LESSP (ABS (CADR RR))
(TIMES $ALGDELTA
(MAX 1 (ABS (CADDR RR)))))))
((NUMBERP (SETQ RR ($RADCAN (CADR RR))))
(RETURN (LESSP (ABS RR) $ALGDELTA)))
(T (RETURN NIL)))))
(DEFUN SATISFYSYSP (ASOLNSET SYSEQNL)
(COND ((NULL SYSEQNL) T)
((ROOTSP ASOLNSET (CAR SYSEQNL))
(SATISFYSYSP ASOLNSET (CDR SYSEQNL)))
(T NIL)))
(DEFUN TRUESOLNS (TEMPSOLNL LHSLIST) ;LHSLIST IS ((MLIST) EQN DERIV)
(PROG (SOLNL ASOLNSET)
LOOP (COND ((NULL TEMPSOLNL) (RETURN (REVERSE SOLNL))))
(SETQ ASOLNSET (CAR TEMPSOLNL))
(SETQ TEMPSOLNL (CDR TEMPSOLNL))
(COND ((SATISFYSYSP ASOLNSET LHSLIST)
(SETQ SOLNL (CONS ASOLNSET SOLNL))))
(GO LOOP)))
(DEFUN ROUND (A $RATEPSILON)
(COND ((FLOATP A)
(SETQ A (RATIONALIZE A))
(FPCOFRAT1 (CAR A) (CDR A)))
(T A)))
(DEFUN ROUNDRHS (EQN)
(PROG (RHS)
(SETQ RHS (CADDR EQN))
(COND ((NUMBERP RHS)
(RETURN (LIST (CAR EQN)
(CADR EQN)
(ROUND RHS $RATEPSILON))))
(T (RETURN EQN)))))
(DEFUN ROUNDROOTS1 (LSOLN) (MAPCAR (FUNCTION ROUNDRHS) LSOLN))
(DEFUN ROUNDROOTS (ASOLNSET)
(APPEND (LIST (CAR ASOLNSET)) (ROUNDROOTS1 (CDR ASOLNSET))))
(DEFUN BBSORTEQNS (L) (SORT (APPEND L NIL) 'ORDERLESSP))
(DEFUN PUTORDER (TEMPVARL)
(PROG (N)
(SETQ N 1.)
LOOP (COND ((NULL TEMPVARL) (RETURN NIL))
(T (PUTPROP (CAR TEMPVARL) N 'VARORDER)))
(SETQ N (PLUS N 1.))
(SETQ TEMPVARL (CDR TEMPVARL))
(GO LOOP)))
(DEFUN REMORDER (GVARL)
(MAPC '(LAMBDA(X) (REMPROP X 'VARORDER)) GVARL))
(DEFUN ORDERLESSP (EQN1 EQN2)
(COND ((LESSP (GET (CAADR (RATF (CADR EQN1))) 'VARORDER)
(GET (CAADR (RATF (CADR EQN2))) 'VARORDER))
T)
(T NIL)))
(DEFUN ADDPARAM (ASOLNSETL)
(PROG (PARAMLIST TVARXL L1 EQN PARAM VAR ASOLNSET)
(SETQ PARAMLIST '($%R1 $%R2 $%R3 $%R4 $%R5 $%R6 $%R7 $%R8))
(SETQ TVARXL (CDR VARXLIST))
(SETQ L1 (LENGTH TVARXL))
(SETQ ASOLNSET ASOLNSETL)
(COND ((EQUAL L1 (LENGTH ASOLNSET)) (RETURN ASOLNSET)))
LOOP (SETQ EQN (CAR ASOLNSET))
(SETQ TVARXL (DELET (CADR EQN) TVARXL))
(SETQ ASOLNSET (CDR ASOLNSET))
(COND ((NULL ASOLNSET) NIL) (T (GO LOOP)))
AGAIN(COND ((NULL TVARXL) (RETURN ASOLNSETL)))
TEST (SETQ PARAM (CAR PARAMLIST))
(SETQ PARAMLIST (CDR PARAMLIST))
(COND ((MEMQ PARAM VARXLIST) (GO TEST)))
(SETQ VAR (CAR TVARXL))
(SETQ ASOLNSETL (CONS (LIST '(MEQUAL) VAR PARAM)
(MAPCAR (FUNCTION YSUBST) ASOLNSETL)))
(SETQ TVARXL (CDR TVARXL))
(GO AGAIN)))
(DEFUN YSUBST (EQN) (SUBST PARAM VAR EQN))
(DEFUN FINDLINVAR (LHSL VARXL)
(PROG (TLHSL LINVAR LINEQN TEMPVAR DEGVEC M N TGENVAR)
(SETQ TLHSL LHSL)
LOOP (COND ((NULL TLHSL) (RETURN NIL)) (T (SETQ LINEQN (CAR TLHSL))))
(SETQ TEMPVAR LINEQN)
(SETQ TLHSL (CDR TLHSL))
(SETQ DEGVEC (PDEGREEVECTOR TEMPVAR))
(SETQ M 0.)
DOSEEK1
(SETQ M (PLUS M 1.))
(SETQ N (SEEK1 M DEGVEC))
(SETQ TGENVAR GENVAR)
GETLINVAR
(COND ((NULL N) (GO LOOP))
((GREATERP N 0.) (GO COUNTDOWN))
(T (GO DONELINVAR)))
COUNTDOWN
(SETQ TGENVAR (CDR TGENVAR))
(SETQ N (PLUS N -1.))
(GO GETLINVAR)
DONELINVAR
(SETQ LINVAR (CAR TGENVAR))
(COND ((MEMQ LINVAR VARXL)
(COND ((CONSTCOEFP LINVAR LINEQN VARXL)
(RETURN (LIST LINEQN LINVAR)))
(T (GO DOSEEK1))))
(T (GO DOSEEK1)))))
(DEFUN SEEK1 (M LIST)
(PROG (TM TLIST N)
(SETQ TM 1.)
(SETQ TLIST LIST)
(SETQ N 1.)
LOOP (COND ((NULL TLIST) (RETURN NIL)) (T NIL))
(COND ((EQUAL (CAR TLIST) 1.) (GO COUNTUP))
(T (SETQ TLIST (CDR TLIST))))
(SETQ N (PLUS N 1.))
(GO LOOP)
COUNTUP
(COND ((EQUAL TM M) (RETURN N)) (T (SETQ TM (PLUS TM 1.))))
(SETQ TLIST (CDR TLIST))
(SETQ N (PLUS N 1.))
(GO LOOP)))
(DEFUN CONSTCOEFP (LINVAR LINEQN TVARXLIST)
(PROG (LINCOEF DEGVEC TGENVAR TESTVAR)
(SETQ LINCOEF (PRODCOEF (LIST LINVAR 1. 1.) LINEQN))
(SETQ DEGVEC (PDEGREEVECTOR LINCOEF))
(SETQ TGENVAR (CDR GENVAR))
LOOP (COND ((NULL DEGVEC) (RETURN T)) (T NIL))
(COND ((EQUAL 0. (CAR DEGVEC)) (GO CONT))
(T (SETQ TESTVAR (CAR TGENVAR))))
(COND ((MEMQ TESTVAR TVARXLIST) (RETURN NIL)) (T NIL))
CONT (SETQ TGENVAR (CDR TGENVAR))
(SETQ DEGVEC (CDR DEGVEC))
(GO LOOP)))
(DEFUN NOFTRS (FTRSL) (QUOTIENT (LENGTH FTRSL) 2))
(DEFUN PFREEOFMAINVARSP (POLY MAINVARS)
(PROG (VAR REST)
(COND ((ATOM POLY) (RETURN T)))
(SETQ VAR (CAR POLY))
TEST (COND ((MEMQ VAR MAINVARS) (RETURN NIL)))
(SETQ REST (CDDR POLY))
LOOP (SETQ VAR (CAR REST))
(COND ((NUMBERP VAR) (GO LOOPQ))
((PFREEOFMAINVARSP VAR MAINVARS) (GO LOOPQ))
(T (RETURN NIL)))
LOOPQ(COND ((EQUAL (LENGTH REST) 1.) (RETURN T))
(T (SETQ REST (CDDR REST))))
(GO LOOP)))
(DEFUN LOFACTORS (ALHS)
(PROG (FACTORS LFACTORS NOFACTORS TEMPLIST AFACTOR)
(SETQ FACTORS (PFACTOR ALHS))
LOOP (COND ((NUMBERP (CAR FACTORS))
(SETQ FACTORS (CDDR FACTORS)) (GO LOOP)))
(SETQ NOFACTORS (NOFTRS FACTORS))
(COND ((EQUAL NOFACTORS 1.) (RETURN (LIST (CAR FACTORS))))
(T (GO MAKELIST)))
MAKELIST
(COND ((GREATERP NOFACTORS MAXNOFTRS) (SETQ MAXNOFTRS NOFACTORS))
(T NIL))
(SETQ LFACTORS NIL)
(SETQ TEMPLIST FACTORS)
LOOP0(COND ((NULL TEMPLIST) (GO END)))
(SETQ AFACTOR (CAR TEMPLIST))
(COND ((PFREEOFMAINVARSP AFACTOR TVARXLIST) (GO SKIP)))
(SETQ LFACTORS (APPEND LFACTORS (LIST (PPOSLEADCOEF AFACTOR))))
SKIP (SETQ TEMPLIST (CDDR TEMPLIST))
(GO LOOP0)
END (RETURN LFACTORS)))
(DEFUN PPOSLEADCOEF (POLY)
(PROG (COEF)
(SETQ COEF (CADDR POLY))
LOOP (COND ((NUMBERP COEF)
(COND ((GREATERP 0. COEF) (RETURN (PMINUS POLY)))
(T (RETURN POLY))))
(T (SETQ COEF (CADDR COEF)) (GO LOOP)))))
(DEFUN COMBINEY (LISTOFL)
(PROG (RESULT TEMPLIST ELTLIST NEWELT TEMPRST OLDRST)
(SETQ LISTOFL (DELQ NIL LISTOFL))
(COND ((NULL LISTOFL) (RETURN NIL)))
(SETQ TEMPRST (CAR LISTOFL))
INIT (COND ((NULL TEMPRST) (GO SET))
(T (SETQ RESULT (APPEND RESULT
(LIST (LIST (CAR TEMPRST)))))))
(SETQ TEMPRST (CDR TEMPRST))
(GO INIT)
SET (SETQ TEMPLIST (CDR LISTOFL))
(COND ((NULL TEMPLIST) (RETURN RESULT)) (T (GO LOOP3)))
LOOP3(SETQ OLDRST RESULT)
(SETQ TEMPRST RESULT)
(SETQ ELTLIST (CAR TEMPLIST))
(SETQ TEMPLIST (CDR TEMPLIST))
(SETQ RESULT NIL)
LOOP2(SETQ NEWELT (LIST (CAR ELTLIST)))
(SETQ ELTLIST (CDR ELTLIST))
(SETQ TEMPRST OLDRST)
LOOP1(SETQ RESULT (APPEND RESULT (LIST (APPEND (CAR TEMPRST) NEWELT))))
(SETQ TEMPRST (CDR TEMPRST))
(COND ((GREATERP (LENGTH TEMPRST) 0.) (GO LOOP1))
(T (COND ((GREATERP (LENGTH ELTLIST) 0.) (GO LOOP2))
(T (COND ((GREATERP (LENGTH TEMPLIST) 0.)
(GO LOOP3))
(T (RETURN RESULT)))))))))
(DEFUN NUMTOR (RATFTN) (CADR (RATF RATFTN)))
(DEFUN LINSUBST (LINSOLN LHSLIST)
(PROG (TLHSLIST TEMPLHS NLHSLIST)
(SETQ TLHSLIST LHSLIST)
(SETQ NLHSLIST NIL)
SUBSTLOOP
(COND ((NULL TLHSLIST) (RETURN NLHSLIST)))
(SETQ TEMPLHS (CAR TLHSLIST))
(SETQ TLHSLIST (CDR TLHSLIST))
(SETQ TEMPLHS (EVAL (CONS '$EV
(LIST (PDIS TEMPLHS)
LINSOLN
'$RADCAN))))
(SETQ TEMPLHS (NUMTOR TEMPLHS))
(COND ((EQUAL TEMPLHS 0.) (GO SUBSTLOOP)))
(SETQ NLHSLIST (APPEND NLHSLIST (LIST TEMPLHS)))
(GO SUBSTLOOP)))
(DEFUN MID (L) (RHALF (RPLUS (CAR L) (CADR L))))
(DEFUN RFLOT (L)
(PROG (RR)
(SETQ RR (MID L))
(RETURN (QUOTIENT (PLUS 0.0 (CAR RR)) (CDR RR)))))
(DEFUN GETROOTS (POLY EPS)
(PROG (FTRL SOLNL SOLN)
(SETQ FTRL (PSQFR POLY))
AGAIN(COND ((NUMBERP (CAR FTRL)) (SETQ FTRL (CDDR FTRL))) (T (GO LOOP)))
(GO AGAIN)
LOOP (COND ((NULL FTRL) (RETURN SOLNL)))
(SETQ SOLN (STURM1 (CAR FTRL) EPS))
(SETQ SOLNL (APPEND SOLNL SOLN))
(SETQ FTRL (CDDR FTRL))
(GO LOOP)))
(DEFUN PREALROOTS (EQN EPS) (MAPCAR (FUNCTION RFLOT) (GETROOTS EQN EPS)))
(DEFUN ADDMEQUAL (L) (LIST '(MEQUAL) VAR L))
(DEFUN MEMBERROOT (A X)
(COND ((NULL X) NIL)
((LESSP (ABS (DIFFERENCE A (CAR X)))
(QUOTIENT (PLUS 0.0 (CAR EPS)) (CDR EPS)))
T)
(T (MEMBERROOT A (CDR X)))))
(DEFUN COMMONROOTS (EPS SOLNL1 SOLNL2)
(COND ((NULL SOLNL1) NIL)
((MEMBERROOT (CAR SOLNL1) SOLNL2)
(CONS (CAR SOLNL1) (COMMONROOTS EPS (CDR SOLNL1) SOLNL2)))
(T (COMMONROOTS EPS (CDR SOLNL1) SOLNL2))))
(DEFUN DELETMULT (L)
(COND ((NULL L) NIL) (T (APPEND (LIST (CAR L)) (DELETMULT (CDDR L))))))
(DEFUN PUNIVARP (POLY) (UNIVAR (CDR POLY)))
(DEFUN REALONLY (ROOTSL)
(COND ((NULL ROOTSL) NIL)
((FREEOF '$%I (CAR ROOTSL))
(NCONC (LIST (CAR ROOTSL)) (REALONLY (CDR ROOTSL))))
(T (REALONLY (CDR ROOTSL)))))
(DEFUN UNIVARSOLN (LHSL VAR)
(PROG (EQN EQNS SOLNLIST SOLNLIST1 *ROOTS *FAILURES TGENVAR TVARLIST)
(SETQ EQN (CAR LHSL))
(SETQ EPS (CONS 1. $ALGEPSILON))
(COND ((AND (EQUAL (LENGTH LHSL) 1.) (NOT (PUNIVARP EQN)))
(GO CALLSOLVE)))
(SETQ EQNS (CDR LHSL))
(COND ((EQ VAR (CAR EQN)) NIL) (T (GO LOOP)))
(SETQ SOLNLIST (PREALROOTS EQN EPS))
LOOP (COND ((NULL EQNS) (GO END)))
(SETQ EQN (CAR EQNS))
(SETQ EQNS (CDR EQNS))
(COND ((EQ VAR (CAR EQN)) NIL) (T (GO LOOP)))
(SETQ SOLNLIST1 (PREALROOTS EQN EPS))
(COND ((NULL SOLNLIST1) (RETURN NIL)))
(SETQ SOLNLIST (COMMONROOTS EPS SOLNLIST SOLNLIST1))
(COND ((NULL SOLNLIST) (RETURN NIL)))
(GO LOOP)
CALLSOLVE
(SETQ EQN (PDIS EQN))
(SETQ VAR (PDIS (LIST VAR 1. 1.)))
(SETQ TGENVAR GENVAR)
(SETQ TVARLIST VARLIST)
(SOLVE EQN VAR 1.)
(SETQ GENVAR TGENVAR)
(SETQ VARLIST TVARLIST)
(COND ((NULL *ROOTS) (RETURN NIL)))
(RETURN (MAPCAR (FUNCTION LIST) (DELETMULT *ROOTS)))
END (SETQ VAR (PDIS (LIST (CAR EQN) 1. 1.)))
(RETURN (MAPCAR (FUNCTION LIST)
(MAPCAR (FUNCTION ADDMEQUAL) SOLNLIST)))))
(DEFPROP PCOEFP (LAMBDA (L) (SUBST (CADR L) 'X '(ATOM X))) MACRO)
(DEFUN PDEGREEY (P *VAR) (PROG (*MAX) (SETQ *MAX 0.) (PDEG2 P) (RETURN *MAX)))
(DEFUN PDEG2 (P)
(COND ((PCOEFP P) *MAX)
((EQ (CAR P) *VAR) (SETQ *MAX (MAX *MAX (CADR P))))
(T (PDEG3 (CDR P)))))
(DEFUN PDEG3 (P) (COND ((NULL P) *MAX) (T (PDEG2 (CADR P)) (PDEG3 (CDDR P)))))
(DEFUN PRESULTANT (P1 P2 VAR)
(CADR (RATF ($RESULTANT (PDIS P1) (PDIS P2) (PDIS (LIST VAR 1. 1.))))))
(DEFUN PTIMEFTRS (L)
(PROG (LL)
(SETQ LL (CDDR L))
(COND ((NULL LL) (RETURN (CAR L)))
(T (RETURN (PTIMES (CAR L) (PTIMEFTRS LL)))))))
(DEFUN LEASTDEG (LHSL VAR)
(PROG (EQN D1 D2 EQN2)
INIT (SETQ EQN (CAR LHSL))
(SETQ D1 (PDEGREEY EQN VAR))
(COND ((ZEROP D1) NIL) (T (GO LOOP)))
(SETQ LHSL (CDR LHSL))
(COND ((NULL LHSL) (RETURN NIL)))
(GO INIT)
LOOP (SETQ LHSL (CDR LHSL))
(COND ((NULL LHSL) (RETURN EQN)))
(SETQ EQN2 (CAR LHSL))
(SETQ D2 (PDEGREEY EQN2 VAR))
(COND ((OR (EQUAL D1 D2) (LESSP D1 D2)) (GO LOOP)))
(COND ((ZEROP D2) (GO LOOP)))
(SETQ EQN EQN2)
(SETQ D1 D2)
(GO LOOP)))
(DECLARE (SPECIAL TSOLN))
(DEFUN MERGESOLN (L) (APPEND L TSOLN))
(DEFUN BAKSUBST (SOLNL POLY VAR)
(PROG (SOLNLIST TSOLNLIST TSOLN SOLN TPOLY)
(SETQ TSOLNLIST SOLNL)
(SETQ TPOLY (PDIS POLY))
SOLNLOOP
(COND ((NULL TSOLNLIST) (RETURN SOLNLIST)))
(SETQ TSOLN (APPEND (LIST '(MLIST)) (CAR TSOLNLIST)))
(SETQ SOLN (EVAL (CONS '$EV
(LIST TPOLY TSOLN '$RADCAN))))
(SETQ SOLN (CADR (RATF SOLN)))
(SETQ SOLN (UNIVARSOLN (LIST SOLN) VAR))
(COND ((NULL SOLN) (GO SKIP)))
(SETQ TSOLN (CDR TSOLN))
(SETQ SOLNLIST (APPEND SOLNLIST
(MAPCAR (FUNCTION MERGESOLN) SOLN)))
(SETQ SOLNLIST (CONDENSEY SOLNLIST))
SKIP (SETQ TSOLNLIST (CDR TSOLNLIST))
(GO SOLNLOOP)))
(DECLARE (UNSPECIAL TSOLN))
(DEFUN BAKALEVEL (SOLNL LHSL VAR)
(PROG (LEASTDEQ SOLNL1)
(COND ((NULL SOLNL) (RETURN NIL)))
LOOP (SETQ LEASTDEQ (LEASTDEG LHSL VAR))
(COND ((NULL LEASTDEQ) (RETURN SOLNL)))
(SETQ LHSL (DELET LEASTDEQ LHSL))
(SETQ SOLNL1 (BAKSUBST SOLNL LEASTDEQ VAR))
(COND ((NULL SOLNL1)
(COND ((NULL LHSL) (RETURN SOLNL)) (T (GO LOOP)))))
(RETURN (MAPCAR (FUNCTION CDR)
(TRUESOLNS (MAPCAR (FUNCTION ADDMLIST) SOLNL1)
(MAPCAR (FUNCTION (LAMBDA(X) (LIST '(MLIST)
(PDIS X)
(TAYAPPROX X))))
LHSL))))))
(DEFUN TAYAPPROX (P)
(CONS '(MPLUS)
(MAPCAR '(LAMBDA (X) (LIST '(MABS) (PDIS
(PTIMES (CONS X '(1 1))
(PDERIVATIVE P X)))))
(LISTOVARS P)))) ;USE TVARXLIST INSTEAD?
(DEFUN DISTREP (LOL)
(PROG (RESULT)
(SETQ RESULT (COMBINEY LOL))
(SETQ RESULT (CONDENSESUBLIST RESULT))
(SETQ RESULT (CONDENSELOL RESULT))
(RETURN RESULT)))
(DEFUN CONDENSEY (L)
(PROG (FIRST REST RESULTL)
(COND ((NULL L) (RETURN RESULTL)))
LOOP (SETQ FIRST (CAR L))
(SETQ REST (CDR L))
(COND ((NULL REST) (RETURN (REVERSE (CONS FIRST RESULTL)))))
(COND ((MEMBER FIRST REST) NIL)
(T (SETQ RESULTL (CONS FIRST RESULTL))))
(SETQ L REST)
(GO LOOP)))
(DEFUN CONDENSESUBLIST (LOL)
(PROG NIL
(COND ((NULL LOL) (RETURN NIL))
(T (RETURN (APPEND (LIST (CONDENSEY (CAR LOL)))
(CONDENSESUBLIST (CDR LOL))))))))
(DEFUN INTERSECTION (X Y)
(PROG NIL
(COND ((NULL X) NIL)
((MEMBER (CAR X) Y)
(RETURN (CONS (CAR X) (INTERSECTION (CDR X) Y))))
(T (RETURN (INTERSECTION (CDR X) Y))))))
(DEFUN CONDENSELOL (LOL)
(PROG (FIRST REST TREST TESTL INTRS LI L1 L2)
(COND ((NULL LOL) (RETURN NIL)) (T NIL))
(SETQ FIRST (CAR LOL))
(SETQ REST (CDR LOL))
(SETQ TREST REST)
(COND ((NULL REST) (RETURN (LIST FIRST))) (T (GO LOOP)))
LOOP (SETQ TESTL (CAR TREST))
(SETQ TREST (CDR TREST))
(SETQ INTRS (INTERSECTION FIRST TESTL))
(SETQ LI (LENGTH INTRS))
(COND ((EQUAL LI 0.) (GO TEST)) (T NIL))
(SETQ L1 (LENGTH FIRST))
(SETQ L2 (LENGTH TESTL))
(COND ((EQUAL L1 L2)
(COND ((EQUAL LI L2) (SETQ REST (DELET TESTL REST)))
(T (GO TEST))))
((GREATERP L1 L2)
(COND ((EQUAL LI L2) (RETURN (CONDENSELOL REST)))
(T (GO TEST))))
(T (COND ((EQUAL LI L1) (SETQ REST (DELET TESTL REST)))
(T (GO TEST)))))
TEST (COND ((NULL TREST)
(RETURN (APPEND (LIST FIRST) (CONDENSELOL REST))))
(T (GO LOOP)))))
(DEFUN EXCLUDE (L1 L2)
(COND ((NULL L2) NIL)
((MEMBER (CAR L2) L1) (EXCLUDE L1 (CDR L2)))
(T (APPEND (LIST (CAR L2)) (EXCLUDE L1 (CDR L2))))))
(DEFUN DISPLAL (L)
(PROG (N EQUATIONS ELIST RDCSYS)
(SETQ BAKEQNS NIL)
(SETQ N 1.)
LOOP (COND ((NULL L) (RETURN NIL)))
(PRINC '/
SUBSYSTEM/ ) (PRINC N)
(PRINC ':/
) (SETQ RDCSYS
(MAPCAR (FUNCTION (LAMBDA (G) (MAPCAR (FUNCTION PDIS) G)))
(CAR L)))
LOOP1(COND ((NULL RDCSYS) (GO CONSTR)))
(SETQ EQUATIONS NIL)
(SOLVE2 (PUTIN1S (CAR RDCSYS)))
(SETQ ELIST (APPEND ELIST (LIST EQUATIONS)))
(SETQ RDCSYS (CDR RDCSYS))
(GO LOOP1)
CONSTR
(SETQ BAKEQNS (APPEND BAKEQNS (LIST ELIST)))
(SETQ ELIST (ADDMLIST (MAPCAR (FUNCTION ADDMLIST) ELIST)))
(DISPLINE ELIST)
(SETQ ELIST NIL)
(MTERPRI)
(SETQ N (ADD1 N))
(SETQ L (CDR L))
(GO LOOP)))
(DEFUN ALLVARS (LHSLIST)
(PROG (VARLIST)
LOOP (COND ((NULL LHSLIST) (RETURN VARLIST)))
(NEWVAR (CAR LHSLIST))
(SETQ LHSLIST (CDR LHSLIST))
(GO LOOP)))
(DEFUN BAKSOLVE (SYSL TVARXLIST)
(PROG (SOLNL)
(SETQ SYSL (REVERSE SYSL))
(SETQ TVARXLIST (REVERSE TVARXLIST))
TEST (COND ((LESSP (LENGTH SYSL) (LENGTH TVARXLIST))
(SETQ TVARXLIST (CDR TVARXLIST))
(GO TEST)))
(SETQ SOLNL (UNIVARSOLN (CAR SYSL) (CAR TVARXLIST)))
LOOP (SETQ SYSL (CDR SYSL))
(SETQ TVARXLIST (CDR TVARXLIST))
(COND ((NULL SYSL) (RETURN SOLNL)))
(SETQ SOLNL (BAKALEVEL SOLNL (CAR SYSL) (CAR TVARXLIST)))
(GO LOOP)))
(DEFUN OUTSOLNS (SOLNL) (PROG2 (PUTORDER TVARXLIST)
(PROG (ELIST EQUATIONS)
(COND ((NULL SOLNL) (DISPLINE '((MLIST))) (MTERPRI) (RETURN NIL)))
(SETQ
SOLNL
(MAPCAR
(FUNCTION (LAMBDA (G) (ROUNDROOTS1 (BBSORTEQNS (ADDPARAM G)))))
SOLNL))
LOOP1(COND ((NULL SOLNL)
(DISPLINE (ADDMLIST ELIST))
(MTERPRI)
(RETURN NIL)))
(SETQ EQUATIONS NIL)
(SOLVE2 (PUTIN1S (CAR SOLNL)))
(SETQ ELIST (APPEND ELIST (LIST (ADDMLIST EQUATIONS))))
(SETQ SOLNL (CDR SOLNL))
(GO LOOP1))
(REMORDER TVARXLIST)))
(DEFUN RATFEVL (EL)
(MAPCAR (FUNCTION (LAMBDA (G) (CADR (RATF (MEVAL (EVAL G)))))) EL))
(DEFUN $BAKSOLVE (MEL VARXLIST)
(PROG (EL TVARXLIST VARLIST GENVAR $RATFAC)
(SETQ GENVAR (LIST 0))
(COND ((NOT ($LISTP MEL))
(DISPLA MEL)
(ERLIST '(ARG TO BAKSOLVE MUST BE A LIST)))
((NOT ($LISTP VARXLIST))
(DISPLA VARXLIST)
(ERLIST '(ARG TO BAKSOLVE MUST BE A LIST))))
(DO MEL
(CDR MEL)
(CDR MEL)
(NULL MEL)
(COND ((NOT ($LISTP (CAR MEL)))
(DISPLA (CAR MEL))
(ERLIST '(IMPROPER ARG TO BAKSOLVE)))))
(SETQ EL (CDR (MAPCAR (FUNCTION CDR) MEL)))
(SETQ EL (MAPCAR (FUNCTION POLYFL) EL))
(SETQ TVARXLIST (MAPCAR (FUNCTION (LAMBDA (G) (CAADR (RATF G))))
(CDR VARXLIST)))
(OUTSOLNS (BAKSOLVE EL TVARXLIST))
(RETURN '$DONE)))
(DEFUN POLYFL (MEL) (MAPCAR (FUNCTION (LAMBDA (G) (CADR (RATF G)))) MEL))
(COMMENT *** THIS FUNCTION IS NOT USED ANY MORE
(DEFUN RETURNSOLNS (SOLNL)
(PROG (EQUATIONS)
(COND
((NULL (CDR SOLNL))
(SOLVE2
(PUTIN1S
(ROUNDROOTS1 (BBSORTEQNS (ADDPARAM (CAR SOLNL))))))
(RETURN NIL))
(T
(SETQ
SOLNL
(MAPCAR
(FUNCTION
(LAMBDA (G)
(ADDMLIST (ROUNDROOTS1 (BBSORTEQNS (ADDPARAM G))))))
SOLNL)))))))