reduce-historical/r38/packages/pm/pmpatch.red

module pmpatch; % Patches to make pattern matcher run in REDUCE 3.4.

% Author: Kevin McIsaac.
% Changes by Rainer M .Schoepf

% remflag('(evenp),'opfn);

% remprop('list,'evfn);

% remprop('list,'rtypefn);

% Redefine LISTEVAL so that the arguments are always returned in prefix
% form.

global '(simpcount!* simplimit!*);

symbolic procedure listeval(u,v);
   <<if (simpcount!* := simpcount!*+1)>simplimit!*
       then <<simpcount!* := 0;
              rederr "Simplification recursion too deep">>;
     u := if atom u
            then listeval(if flagp(u,'share) then eval u
                           else cadr get(u,'avalue),v)
           else car u . for each x in cdr u collect reval1(x,t);
     simpcount!* := simpcount!*-1;
     u>>;


% Allow EXPR as a keyword in patterns.

% remprop('expr,'stat);

% Make REVAL of an equation return a simplified value.

fluid '(substitution);

symbolic procedure equalreval u;
  if null substitution then 'equal . car u . list reval cadr u
   else if evalequal(car u,cadr u) then t
   else 0;

% Define function to prevent simplification of arguments of symbolic
% operators.
% If the i'th element of `list' is `nil' then the i'th argument of `fn'
% is left unsimplified by simp.  If `list' is longer that the argument
% list of `fn' then the extra indicators are ignored.  If `list' is
% shorter than the argument list of `fn' then the remaining arguments
% are simplified, eq nosimp(cat,'(nil T nil)) will cause the 1 and third
% arguments of the functions `cat' to be left un simplified.

symbolic procedure nosimp(fn,list);
  <<put(fn, 'nosimp, list);>>;

symbolic operator nosimp;

flag('(nosimp), 'noval);

symbolic procedure fnreval(u,v,mode);
   % Simplify list u according to list v. If mode is NIL use AEVAL
   % else use REVAL.
   if null u then nil
    else if v eq t then u
    else if null v then for each j in u collect reval1(j ,mode)
    else ((if car v then car u
           else reval1(car u, mode)) . fnreval(cdr u,cdr v,mode));

% Next two routines are changes to module SIMP to add NOSIMP code.

symbolic procedure opfneval u;
   lispeval(car u . for each j in 
                  (if flagp(car u,'noval) then cdr u 
                  else fnreval(cdr u,get(car u,'nosimp),t))
                            collect mkquote j);

fluid '(ncmp!* subfg!*);

symbolic procedure simpiden u;
   % Convert the operator expression U to a standard quotient.
   % Note: we must use PREPSQXX and not PREPSQ* here, since the REVOP1
   % in SUBS3T uses PREPSQXX, and terms must be consistent to prevent a
   % loop in the pattern matcher.
   begin scalar bool,fn,x,y,z,n;
    fn := car u; u := cdr u;
    if x := valuechk(fn,u) then return x;
    if not null u and eqcar(car u,'list)
      then return mksq(list(fn,aeval car u),1);
    % *** Following line added to add nosimp code.
    x := fnreval(u, get(fn, 'nosimp),nil);
%    x := for each j in cdr u collect aeval j;
    u := for each j in x collect
              if eqcar(j,'!*sq) then prepsqxx cadr j
               else if numberp j then j
               else <<bool := t; j>>;
    if u and car u=0
       and flagp(fn,'odd) and not flagp(fn,'nonzero)
      then return nil ./ 1;
    u := fn . u;
    if flagp(fn,'noncom) then ncmp!* := t;
    if null subfg!* then go to c
     else if flagp(fn,'linear) and (z := formlnr u) neq u
      then return simp z
     else if z := opmtch u then return simp z
     else if z := get(car u,'opvalfn) then return apply1(z,u);
 %    else if null bool and (z := domainvalchk(fn,
 %                for each j in x collect simp j))
 %     then return z;
    c:  if flagp(fn,'symmetric) then u := fn . ordn cdr u
         else if flagp(fn,'antisymmetric)
          then <<if repeats cdr u then return (nil ./ 1)
              else if not permp(z:= ordn cdr u,cdr u) then y := t;
        % The following patch was contributed by E. Schruefer.
        fn := car u . z;
        if z neq cdr u and (z := opmtch fn)
          then return if y then negsq simp z else simp z;
        u := fn>>;
    if (flagp(fn,'even) or flagp(fn,'odd))
       and x and minusf numr(x := simp car x)
     then <<if flagp(fn,'odd) then y := not y;
        u := fn . prepsqxx negsq x . cddr u;
        if z := opmtch u
          then return if y then negsq simp z else simp z>>;
    u := mksq(u,1);
    return if y then negsq u else u
   end;

endmodule;

end;