Sindbad~EG File Manager
/* automode solving of systems of linear equations for MathXpert */
/* Original date 6.3.91
Last modified 1.22.98
3.17.06 deleted include document.h
*/
#define AUTOMODE_DLL
#include <assert.h>
#include <string.h>
#include "globals.h"
#include "graphstr.h"
#include "tdefn.h"
#include "checkarg.h" /* for operator typedef */
#include "ops.h" /* for prototypes of operators */
#include "symbols.h"
#include "cflags.h" /* get_currenttopic */
#include "calc.h" /* polyvalop */
#include "autosimp.h" /* SetShowStepOperation, set_pathtail */
#include "deval.h" /* seminumerical */
#define ENTRY(i,j,t) (ARG((j),ARG((i),(t))))
/*________________________________________________________________________*/
MEXPORT_AUTOMODE void solve_by_substitution(term t, term * arg, int initiali, actualop *o, int *nops)
/* Called by post_ops for solving a system of linear equations t by
repeated substitution. */
/* t is an AND of linear equations; arg is used to return an argument for
the selected operator. The selected operator (or operators) is
returned in o[initiali] and if needed subsequent values of initiali;
nops is returned as one more than the last index used (i.e., it is the
final dimension of the array o.) */
{ int ii = initiali;
int currenttopic = get_currenttopic();
unsigned i,j;
term *atomlist;
unsigned n = ARITY(t);
term x,u;
o[ii] = dropeqn; ++ii;
o[ii] = eqnscollectall; ++ii;
o[ii] = polyvalop; ++ii;
/* the equations are simplified now */
assert(currenttopic == _eqns_by_substitution);
/* Detect a contradiction: if the equations have no solution,
one of the equations will eventually be a numerical contradiction. */
for(i=0;i<n;i++)
{ if(seminumerical(ARG(i,t)))
{ o[ii] = impossibleeqns; ++ii;
}
}
/* Find the first solved equation, solved for a variable x
which still occurs in another equation,
and use it for a substitution */
for(i=0;i<n;i++)
{ u = ARG(i,t);
assert(FUNCTOR(u) == '=');
x = ARG(0,u);
if(!ISATOM(x))
continue;
if(contains(ARG(1,u),FUNCTOR(x)))
continue;
for(j=0;j<n;j++)
{ if(j!=i && contains(ARG(j,t),FUNCTOR(x)))
{ /* got it! */
o[ii] = substforvar; ++ii;
*arg = x;
*nops = ii;
return;
}
}
}
/* OK, all the solved equations have already been used.
Find the first unsolved equation and solve it for
the first variable that occurs in it. */
for(i=0;i<n;i++)
{ u = ARG(i,t);
assert(FUNCTOR(u) == '=');
x = ARG(0,u);
if(constant(u))
continue; /* be sure there is at least one variable in u */
if(!ISATOM(x) || contains(ARG(1,u),FUNCTOR(x)))
break; /* got the first unsolved equation */
}
if(i==n)
{ *nops = ii;
return; /* nothing to do */
}
variablesin(u,&atomlist); /* there must be at least one */
x = atomlist[0];
/* don't bother to free2(atomlist), because the operation is going to
succeed and the heap will be reset anyway. */
*arg = and(make_int(i+1),x); /* Solve equation ? for ? */
/* Note the equations are numbered starting
from 1 in the numbering passed to arg */
o[ii] = solveone; ++ii;
*nops = ii;
return;
}
/*________________________________________________________________________*/
MEXPORT_AUTOMODE void solve_linear_equations(term t, term * arg, int initiali, actualop *o, int *nops)
/* called by post_ops for solving linear equations */
/* t is an AND of linear equations; arg is used to return an argument for
the selected operator. The selected operator (or operators) is
returned in o[initiali] and if needed subsequent values of initiali;
nops is returned as one more than the last index used (i.e., it is the
final dimension of the array o.) */
{ int ii = initiali;
int indent = 0;
int currenttopic = get_currenttopic();
char localbuf[32];
int n,m; /* there are n rows and m columns */
unsigned short k;
int i,j,err,row;
term a; /* the matrix form of the equation is ax = rhs */
term entry; /* the entry to be changed at a given step */
term foo; /* foo will be the equality ax = rhs */
o[ii] = dropeqn; ++ii;
if(!LINEUP(t)) /* LINEUP(t) means variables are already lined up */
{ for(i=0;i<ARITY(t);i++)
{ if(FUNCTOR(ARG(0,ARG(i,t))) == '+') /* left side of i-th equation is a sum */
break;
}
if(i<ARITY(t)) /* at least one sum on a left side */
{ o[ii] = eqnscollectall; ++ii; /* varsleft is in pre_ops */
o[ii] = lineupvars; ++ii; /* hence lineupvars won't be used if */
*nops = ii; /* the equations are already solved */
return;
}
}
/* So now the equations are in standard form with variables lined up */
/* Internally we convert the equations to matrix form so we can easily
get at the right coefficients */
err = matrixform(t,zero,&foo,localbuf);
if(err) /* wrong input form of t */
{ *nops = ii;
return;
}
assert(FUNCTOR(foo)== '=');
assert(FUNCTOR(ARG(0,foo)) == '*');
a = ARG(0,ARG(0,foo));
n = ARITY(a); /* number of rows */
m = ARITY(ARG(0,a)); /* number of columns */
if(m>n) /* More columns than rows */
{ /* There are m-n "extra" variables. Before making them into
constants, we should manipulate the equations so that the
square part of a consisting of n columns and n rows is
the identity. */
for(i=0;i<n;i++)
{ for(j=0;j<n;j++)
{ if(!equals(ENTRY(i,j,a), i==j ? one : zero))
break;
}
if(j < n)
break;
}
if(i==n)
{ o[ii] = regardvarasconst; ++ii;
}
}
/* Now check the topic and use the correct method to solve the equations: */
if(currenttopic == _cramers_rule)
{ o[ii] = cramersrule; ++ii;
*nops =ii;
return; /* it only remains to evaluate the determinants */
}
if(currenttopic == _eqns_in_matrix_form ||
currenttopic == _gauss_jordan ||
currenttopic == _eqns_by_matrix_inverse
)
{ o[ii] = matrixform; ++ii;
*nops = ii;
return;
}
/* Now we're going to use the add-and-subtract method. */
/* Identify the first column which isn't done */
for(j=0;j<m;j++)
{ row = j-indent;
if(row >= n)
break;
if(ZERO(ENTRY(row,j,a))) /* zero "diagonal" entry in this column */
/* If there are degenerate columns, then the "diagonal" is
crooked, as in example x+y+z = 6, -z = -2, where indent
is 1 when we come to column 2 (the third column) */
{ /* then does any row below have a nonzero entry in this column ? */
for(i=n-1;i>row;i--)
{ if(!ZERO(ENTRY(i,j,a)))
break;
}
if(i>j) /* yes, there was a nonzero entry below */
{ unsigned short path[5];
o[ii] = swapeqns; ++ii;
*arg = and(make_int(i+1),make_int(j+1));
/* +1 because the operators expect indices beginning at 1, not 0 */
*nops = ii;
SetShowStepOperation(swapselectedeqn);
path[0] = FUNCTOR(t);
path[1] =(unsigned short)(i+1);
path[2] = 0;
set_pathtail(path);
return;
}
/* else there wasn't a nonzero entry below, but there
might be a row above with all zeroes to the left of here: */
for(i=row-1; i>=0; i--)
{ if(ZERO(ENTRY(i,j,a)))
continue;
for(k=0;k<j;k++)
{ if(!ZERO(ENTRY(i,k,a)))
break;
}
if(k==j)
break;
}
if(i>=0) /* got such a row */
{ o[ii] = swapeqns; ++i;
*arg = and(make_int(i+1),make_int(j+1));
*nops = ii;
return;
}
/* No row to swap with found, so go on to the next column */
++indent;
continue;
}
else if(equals(ENTRY(row,j,a),minusone))
{ *arg = make_int(j+1);
o[ii] = changesigns; ++ii;
*nops = ii;
return;
}
else if(!ONE(ENTRY(row,j,a))) /* nonzero, non-one "diagonal" entry */
{ /* then see if there is a row below with 1 in this column; if so swap */
for(i=j-indent+1;i<n;i++)
{ if(ONE(ENTRY(i,j,a)))
break;
}
if(i<n) /* yes, there was a unit entry */
{ o[ii] = swapeqns; ++ii;
*arg = and(make_int(i+1),make_int(j+1));
*nops = ii;
return;
}
/* no unit entry */
entry = ENTRY(row,j,a);
if(FUNCTOR(entry) == '/' && ONE(ARG(0,entry)))
{ o[ii] = muleqns; ++ii;
*arg = and(make_int(row+1),ARG(1,entry));
*nops = ii;
return;
}
if(FUNCTOR(entry) == '-' && FUNCTOR(ARG(0,entry)) == '/'
&& ONE(ARG(0,ARG(0,entry)))
)
{ o[ii] = muleqns; ++ii;
*arg = and(make_int(row+1),ARG(1,ARG(0,entry)));
*nops = ii;
return;
}
if(FUNCTOR(entry) == '/') /* but numerator isn't 1 */
{ o[ii] = muleqns; ++ii;
*arg = and(make_int(row+1),make_fraction(ARG(1,entry),ARG(0,entry)));
*nops = ii;
return;
}
if(FUNCTOR(entry) == '-' && FUNCTOR(ARG(0,entry)) == '/' )
/* but numerator isn't 1 */
{ o[ii] = muleqns; ++ii;
*arg = and(make_int(row+1),tnegate(make_fraction(ARG(1,ARG(0,entry)),ARG(0,ARG(0,entry)))));
*nops = ii;
return;
}
o[ii] = diveqns; ++ii; /* coef not a fraction, so divide by the coefficient */
*arg = and(make_int(row+1),entry);
*nops = ii;
return;
}
/* Now we have a unit entry on the "diagonal" in this column. Clear
the rest of the column to zero by subtracting or adding this
row or multiples of this row. */
for(i=n-1;i>=0;--i)
{ if(i != j-indent) /* off-"diagonal" */
{ entry = ENTRY(i,j,a);
if(!ZERO(entry))
{ if(ONE(entry)) /* subtract row j from row i */
{ o[ii] = subtwoeqns; ++ii;
*arg = and(make_int(j-indent+1),make_int(i+1));
*nops = ii;
return;
}
if(equals(entry,minusone))
{ o[ii] = addtwoeqns; ++ii;
*arg = and(make_int(j-indent+1),make_int(i+1));
*nops = ii;
return;
}
if(FUNCTOR(entry) == '-')
{ o[ii] = addmuleqns; ++ii;
*arg = and3(ARG(0,entry),make_int(j-indent+1),make_int(i+1));
*nops = ii;
return;
}
else
{ o[ii] = submuleqns; ++ii;
*arg = and3(entry,make_int(j-indent+1),make_int(i+1));
*nops = ii;
return;
}
}
}
}
} /* finished the j-loop over columns */
/* all columns done already; */
/* Now detect a contradiction: if the equations have no solution,
one of the equations is now a numerical contradiction */
for(i=0;i<n;i++)
{ if(seminumerical(ARG(i,t)))
{ o[ii] = impossibleeqns; ++ii;
break;
}
}
*nops = ii; /* no operators applicable */
return;
}
/*________________________________________________________________*/
MEXPORT_AUTOMODE void solve_matrix_equation(term t, term * arg, int initiali, actualop *o, int *nops)
/* called by post_ops for solving linear equations */
/* t is an equation a*x = c where c and x are vectors and a is a matrix;
arg is used to return an argument for
the selected operator. The selected operator (or operators) is
returned in o[initiali] and if needed subsequent values of initiali;
nops is returned as one more than the last index used (i.e., it is the
final dimension of the array o.) */
{ int ii = initiali;
int n,m; /* there are n rows and m columns */
int i,j;
term a,c,x; /* the matrix form of the equation is ax = rhs */
term entry; /* the entry to be changed at a given step */
assert(FUNCTOR(t)== '=');
assert(FUNCTOR(ARG(0,t)) == '*');
assert(ARITY(ARG(0,t)) == 2);
a = ARG(0,ARG(0,t)); /* the matrix */
x = ARG(1,ARG(0,t)); /* the vector of variables */
n = ARITY(a); /* number of rows */
m = ARITY(ARG(0,a)); /* number of variables */
assert(m==ARITY(x)); /* one column for every variable */
assert(FUNCTOR(a) == MATRIX);
c = ARG(1,t);
if(!contains(c,VECTOR) && !contains(c,MATRIX))
{ /* scalar on the right; all you can do is multiply out on the left */
o[ii] = multiplymatrices; ++ii;
*nops = ii;
return;
}
if(FUNCTOR(c) != VECTOR &&
!(FUNCTOR(c) == '*' && ARITY(c) == 2 && FUNCTOR(ARG(0,c)) == MATRIX)
)
{ *nops = ii; /* shouldn't be called in this case anyway */
return;
}
o[ii] = impossibleeqns; ++ii; /* check for a zero row and nonzero entry on the right */
o[ii] = dropzerorow; ++ii; /* check for a zero row with a zero entry on the right */
o[ii] = dropduplicaterow; ++ii;
if(get_currenttopic() == _eqns_by_matrix_inverse)
{ o[ii] = dividebymatrix; ++ii;
*nops = ii;
return;
}
if(get_currenttopic() == _gauss_jordan &&
FUNCTOR(ARG(1,t)) == VECTOR /* don't do it more than once! */
)
{ o[ii] = multbyidentity; ++ii;
*nops = ii;
return;
}
/* Identify the first column which isn't done */
for(j=0;j<m && j<n;j++)
{ if(ZERO(ENTRY(j,j,a))) /* zero diagonal entry in this column */
{ /* then does any row BELOW this diagonal entry
have a nonzero entry in this column ? */
for(i=n-1;i>j;i--)
{ if(!ZERO(ENTRY(i,j,a)))
break;
}
if(i>j) /* yes, there was a nonzero entry below */
{ o[ii] = swaprows; ++ii;
*arg = and(make_int(i+1),make_int(j+1));
/* +1 because the operators expect indices beginning at 1, not 0 */
*nops = ii;
return;
}
/* Perhaps the whole column is zero */
for(i=0;i<j;i++)
{ if(!ZERO(ENTRY(i,j,a)))
break;
}
if(i==j)
{ /* Yes, the whole column is zero */
o[ii] = dropzerocolumn; ++ii;
*nops = ii;
return;
}
/* Now we have a nonzero entry ABOVE the diagonal,
a zero entry ON the diagonal, and all zeroes BELOW
the diagonal. That means the matrix is singular.
But you can still go on to the remaining columns
and clean them up.
*/
continue; /* to next column */
}
else if( !ONE(ENTRY(j,j,a))) /* nonzero, non-one diagonal entry */
{ /* then see if there is a row below with 1 in this column; if so swap */
for(i=j+1;i<n;i++)
{ if(ONE(ENTRY(i,j,a)))
break;
}
if(i<n) /* yes, there was a unit entry */
{ o[ii] = swaprows; ++ii;
*arg = and(make_int(i+1),make_int(j+1));
*nops = ii;
return;
}
/* no unit entry */
entry = ENTRY(j,j,a);
if(FUNCTOR(entry) == '/' && ONE(ARG(0,entry)))
{ o[ii] = mulrows; ++ii;
*arg = and(make_int(j+1),ARG(1,entry));
*nops = ii;
return;
}
if(FUNCTOR(entry) == '-' && FUNCTOR(ARG(0,entry)) == '/'
&& ONE(ARG(0,ARG(0,entry)))
)
{ o[ii] = mulrows; ++ii;
*arg = and(make_int(j+1),ARG(1,ARG(0,entry)));
*nops = ii;
return;
}
if(FUNCTOR(entry) == '/') /* but numerator isn't 1 */
{ o[ii] = mulrows; ++ii;
*arg = and(make_int(j+1),make_fraction(ARG(1,entry),ARG(0,entry)));
*nops = ii;
return;
}
if(FUNCTOR(entry) == '-' && FUNCTOR(ARG(0,entry)) == '/' )
/* but numerator isn't 1 */
{ o[ii] = mulrows; ++ii;
*arg = and(make_int(j+1),tnegate(make_fraction(ARG(1,ARG(0,entry)),ARG(0,ARG(0,entry)))));
*nops = ii;
return;
}
o[ii] = divrows; ++ii; /* coef not a fraction, so divide by the coefficient */
*arg = and(make_int(j+1),ENTRY(j,j,a));
*nops = ii;
return;
}
/* Now we have a unit entry on the diagonal in this column. Clear
the rest of the column to zero by subtracting or adding this
row or multiples of this row. */
for(i=n-1;i>=0;--i)
{ if(i != j) /* off-diagonal */
{ entry = ENTRY(i,j,a);
if(!ZERO(entry))
{ if(ONE(entry)) /* subtract row j from row i */
{ o[ii] = subrows; ++ii;
*arg = and(make_int(j+1),make_int(i+1));
*nops = ii;
return;
}
if(equals(entry,minusone))
{ o[ii] = addrows;++ii;
*arg = and(make_int(j+1),make_int(i+1));
*nops = ii;
return;
}
if(FUNCTOR(entry) == '-')
{ o[ii] = addmulrows; ++ii;
*arg = and3(ARG(0,entry),make_int(j+1),make_int(i+1));
*nops = ii;
return;
}
else
{ o[ii] = submulrows; ++ii;
*arg = and3(entry,make_int(j+1),make_int(i+1));
*nops = ii;
return;
}
}
}
}
} /* finished the j-loop over columns */
/* all columns done already; */
o[ii] = multiplymatrices; ++ii; /* when we have I*(x,y,z) = c, multiply out the I */
*nops = ii; /* no more operators applicable */
return;
}
Sindbad File Manager Version 1.0, Coded By Sindbad EG ~ The Terrorists