reduce-historical: Artifact [0305241679]

Artifact 0305241679e578b926e7cbf51c2d46f03df2f440604ac5f5b12f6b461fa07852:

Executable file r37/packages/solve/solvetab.red — part of check-in [f2fda60abd] at 2011-09-02 18:13:33 on branch master — Some historical releases purely for archival purposes
git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/trunk/historical@1375 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 7811) [annotate] [blame] [check-ins using] [more...]
Executable file r38/packages/solve/solvetab.red — part of check-in [f2fda60abd] at 2011-09-02 18:13:33 on branch master — Some historical releases purely for archival purposes
git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/trunk/historical@1375 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 7811) [annotate] [blame] [check-ins using]

module solvetab;   % Simplification rules for SOLVE.

% Author: David R. Stoutemyer.

% Modifications by: Anthony C. Hearn, Donald R. Morrison, Rainer
%                   Schoepf and Herbert Melenk.

put('asin, 'inverse, 'sin);

put('acos, 'inverse, 'cos);

put('atan,'inverse,'tan);

put('acot,'inverse,'cot);

put('asec,'inverse,'sec);

put('acsc,'inverse,'csc);

algebraic;

Comment Rules for reducing the number of distinct kernels in an
   equation;

operator sol;

% for all a,b,c,d,x such that ratnump c and ratnump d let
%    sol(a**c-b**d, x) = a**(c*lcm(c,d)) - b**(d*lcm(c,d));

for all a,b,c,d,x such that not fixp c and ratnump c and
                            not fixp d and ratnump d let
   sol(a**c-b**d, x) = a**(c*lcm(den c,den d))
                     - b**(d*lcm(den c,den d));

for all a,b,c,d,x such that a freeof x and c freeof x let
   sol(a**b-c**d, x) = e**(b*log a - d*log c);

for all a,b,c,d,x such that a freeof x and c freeof x let
   sol(a*log b + c*log d, x) = b**a*d**c - 1;
%% sol(a*log b - c*log d, x) = b**a - d**c


for all a,b,c,d,f,x such that a freeof x and c freeof x let
   sol(a*log b + c*log d + f, x) = sol(log(b**a*d**c) + f, x);
%% sol(a*log b + c*log d - f, x) = sol(log(b**a*d**c) - f, x),
%% sol(a*log b - c*log d + f, x) = sol(log(b**a/d**c) + f, x),
%% sol(a*log b - c*log d - f, x) = sol(log(b**a/d**c) - f, x)


for all a,b,d,f,x such that a freeof x let
   sol(a*log b + log d + f, x) = sol(log(b**a*d) + f, x),
%% sol(a*log b + log d - f, x) = sol(log(b**a*d) - f, x),
   sol(a*log b - log d + f, x) = sol(log(b**a/d) + f, x);
%% sol(a*log b - log d - f, x) = sol(log(b**a/d) - f, x),
%% sol(log d - a*log b + f, x) = sol(log(d/b**a) + f, x),
%% sol(log d - a*log b - f, x) = sol(log(d/b**a) - f, x)


%%%%for all a,b,c,d,x such that a freeof x and c freeof x let
%%%%   sol(a*log b + c*log d, x) = b**a*d**c - 1,
%%%%   sol(a*log b - c*log d, x) = b**a - d**c;

for all a,b,d,x such that a freeof x let
   sol(a*log b + log d, x) = b**a*d - 1,
   sol(a*log b - log d, x) = b**a - d;
%% sol(log d - a*log b, x) = d - b**a;

for all a,b,c,x let
   sol(log a + log b + c, x) = sol(log(a*b) + c, x),
   sol(log a - log b + c, x) = sol(log(a/b) + c, x);
%% sol(log a + log b - c, x) = sol(log(a*b) - c, x),
%% sol(log a - log b - c, x) = sol(log(a/b) - c, x)


for all a,c,x such that c freeof x let
   sol(log a + c, x) = a - e**(-c);
%% sol(log a - c, x) = a - e**c;

for all a,b,x let
   sol(log a + log b, x) = a*b - 1,
   sol(log a - log b, x) = a - b,
%  sol(cos a - sin b, x) = sol(cos a - cos(pi/2-b), x),
%  sol(sin a + cos b, x) = sol(sin a - sin(b-pi/2), x),
%  sol(sin a - cos b, x) = sol(sin a - sin(pi/2-b), x),
   sol(sin a + sin b, x) = if !*allbranch then sin((a+b)/2)*
       cos((a-b)/2) else a+b,
   sol(sin a - sin b, x) = if !*allbranch then sin((a-b)/2)*
       cos((a+b)/2)  else a-b,
   sol(cos a + cos b, x) = cos((a+b)/2)*cos((a-b)/2),
   sol(cos a - cos b, x) = if !*allbranch then sin((a+b)/2)*
       sin((a-b)/2)  else a-b,
   sol(asin a - asin b, x) = a-b,
   sol(asin a + asin b, x) = a+b,
   sol(acos a - acos b, x) = a-b,
   sol(acos a + acos b, x) = a-b;

solve_trig_rules := {sin(~x + ~y) => sin x * cos y + cos x * sin y,
                     sin(~x - ~y) => sin x * cos y - cos x * sin y,
                     cos(~x + ~y) => cos x * cos y - sin x * sin y,
                     cos(~x - ~y) => cos x * cos y + sin x * sin y};

fluid '(solve_invtrig_soln!*);

share solve_invtrig_soln!*;

clear solve_invtrig_soln!*;

invtrig_solve_rules := {
   sol(asin(~x) + ~y,~z) => solve_invtrig_soln!*
                 when check_solve_inv_trig('sin,asin(x) + y,z),
   sol(acos(~x) + ~y,~z) => solve_invtrig_soln!*
                 when check_solve_inv_trig('cos,acos(x) + y,z),
   sol(atan(~x) + ~y,~z) => solve_invtrig_soln!*
                 when check_solve_inv_trig('tan,atan(x) + y,z),
   sol(acos(~x) + ~y,~z) => solve_invtrig_soln!*
                 when check_solve_inv_trig('sin,acos(x) + y,z),
   sol(atan(~x) + ~y,~z) => solve_invtrig_soln!*
                 when check_solve_inv_trig('sin,atan(x) + y,z),
   sol(asin(~x) + ~y,~z) => solve_invtrig_soln!*
                 when check_solve_inv_trig('cos,asin(x) + y,z),
   sol(atan(~x) + ~y,~z) => solve_invtrig_soln!*
                 when check_solve_inv_trig('cos,atan(x) + y,z),
   sol(~n*asin(~x) + ~y,~z) => solve_invtrig_soln!*
                 when check_solve_inv_trig('sin,n*asin(x) + y,z),
   sol(~n*acos(~x) + ~y,~z) => solve_invtrig_soln!*
                 when check_solve_inv_trig('cos,n*acos(x) + y,z),
   sol(~n*acos(~x) + ~y,~z) => solve_invtrig_soln!*
                 when check_solve_inv_trig('sin,n*acos(x) + y,z),
   sol(~n*atan(~x) + ~y,~z) => solve_invtrig_soln!*
                 when check_solve_inv_trig('sin,n*atan(x) + y,z),
   sol(~n*asin(~x) + ~y,~z) => solve_invtrig_soln!*
                 when check_solve_inv_trig('cos,n*asin(x) + y,z),
   sol(~n*atan(~x) + ~y,~z) => solve_invtrig_soln!*
                 when check_solve_inv_trig('cos,n*atan(x) + y,z)
};

let invtrig_solve_rules;

% The following rules allow REDUCE to solve some classes of equations 
% where a variable appears inside and outside a log or an exponential.
% The results are based on Lambert's W (Omega) function which is fully
% supported in the specfn package. The ruleset has one central rule 
% which produces the Omega function expression in the simplest (rather
% special) form, while the more general cases are mapped towards this 
% rule by reforming the equation algebraically or by variable
% transformations.

lambert_rules := {
          % Basic solution of x=log(c*x/d)

    sol(~x + log(~~c*~x/~~d),~x) => x - lambert_w(d/c)
         when c freeof x and d freeof x,

   
          % General forms transformed to simpler ones.

    sol(~~a*~x + ~~b*log(~c) + ~w,x) 
             => sol(a*x + b*log(c*e^(w/b)), x)
	 when a freeof x and b freeof x and w freeof x
	    and not(c freeof x),

    sol(~~a*~x + ~~b*log(~~c*x/~~d),x) 
             => sub(x=a*x/b, sol(x + log(c*b*x/(a*d)),x))
         when (a neq 1 or b neq 1) and
          a freeof x and b freeof x and c freeof x and d freeof x,

    sol(~~a*~x + ~~b*log((~~c*x + ~u)/~~d),x) 
             => sub(x=x+u/c, sol(num(a*(x-u/c) + b*log(c*x/d)),x))
         when 
          a freeof x and b freeof x and c freeof x 
             and d freeof x and u freeof x,

    sol(~~a*~x + ~~b*log((~~c*x^~n)/~~d),x) 
             => 
               sol(num(a*x + n*b*log x + 1/n*log(c/d)),x)
         when 
          a freeof x and b freeof x and c freeof x 
             and d freeof x and n freeof x,

    sol(~~a*~x^~~n + ~~b*e^(~~c*~x/~~d),x)
            => sol(num(log(a) + n*log(x) - (log(-b)*d + c*x)/d), x) 
         when
          a freeof x and b freeof x and c freeof x 
             and d freeof x and n freeof x,

    sol(~~a*~x + ~~b*e^(~~c*~x/~~d) + ~f,x)
	=> sub(x=a*x+f/a,sol(num(x + b*e^(-c*f/(a*d))*e^(c*x/(a*d))),x))
         when
          a freeof x and b freeof x and c freeof x 
             and d freeof x and f freeof x
}$         

% let lambert_rules;

symbolic procedure lambertp(e1,x); 
        smemq('log,e1) or smemq('expt,e1);

symbolic;

fluid '(sol!-rulesets!*);

sol!-rulesets!*:={{'lambertp,'lambert_rules}};

symbolic procedure solve!-apply!-rules(e1,var);
  begin scalar rules,u;
    u:=list('sol,mk!*sq(e1 ./ 1), var);
    for each r in sol!-rulesets!* do
      if apply(car r,{e1,var}) then rules := cadr r . rules;
    if null rules then return simp!* u;
    return car evalletsub2({rules,{'simp!*, mkquote u}},nil);
  end;
    
endmodule;

end;