From e6b5d81f40514d7792274ae8d2d00feaba4598e6 Mon Sep 17 00:00:00 2001 From: Eric Swenson Date: Mon, 18 Jun 2018 15:29:51 -0700 Subject: [PATCH] Resolves #977: ALGSYS updated with correct version. --- src/rat/{algsys.1 => algsys.150} | 19 +- src/rat/algsys.480 | 948 ------------------------------- 2 files changed, 16 insertions(+), 951 deletions(-) rename src/rat/{algsys.1 => algsys.150} (95%) mode change 100644 => 100755 delete mode 100755 src/rat/algsys.480 diff --git a/src/rat/algsys.1 b/src/rat/algsys.150 old mode 100644 new mode 100755 similarity index 95% rename from src/rat/algsys.1 rename to src/rat/algsys.150 index 30263a18..2aa72bdd --- a/src/rat/algsys.1 +++ b/src/rat/algsys.150 @@ -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)))))) +  \ No newline at end of file diff --git a/src/rat/algsys.480 b/src/rat/algsys.480 deleted file mode 100755 index 0537f0d8..00000000 --- a/src/rat/algsys.480 +++ /dev/null @@ -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))))))) - \ No newline at end of file