Sindbad~EG File Manager
/* matrix operations for solving systems of linear equations */
/* M. Beeson
Original date 3.27.91
Last modified 2.27.98
3.17.06 modified addrows to eliminate ltoa in favor of sprintf;
and at the same time make the reasons not depend on the exact length of "Add row", etc.,
as these may vary in other languages.
/* Matrix multiplication uses the same functor '*' as ordinary
multiplication, so flattening, regrouping terms, etc. will work
on it; but then we have to prevent violations of commutativity
carefully.
*/
#define ALGEBRA_DLL
#include <string.h>
#include <assert.h>
#include <math.h>
#include <stdlib.h>
#include <stdio.h> /* sprintf */
#include "globals.h"
#include "errbuf.h"
#include "pathtail.h" /* set_pathtail */
#include "deval.h"
#include "ops.h"
#include "polynoms.h"
#include "algaux.h"
#include "cancel.h"
#include "matrix.h"
#include "order.h"
#include "checkarg.h"
#include "prover.h"
#include "symbols.h"
#include "pvalaux.h"
#include "mstring.h"
#define ENTRY(i,j,t) (ARG((j),ARG((i),(t))))
#define ENTRYPTR(i,j,t) (ARGPTR(ARG((i),(t))) + (j))
#define ROWS(t) ARITY((t))
#define COLUMNS(t) ARITY(ARG(0,(t))) /* number of columns of a (non-bblocked) term */
static int symbolic_determinant(term t, term *ans);
/*_______________________________________________________________*/
static term make_matrix(unsigned short nrows, unsigned short ncols)
/* duplicated in matrix.c, but it's short and will save jumping to an overlay */
{ term ans;
int i;
ans = make_term(MATRIX,nrows);
for(i=0;i<nrows;i++)
ARGREP(ans,i,make_term(VECTOR,ncols));
return ans;
}
/*_______________________________________________________________*/
MEXPORT_ALGEBRA int matrixform(term t, term arg, term *next, char *reason)
/* take an AND of linear equations and produce a corresponding
matrix equation */
{ int err,i,j,k,p,flag;
int nvariables = get_nvariables();
int nparameters = get_nparameters();
term *varlist = get_varlist();
parameter *parameters = get_parameters();
term *entryptr;
long degree;
term var;
term a,x,rhs; /* *next will be a*x = rhs */
term lhs;
unsigned short n = ARITY(t); /* number of equations */
unsigned short m = (unsigned short)(nvariables - nparameters); /* number of variables */
if(nvariables > 0 && nparameters >= nvariables)
assert(0);
if(FUNCTOR(t)!= AND)
return 1;
for(i=0;i<n;i++) /* check all args are equations */
{ if(FUNCTOR(ARG(i,t)) != '=')
return 1;
}
a = make_matrix(n,m);
x = make_term(VECTOR,m);
rhs = make_term(VECTOR,n);
/* Now initialize the vector x of variables */
k=0;
for(i=0;i<nvariables;i++)
{ for(j=0;j<nparameters;j++)
{ if(parameters[j].index == i)
break;
}
if(j==nparameters) /* varlist[i] is a not a parameter */
{ ARGREP(x,k,varlist[i]);
++k;
}
}
assert(k==m);
/* That completes the initialization of x */
/* Now create the vector rhs of right-hand sides */
for(i=0;i<n;i++)
ARGREP(rhs,i,ARG(1,ARG(i,t)));
/* Now finally create the matrix a */
for(i=0;i<n;i++)
{ for(j=0;j<k;j++)
{ entryptr = ENTRYPTR(i,j,a); /* where to put the entry */
var = ARG(j,x);
lhs = ARG(0,ARG(i,t)); /* left side of i-th equation */
/* first, there might be only one term in that row: */
if(FUNCTOR(lhs) != '+')
{ if(contains(lhs,FUNCTOR(var)))
{ err = monomial_form(lhs,var,°ree,entryptr);
if(err || degree != 1)
{ errbuf(0,english(488));
/* Your equations are nonlinear. */
RELEASE(x);
RELEASE(rhs);
for(i=0;i<n;i++)
{ RELEASE(ARG(i,a));
}
RELEASE(a);
return 1;
}
}
else
*entryptr = zero;
}
else /* Now, lhs is a sum */
{ flag = 0; /* set if encounter two terms with var in them */
for(p=0;p<ARITY(lhs);p++)
/* this may seem inefficient, to go through lhs looking for the
coef of var, but the alternative is to fix a term of lhs and
go through x looking for the variable in that term, which is
equally inefficient, and this way enables us to check for
erroneous input better. */
{ if(contains(ARG(p,lhs),FUNCTOR(var)))
{ if(flag)
{ errbuf(0, english(489));
/* You must first collect like terms. */
goto fail;
}
flag = 1;
err = monomial_form(ARG(p,lhs),var,°ree,entryptr);
if(err || degree != 1)
{ errbuf(0,english(488));
/* Your equations are nonlinear */
goto fail;
}
}
}
if(flag==0) /* no term in var occurs in lhs */
*entryptr = zero;
}
}
}
/* That completes the construction of the matrix a */
*next = equation(product(a,x),rhs);
HIGHLIGHT(*next);
strcpy(reason, english(490)); /* matrix form */
return 0;
fail:
RELEASE(x);
RELEASE(rhs);
for(i=0;i<n;i++)
{ RELEASE(ARG(i,a));
}
RELEASE(a);
return 1;
}
/*_______________________________________________________________*/
MEXPORT_ALGEBRA int multbyidentity(term t, term arg, term *next, char *reason)
/* multiply the right side of a matrix equation Ax = y by I,
producing Ax = Iy (used this way in auto mode)
Or, replace vector y by Iy
(used this way in term selection mode under topic _gauss_jordan)
*/
{ term y;
term iden;
unsigned short path[3];
if(FUNCTOR(t) == VECTOR)
{ iden = make_identity(ARITY(t));
HIGHLIGHT(iden);
*next = product(iden,t);
strcpy(reason,"A = IA");
return 0;
}
if(FUNCTOR(t) != '=')
return 1;
y = ARG(1,t);
if(FUNCTOR(y) != MATRIX && FUNCTOR(y) != VECTOR)
return 1;
iden = make_identity(ARITY(y));
HIGHLIGHT(iden);
*next = equation(ARG(0,t),product(iden,y));
strcpy(reason,"A = IA");
path[0] = '=';
path[1] = 2;
path[2] = 0;
set_pathtail(path);
return 0;
}
/*_______________________________________________________________*/
static void swapargs(term u, int i, int j, term *ans)
/* swap args i and j of u producing *ans; args numbered from 0 */
/* Color the swapped rows yellow */
{ unsigned short n = ARITY(u);
int k;
assert(i>=0 && i<n && j>=0 && j <n);
*ans = make_term(FUNCTOR(u),n);
for(k=0;k<n;k++)
{ if(k!=i && k!=j)
ARGREP(*ans,k,ARG(k,u));
if(k==i)
{ ARGREP(*ans,k,ARG(j,u));
HIGHLIGHT(ARG(k,*ans));
}
if(k==j)
{ ARGREP(*ans,k,ARG(i,u));
HIGHLIGHT(ARG(k,*ans));
}
}
}
/*_______________________________________________________________*/
static void swaprows_aux(term u, int i,int j, term *ans)
/* swap rows i and j of a matrix or matrix product */
/* numbering rows from 0 */
{ int k=0;
if(FUNCTOR(u)==MATRIX || FUNCTOR(u)==VECTOR)
swapargs(u,i,j,ans);
if(FUNCTOR(u) == '*')
{ *ans = make_term('*',ARITY(u));
while(FUNCTOR(ARG(k,u)) != MATRIX && FUNCTOR(ARG(k,u))!=VECTOR && k < ARITY(u))
++k;
assert(k< ARITY(u));
swapargs(ARG(k,u),i,j,ARGPTR(*ans)+k);
for(i=0;i<ARITY(u);i++)
{ if(i!=k)
ARGREP(*ans,i,ARG(i,u)); /* swap rows only of first matrix in product */
}
}
}
/*_______________________________________________________________*/
/* arg is (i,j); swap rows i and j in a matrix equation Ax=y;
that is, swap the rows in A and in y. More generally, swap the
rows in the first matrix on each side. */
MEXPORT_ALGEBRA int swaprows(term t, term arg, term *next, char *reason)
{ int i,j,k;
unsigned short path[7];
term u,v,lhs,rhs;
if(FUNCTOR(t) != '=')
return 1;
if(FUNCTOR(arg) == ILLEGAL)
arg = and(one,two);
assert(ARITY(arg)==2);
assert(ISINTEGER(ARG(0,arg)));
assert(ISINTEGER(ARG(1,arg)));
i = (int) INTDATA(ARG(0,arg));
j = (int) INTDATA(ARG(1,arg));
u = ARG(0,t);
v = ARG(1,t);
swaprows_aux(u,i-1,j-1,&lhs);
swaprows_aux(v,i-1,j-1,&rhs);
*next = equation(lhs,rhs);
strcpy(reason, english(1713)); /* swap rows */
if(FUNCTOR(lhs) != '*')
return 1;
k = 0;
while(FUNCTOR(ARG(k,lhs)) != MATRIX)
++k;
if(k == ARITY(lhs))
return 1;
path[0] = '=';
path[1] = 1; /* left side */
path[2] = '*';
path[3] = (unsigned short)(k+1);
path[4] = MATRIX;
path[5] = (unsigned short)(i); /* not i+1, i already starts from 1 */
path[6] = 0;
set_pathtail(path);
return 0;
}
/*_______________________________________________________________*/
static int addrows_aux(term t, int i, int j, term c, term *ans)
/* add c times row i to row j of matrix or matrix product t, yielding *ans;
and color the swapped rows */
/* Return 0 for success, 1 for inapplicable (wrong input) */
{ int k,p,err;
term temp,v,u;
unsigned short m,n;
if(FUNCTOR(t) == '*')
{ n = ARITY(t);
k=0;
while(FUNCTOR(ARG(k,t)) != MATRIX && FUNCTOR(ARG(k,t)) != VECTOR && k < n )
k++;
if(k==ARITY(t))
return 1;
err = addrows_aux(ARG(k,t),i,j,c,&temp);
if(err)
return 1;
*ans = make_term('*', ARITY(t));
ARGREP(*ans,k,temp);
for(p=0;p<n;p++)
{ if(p!=k)
ARGREP(*ans,p,ARG(p,t));
}
return 0;
}
if(FUNCTOR(t) != MATRIX && FUNCTOR(t) != VECTOR)
return 1;
n = ARITY(t); /* number of rows */
assert(i<n && j<n && i>=0 && j >= 0);
if(FUNCTOR(t) == MATRIX)
{ m = COLUMNS(t);
temp = make_term(VECTOR,m);
for(p=0;p<m;p++) /* temp = c * i-th row of t */
{ u = sum(ARG(p,ARG(j,t)),product(c,ARG(p,ARG(i,t))));
err = value(u,ARGPTR(temp) + p);
if(err > 2)
{ errbuf(0,aem(err));
return 1;
}
if(err==2)
{ destroy_term(ARG(p,temp));
mfracts(c,ARG(p,ARG(i,t)),&v);
at(ARG(p,ARG(j,t)),v,ARGPTR(temp) + p);
}
}
*ans = make_term(MATRIX,n);
ARGREP(*ans,j,temp);
HIGHLIGHT(ARG(j,*ans));
for(p=0;p<n;p++)
{ if(p != j)
ARGREP(*ans,p,ARG(p,t));
}
return 0;
}
if(FUNCTOR(t) == VECTOR)
{ u = sum(ARG(j,t),product(c,ARG(i,t)));
err = value(u,&temp);
if(err > 2)
{ errbuf(0,aem(err));
return 1;
}
if(err==2)
{ destroy_term(temp);
mfracts(c,ARG(i,t),&v);
at(ARG(j,t),v,&temp);
}
*ans = make_term(VECTOR,n);
ARGREP(*ans,j,temp);
for(p=0;p<n;p++)
{ if(p != j)
ARGREP(*ans,p,ARG(p,t));
}
return 0;
}
assert(0); /* can't get here */
return 1;
}
/*_______________________________________________________________*/
static int mulrows_aux(term t, int i, term c, term *ans)
/* multiply row i by c in matrix or matrix product t, yielding *ans;
and color the new row */
/* Return 0 for success, 1 for inapplicable (wrong input) */
{ int k,p,err;
term temp;
unsigned short m,n;
if(ONE(c))
{ errbuf(0, english(492));
/* Multiplying by 1 won't change anything. */
return 1;
}
if(FUNCTOR(t) == '*')
{ n = ARITY(t);
k=0;
while(FUNCTOR(ARG(k,t)) != MATRIX && FUNCTOR(ARG(k,t)) != VECTOR && k < n )
k++;
if(k==ARITY(t))
return 1;
err = mulrows_aux(ARG(k,t),i,c,&temp);
if(err)
return 1;
*ans = make_term('*', ARITY(t));
ARGREP(*ans,k,temp);
for(p=0;p<n;p++)
{ if(p!=k)
ARGREP(*ans,p,ARG(p,t));
}
return 0;
}
if(FUNCTOR(t) != MATRIX && FUNCTOR(t) != VECTOR)
return 1;
n = ARITY(t); /* number of rows */
assert(i<n && i>=0);
if(FUNCTOR(t) == MATRIX)
{ m = COLUMNS(t);
temp = make_term(VECTOR,m);
for(p=0;p<m;p++) /* temp = c * i-th row of t */
{ err = value(product(c,ARG(p,ARG(i,t))),ARGPTR(temp) + p);
if(err==2)
{ destroy_term(ARG(p,temp));
mfracts(c,ARG(p,ARG(i,t)),ARGPTR(temp) + p);
}
if(err>2)
{ errbuf(0,aem(err));
return 1;
}
}
*ans = make_term(MATRIX,n);
ARGREP(*ans,i,temp);
HIGHLIGHT(ARG(i,*ans));
for(p=0;p<n;p++)
{ if(p != i)
ARGREP(*ans,p,ARG(p,t));
}
return 0;
}
if(FUNCTOR(t) == VECTOR)
{ err = value(product(c,ARG(i,t)),&temp);
if(err==2)
{ destroy_term(temp);
mfracts(c,ARG(i,t),&temp);
}
if(err > 2)
{ errbuf(0,aem(err));
return 1;
}
*ans = make_term(VECTOR,n);
ARGREP(*ans,i,temp);
for(p=0;p<n;p++)
{ if(p != i)
ARGREP(*ans,p,ARG(p,t));
}
return 0;
}
assert(0); /* can't get here */
return 1;
}
/*_______________________________________________________________*/
MEXPORT_ALGEBRA int addrows(term t, term arg, term *next, char *reason)
/* arg is (i,j); add row i to row j */
{ term left,right,ll, rr;
int i,j,k;
unsigned short n;
unsigned short path[7];
char buffer[40];
if(FUNCTOR(t) != '=')
return 1;
if(! is_matrix_product(ARG(0,t),&n))
return 1;
assert(ARITY(arg)==2);
assert(ISINTEGER(ARG(0,arg)));
assert(ISINTEGER(ARG(1,arg)));
i = (int) INTDATA(ARG(0,arg));
j = (int) INTDATA(ARG(1,arg));
assert(i>0 && i <= n);
assert(j>0 && j <= n);
strcpy(reason, english(493)); /* Add row */
sprintf(buffer," %d ",i);
strcat(reason, buffer);
strcat(reason, english(494)); /* to row */
sprintf(buffer, " %d",j);
--i; /* adjust to zero-based indices for use with ARG */
--j;
/* The operation should affect only the first matrix on each side */
ll = ARG(0,t);
rr = ARG(1,t);
if(addrows_aux(ll,i,j,one,&left))
return 1;
if(addrows_aux(rr,i,j,one,&right))
return 1;
*next = equation(left,right);
if(FUNCTOR(left) != '*')
return 1;
k = 0;
while(FUNCTOR(ARG(k,left)) != MATRIX)
++k;
if(k == ARITY(left))
return 1;
path[0] = '=';
path[1] = 1; /* left side */
path[2] = '*';
path[3] = (unsigned short)(k+1);
path[4] = MATRIX;
path[5] = (unsigned short)(i+1);
path[6] = 0;
set_pathtail(path);
return 0;
}
/*_______________________________________________________________*/
MEXPORT_ALGEBRA int subrows(term t, term arg, term *next, char *reason)
{ term left,right,ll,rr;
int i,j,k;
unsigned short n;
unsigned short path[7];
char buffer[40];
if(FUNCTOR(t) != '=')
return 1;
if(! is_matrix_product(ARG(0,t),&n))
return 1;
assert(ARITY(arg)==2);
assert(ISINTEGER(ARG(0,arg)));
assert(ISINTEGER(ARG(1,arg)));
i = (int) INTDATA(ARG(0,arg));
j = (int) INTDATA(ARG(1,arg));
assert(i>0 && i <= n);
assert(j>0 && j <= n);
strcpy(reason, english(495)); /* Sub row */
sprintf(buffer," %d ",i);
strcat(reason, buffer);
strcat(reason, english(496)); /* from row */
sprintf(buffer, " %d",j);
--i; /* adjust to zero-based indices for use with ARG */
--j;
/* The operation should affect only the first matrix on each side */
ll = ARG(0,t);
rr = ARG(1,t);
if(addrows_aux(ll,i,j,minusone,&left))
return 1;
if(addrows_aux(rr,i,j,minusone,&right))
return 1;
*next = equation(left,right);
if(FUNCTOR(left) != '*')
return 1;
k = 0;
while(FUNCTOR(ARG(k,left)) != MATRIX)
++k;
if(k == ARITY(left))
return 1;
path[0] = '=';
path[1] = 1; /* left side */
path[2] = '*';
path[3] = (unsigned short)(k+1);
path[4] = MATRIX;
path[5] = (unsigned short)(i+1);
path[6] = 0;
set_pathtail(path);
return 0;
}
/*_______________________________________________________________*/
MEXPORT_ALGEBRA int mulrows(term t, term arg, term *next, char *reason)
/* multiply a row by a constant */
{ term left,right,ll,rr,c;
int i,j,k,err;
unsigned short n;
unsigned short path[7];
char localbuf[82];
char buffer[40];
if(FUNCTOR(t) != '=')
return 1;
if(! is_matrix_product(ARG(0,t),&n))
return 1;
assert(ARITY(arg)==2);
c = ARG(1,arg);
assert(constant(c));
assert(ISINTEGER(ARG(0,arg)));
i = (int) INTDATA(ARG(0,arg));
assert(i>0 && i <= n);
strcpy(reason, english(497)); /* Multiply row */
sprintf(buffer," %d",i);
strcat(reason, buffer);
strcat(reason, english(386)); /* " by " */
mstring(c,localbuf);
j = strlen(localbuf);
/* is there room on first line of reason? */
if(strlen(reason) + j <= MAXREASONSTRING)
strcat(reason,localbuf);
else /* put it on the next line */
{ for(j=strlen(reason); j<=MAXREASONSTRING; j++)
reason[j] = 32; /* finish first line with blanks */
if(j <= MAXREASONSTRING )
strcpy(reason + MAXREASONSTRING, localbuf);
else
strcpy(reason + MAXREASONSTRING, english(387)); /* constant */
}
--i; /* adjust to zero-based indices for use with ARG */
ll = ARG(0,t);
rr = ARG(1,t);
err = mulrows_aux(ll,i,c,&left);
if(err)
return 1;
err = mulrows_aux(rr,i,c,&right);
if(err)
return 1;
*next = equation(left,right);
if(FUNCTOR(left) != '*')
return 1;
k = 0;
while(FUNCTOR(ARG(k,left)) != MATRIX)
++k;
if(k == ARITY(left))
return 1;
path[0] = '=';
path[1] = 1; /* left side */
path[2] = '*';
path[3] = (unsigned short)(k+1);
path[4] = MATRIX;
path[5] = (unsigned short)(i+1);
path[6] = 0;
set_pathtail(path);
return 0;
}
/*_______________________________________________________________*/
MEXPORT_ALGEBRA int divrows(term t, term arg, term *next, char *reason)
/* divide a row by a constant */
{ term left,right,ll,rr,c;
int i,j,k,err;
term oneoverc;
unsigned short path[7];
unsigned short n;
char localbuf[82];
char buffer[40];
if(FUNCTOR(t) != '=')
return 1;
if(! is_matrix_product(ARG(0,t),&n))
return 1;
assert(ARITY(arg)==2);
c = ARG(1,arg);
assert(constant(c));
assert(ISINTEGER(ARG(0,arg)));
i = (int) INTDATA(ARG(0,arg));
assert(i>0 && i <= n);
strcpy(reason, english(2206));
/* Divide row */
sprintf(buffer, " %d", i);
strcat(reason, buffer);
strcat(reason, english(2207)); /* " by " */
mstring(c,localbuf);
j = strlen(localbuf);
/* is there room on first line of reason? */
if(strlen(reason) + j <= MAXREASONSTRING)
strcat(reason,localbuf);
else /* put it on the next line */
{ for(j=strlen(reason); j<=MAXREASONSTRING; j++)
reason[j] = 32; /* finish first line with blanks */
if(j <= MAXREASONSTRING )
strcpy(reason + MAXREASONSTRING, localbuf);
else
strcpy(reason + MAXREASONSTRING, english(387)); /* constant */
}
--i; /* adjust to zero-based indices for use with ARG */
ll = ARG(0,t);
rr = ARG(1,t);
oneoverc = make_fraction(one,c);
err = mulrows_aux(ll,i,oneoverc,&left);
if(err)
return 1;
err = mulrows_aux(rr,i,oneoverc,&right);
if(err)
return 1;
*next = equation(left,right);
if(FUNCTOR(left) != '*')
return 1;
k = 0;
while(FUNCTOR(ARG(k,left)) != MATRIX)
++k;
if(k == ARITY(left))
return 1;
path[0] = '=';
path[1] = 1; /* left side */
path[2] = '*';
path[3] = (unsigned short)(k+1);
path[4] = MATRIX;
path[5] = (unsigned short)(i+1);
path[6] = 0;
set_pathtail(path);
return 0;
}
/*_______________________________________________________________*/
MEXPORT_ALGEBRA int addmulrows(term t, term arg, term *next, char *reason)
{ term left,right,ll,rr,c;
int i,j,k,err;
char buffer[40];
unsigned short n;
unsigned short path[7];
char localbuf[82];
if(FUNCTOR(t) != '=')
return 1;
if(! is_matrix_product(ARG(0,t),&n))
return 1;
assert(ARITY(arg)==3);
c = ARG(0,arg);
assert(constant(c));
assert(ISINTEGER(ARG(1,arg)));
assert(ISINTEGER(ARG(2,arg)));
i = (int) INTDATA(ARG(1,arg));
j = (int) INTDATA(ARG(2,arg));
assert(i>0 && i <= n);
assert(j>0 && j <= n);
strcpy(reason,english(2208)); /* Add */
strcat(reason, " ");
err = mstring(c,localbuf);
if(err || strlen(localbuf) > MAXREASONSTRING-9) /* multiple too long */
strcat(reason, english(387)); /* constant */
else
strcat(reason,localbuf);
strcat(reason, " ");
strcat(reason, english(2209)); /* times */
strcat(reason," ");
strcpy(reason + MAXREASONSTRING, english(2210)); /* row */
sprintf(buffer," %d ",i);
strcat(reason,buffer);
strcat(reason, english(2211)); /* "to row" */
sprintf(buffer, " % d",j);
strcat(reason,buffer);
--i; /* adjust to zero-based indices for use with ARG */
--j;
ll = ARG(0,t);
rr = ARG(1,t);
if(addrows_aux(ll,i,j,c,&left))
return 1;
if(addrows_aux(rr,i,j,c,&right))
return 1;
*next = equation(left,right);
if(FUNCTOR(left) != '*')
return 1;
k = 0;
while(FUNCTOR(ARG(k,left)) != MATRIX)
++k;
if(k == ARITY(left))
return 1;
path[0] = '=';
path[1] = 1; /* left side */
path[2] = '*';
path[3] = (unsigned short)(k+1);
path[4] = MATRIX;
path[5] = (unsigned short)(i+1);
path[6] = 0;
set_pathtail(path);
return 0;
}
/*_______________________________________________________________*/
MEXPORT_ALGEBRA int submulrows(term t, term arg, term *next, char *reason)
{ term left,right,ll,rr,c;
int i,j,k,err;
unsigned short n;
char localbuf[82];
char buffer[40];
unsigned short path[7];
if(FUNCTOR(t) != '=')
return 1;
if(! is_matrix_product(ARG(0,t),&n))
return 1;
assert(ARITY(arg)==3);
c = ARG(0,arg);
assert(constant(c));
assert(ISINTEGER(ARG(1,arg)));
assert(ISINTEGER(ARG(2,arg)));
i = (int) INTDATA(ARG(1,arg));
j = (int) INTDATA(ARG(2,arg));
assert(i>0 && i <= n);
assert(j>0 && j <= n);
strcpy(reason, english(2212)); /* Sub */
strcat(reason, " ");
err = mstring(c,localbuf);
if(err || strlen(localbuf) > MAXREASONSTRING-9) /* multiple too long */
strcat(reason, english(387)); /* constant */
else
strcat(reason,localbuf);
strcat(reason, " ");
strcat(reason, english(2209)); /* times */
strcat(reason," ");
strcpy(reason + MAXREASONSTRING, english(2210)); /* row */
sprintf(buffer, " %d ",i);
strcat(reason,buffer);
strcat(reason, english(2213)); /* from row */
sprintf(buffer," %d",j);
strcat(reason,buffer);
--i; /* adjust to zero-based indices for use with ARG */
--j;
ll = ARG(0,t);
rr = ARG(1,t);
if(addrows_aux(ll,i,j,strongnegate(c),&left))
return 1;
if(addrows_aux(rr,i,j,strongnegate(c),&right))
return 1;
*next = equation(left,right);
if(FUNCTOR(left) != '*')
return 1;
k = 0;
while(FUNCTOR(ARG(k,left)) != MATRIX)
++k;
if(k == ARITY(left))
return 1;
path[0] = '=';
path[1] = 1; /* left side */
path[2] = '*';
path[3] = (unsigned short)(k+1);
path[4] = MATRIX;
path[5] = (unsigned short)(i+1);
path[6] = 0;
set_pathtail(path);
return 0;
}
/*_______________________________________________________________*/
MEXPORT_ALGEBRA int multiplymatrices(term t, term arg, term *next, char *reason)
/* carry out one matrix multiplication */
{ unsigned short n;
int i,j,err,err2;
unsigned short path[7];
term temp;
if(FUNCTOR(t) == '=') /* in auto mode this operator is associated to
equations, not to '*', so that matrices
are left untouched until the equation is
simplified */
{ *next = make_term('=',2);
err = multiplymatrices(ARG(0,t),arg,ARGPTR(*next),reason);
err2 = multiplymatrices(ARG(1,t),arg,ARGPTR(*next)+1,reason);
if(err && err2)
{ RELEASE(*next);
return 1;
}
if(err)
ARGREP(*next,0,ARG(0,t));
if(err2)
ARGREP(*next,1,ARG(1,t));
HIGHLIGHT(*next);
path[0] = '=';
path[1] = (unsigned short) (!err ? 1 : 2);
path[2] = 0;
set_pathtail(path);
return 0;
}
if(FUNCTOR(t) != '*')
return 1;
n = ARITY(t);
/* multiply the first two (adjacent) matrices in t */
for(i=0;i<n-1;i++)
{ if(FUNCTOR(ARG(i,t)) == MATRIX &&
(FUNCTOR(ARG(i+1,t)) == MATRIX || FUNCTOR(ARG(i+1,t)) == VECTOR)
)
break;
}
if(i==n-1)
return 1;
err = matrix_mult(ARG(i,t),ARG(i+1,t),&temp);
if(err!=0 && err != 2)
{ errbuf(0,aem(err));
return 1;
}
if(n==2)
*next = temp;
else
{ *next = make_term('*',(unsigned short)(n-1));
for(j=0;j<n-1;j++)
{ if(j<i) ARGREP(*next,j,ARG(j,t));
if(j==i) ARGREP(*next,j,temp);
if(j>i) ARGREP(*next,j,ARG(j+1,t));
}
}
strcpy(reason, english(2214)); /* matrix multiplication */
HIGHLIGHT(*next);
return 0;
}
/*_______________________________________________________________*/
MEXPORT_ALGEBRA int dividebymatrix(term eqn, term arg, term *next, char *reason)
/* AX = C => X = inv(A) C */
/* Refuse to do it in cases where MathXpert won't be able to compute
the inverse anyway. Specifically, do it only if the matrix is
seminumerical or of dimension 2 or 3.
*/
{ term left, newleft,newright,inv,u,det;
unsigned short n;
int err;
if(FUNCTOR(eqn) != '=')
return 1;
left = ARG(0,eqn);
if(FUNCTOR(left) != '*')
return 1;
u = ARG(0,left);
if(FUNCTOR(u) != MATRIX)
return 1;
/* u is the matrix to be (eventually) inverted */
/* Is it square? */
n = ARITY(u); /* the number of rows */
if(n != ARITY(ARG(0,u)))
{ errbuf(0, english(1346));
return 1; /* Matrix is not square, so you cannot take its inverse.*/
}
if(seminumerical(u))
{ err = determinant(u,&det);
if(err)
{ errbuf(0, english(1348));
/* MathXpert cannot invert this matrix, even though the inverse may exist,
because the numbers involved are quite
large or quite small. */
return 1;
}
}
else if(n==2 || n ==3)
{ err = symbolic_determinant(u,&det);
assert(!err);
}
else
{ errbuf(0, english(1347));
/* MathXpert cannot invert matrices of dimension 4 or more
unless all entries are numerical. */
return 1;
}
if(ISZERO(det))
{ errbuf(0, english(1349));
/* Matrix cannot be inverted, because its determinant is zero. */
return 1;
}
/* Now, the inverse DOES exist and CAN be computed in MathXpert.
So proceed. */
if(ARITY(left)==2)
newleft = ARG(1,left);
else
{ int i;
newleft = make_term('*',(unsigned short)(ARITY(left)-1));
for(i=0;i<ARITY(newleft);i++)
ARGREP(newleft,i,ARG(i+1,left));
}
inv = make_term(MATRIXINVERSE,1);
ARGREP(inv,0,ARG(0,left));
newright = product(inv,ARG(1,eqn));
*next = equation(newleft,newright);
HIGHLIGHT(*next);
strcpy(reason,"X = A^(-1)C if AX=C");
return 0;
}
/*_______________________________________________________________*/
MEXPORT_ALGEBRA int twobytwoinverse(term t, term arg, term *next, char *reason)
/* evaluate MATRIXINVERSE(MATRIX(row1,row2)) */
{ term u,v;
int err;
term a,b,c,d; /* entries of the matrix to be inverted */
term detr, matrixpart;
if(FUNCTOR(t) != MATRIXINVERSE)
return 1;
u = ARG(0,t);
if(FUNCTOR(u) != MATRIX)
return 1;
if(ROWS(u) != 2)
return 1;
if(COLUMNS(u) != 2)
return 1;
a = ENTRY(0,0,u);
b = ENTRY(0,1,u);
c = ENTRY(1,0,u);
d = ENTRY(1,1,u);
detr = sum(product(a,d),tnegate(product(b,c)));
v = ne(detr,zero);
err = check(v);
RELEASE(v);
if(err)
{ errbuf(0,english(1182)); /* matrix not invertible */
return 1;
}
matrixpart = make_matrix(2,2);
*ENTRYPTR(0,0,matrixpart) = d;
*ENTRYPTR(0,1,matrixpart) = tnegate(b);
*ENTRYPTR(1,0,matrixpart) = tnegate(c);
*ENTRYPTR(1,1,matrixpart) = a;
*next = product(make_fraction(one,detr),matrixpart);
HIGHLIGHT(*next);
strcpy(reason,english(2215)); /* formula for 2 by 2 */
strcpy(reason + MAXREASONSTRING, english(2216)); /* matrix inverse */
return 0;
}
/*_______________________________________________________________*/
MEXPORT_ALGEBRA int exactmatrixinverse(term t, term arg, term *next, char *reason)
{ int err;
if(FUNCTOR(t)!=MATRIXINVERSE)
return 1;
err= matrix_inverse(ARG(0,t),0,next);
if(err==1)
{ nospace();
return 1;
}
if(err==53)
{ errbuf(0, english(1182)); /* matrix not invertible */
return 1;
}
if(err)
{ errbuf(0,aem(err));
return 1;
}
strcpy(reason, english(2217)); /* compute inverse */
HIGHLIGHT(*next);
return 0;
}
/*_______________________________________________________________*/
MEXPORT_ALGEBRA int cramersrule(term t, term arg, term *next, char *reason)
{ char localbuf[82];
int i,j,p,err;
term q,lhs,rhs,a,x,denom,num;
term d;
unsigned short n;
if(FUNCTOR(t) != AND)
return 1;
n = ARITY(t); /* number of equations */
err = matrixform(t,arg,&q,localbuf);
if(err)
return 1;
assert(FUNCTOR(q) == '=');
lhs = ARG(0,q);
rhs = ARG(1,q);
if(ARITY(lhs) != 2)
return 1;
a = ARG(0,lhs); /* coefficient matrix */
x = ARG(1,lhs); /* vector of variables */
if(FUNCTOR(rhs) != VECTOR)
return 1;
if(ARITY(ARG(0,a)) != n) /* n is the number of rows, ARITY(ARG(0,a)) is the number of columns */
{ errbuf(0, english(498));
/* Can't use Cramer's rule unless the number of */
errbuf(1, english(499));
/* equations is the same as the number of variables. */
return 1;
}
denom = det1(a); /* denominator in Cramer's rule */
/* Now check for singular equations */
if(seminumerical(a))
{ determinant(a,&d);
err = ZERO(d);
}
else
/* symbolic entries in the determinant */
err = check(nonzero(denom));
if(err) /* singular determinant */
{ errbuf(0, english(1341));
errbuf(1, english(1342));
errbuf(2, english(1343));
/* Cramer's rule would create a zero denominator.
This means your equations are not independent,
so they don't have a unique solution. */
RELEASE(denom);
return 1;
}
*next = make_term(AND,n);
for(p=0;p<n;p++)
{ num = make_matrix(n,n);
for(i=0;i<n;i++)
{ for(j=0;j<n;j++)
*(ENTRYPTR(i,j,num)) = (j==p ? ARG(i,rhs) : ENTRY(i,j,a));
}
ARGREP(*next,p,equation(ARG(p,x),make_fraction(det1(num),denom)));
}
strcpy(reason, english(500)); /* Cramer's rule */
HIGHLIGHT(*next);
return 0;
}
/*_______________________________________________________________*/
static int evaldet_aux(term t, term *next)
/* evaluate all numerical determinants occurring in t */
/* return 0 if there was one to evaluate, 1 if not;
in either case *next is equal to t with the determinants evaluated.
Return 2 if there is an error evaluating the determinant;
then *next is garbage.
*/
{ unsigned short f = FUNCTOR(t);
unsigned short n = ARITY(t);
int i,ans,err;
term u;
if(ATOMIC(t))
{ *next = t;
return 1;
}
if(f == DET && numerical(ARG(0,t)))
{ err = determinant(ARG(0,t),next);
if(err)
{ errbuf(0,aem(err));
return 2;
}
HIGHLIGHT(*next);
return 0;
}
else if(f == DET)
{ err = symbolic_determinant(ARG(0,t),next);
if(err)
{ errbuf(0, english(1345));
/* MathXpert will not evaluate a large determinant containing variables. */
return 2;
}
HIGHLIGHT(*next);
return 0;
}
*next = make_term(f,n);
ans = 1;
for(i=0;i<n;i++)
{ err = evaldet_aux(ARG(i,t),&u);
if(err > 1)
{ RELEASE(*next);
return 2;
}
ARGREP(*next,i,u);
if(err == 0)
ans = 0;
}
return ans;
}
/*_______________________________________________________________*/
MEXPORT_ALGEBRA int evaluatedeterminant(term t, term arg, term *next, char *reason)
/* evaluates a numerical determinant; also
works on a system of linear equations with quotients of
determinants on the right, as produced by Cramer's rule;
the general machinery of autosimp works on only one equation
at a time so if you want all determinants evaluated at once,
the operator has to do it.
*/
{ int err;
unsigned short f = FUNCTOR(t);
if((f == AND && contains(t,DET)) || f == DET)
{ err = evaldet_aux(t,next);
if(err)
return 1;
strcpy(reason, english(501)); /* evaluate determinant */
return 0;
}
return 1;
}
/*______________________________________________________*/
MEXPORT_ALGEBRA int is_matrix_product(term t, unsigned short *n)
/* see if t is a matrix or product containing a matrix and return the
number of rows in n; return 1 for success, 0 for failure */
{ int i;
unsigned short m;
if(FUNCTOR(t)==MATRIX || FUNCTOR(t) == VECTOR)
{ *n = ARITY(t);
return 1;
}
if(FUNCTOR(t) != '*')
return 0;
m = ARITY(t);
for(i=0;i<m;i++)
{ if(FUNCTOR(ARG(i,t))== MATRIX || FUNCTOR(ARG(i,t)) == VECTOR)
break;
}
if(i==m)
return 0;
*n = ARITY(ARG(i,t));
return 1;
}
/*___________________________________________________________*/
static int symbolic_determinant(term t, term *ans)
/* t is a square MATRIX term which contains at least one variable */
/* Evaluate the determinant. Note: numerical determinants are
evaluated using code in matrix.c, based on the LU decomposition
method written for exact arithmetic. LU decomposition has not
been written for MathXpert for arbitrary symbolic entries, only
for numerical entries. This function then works only on simple
cases: n = 2 or n = 3.
Return 0 for success, 1 for failure.
*/
{ term temp;
int i;
unsigned short n = ARITY(t);
if(n==2)
{ temp = sum(product(ENTRY(0,0,t), ENTRY(1,1,t)), tnegate(product(ENTRY(1,0,t), ENTRY(0,1,t))));
polyval(temp,ans);
return 0;
}
if(n==3)
{ temp = make_term('+',6);
for(i=0;i<3;i++)
{ ARGREP(temp,2*i,product3(ENTRY(0,i,t),ENTRY(1,(i+1)%3,t), ENTRY(2,(1+2)%3,t)));
ARGREP(temp,2*i+1, tnegate(product3(ENTRY(0,i,t), ENTRY(1,(i+2)%3,t), ENTRY(2,(i+1)%3,t))));
}
polyval(temp,ans);
return 0;
}
return 1;
}
/*_____________________________________________________________________*/
MEXPORT_ALGEBRA int convertmatrixeqn(term t, term arg, term *next, char *reason)
/* convert an equation of two VECTOR terms to a system of equations */
{ unsigned short n;
term left, right;
int i;
if(FUNCTOR(t) != '=')
return 1;
left = ARG(0,t);
right = ARG(1,t);
if(FUNCTOR(left) != VECTOR || FUNCTOR(right) != VECTOR)
return 1;
n = ARITY(left);
assert(ARITY(right) == n);
*next = make_term(AND,n);
for(i=0;i<n;i++)
ARGREP(*next,i, equation(ARG(i,left),ARG(i,right)));
HIGHLIGHT(*next);
strcpy(reason, english(2218)); /* convert matrix eqn */
return 0;
}
Sindbad File Manager Version 1.0, Coded By Sindbad EG ~ The Terrorists