File r36/src/pmrules.red artifact e885ce0919 part of check-in 12412d85b9

module pmrules;   % Basic rules for PM pattern matcher.

% Author:  Kevin McIsaac.

create!-package('(pmrules), '(contrib pm));

% Other packages needed.

load!-package 'pm;

algebraic;

% Define logical operators;
% These routines are used so often they should be coded in LISP
% for efficiency.

operator ~; deflist('((!~ !~)),'unary); %precedence ~,not;

infix &; deflist('((!& !&)),'unary); precedence &, and;

infix |; deflist('((!| !|)),'unary); precedence |, or;

flag('( & |), 'nary);

flag('( & |),'symmetric);

&(t) :- t; % We must have this else the fourth rule => &(t) -> &() -> 0

&(0) :- 0;

&(0, ??b) :- 0;

&(t, ??b) ::- &(??b);

&(?a,?a,??b) ::- &(?a,??b);

&(?a,~?a,??b) ::- 0;

|(t) :- t;
|(0) :- 0;
|(t,??a) :- t;
|(0,??a) ::- |(??a);
|(?a,?a,??b) ::- |(?a,??b);
|(?a,~?a) :- t;
|(?a,~?a,??b) ::- |(??b);

~(t) :- 0;
~(0) :- t;


% Define SMP predicates in terms of their REDUCE equivalents.


symbolic procedure simpbool u;
  begin scalar x;
  x := get(car u,'boolfn) or car u;
  u := for each j in cdr u collect reval j;
  u := apply (x, u);
  return (if u then !*k2f t else 0) ./ 1
 end;

flag('(numberp fixp), 'full);

put('numberp,'simpfn,'simpbool);
put('fixp,'simpfn,'simpbool);



operator numbp, posp, intp, natp, oddp, evnp, complexp, listp;

numbp(?n _=numberp(?n)) :- t;
numbp(?n/?m _=(numberp(?n)&numberp(?m))) :- t;

posp(?n _=(numbp(?n)&?n > 0)) :- t;
posp(?n _=(numbp(?n)&~(?n > 0))) :- 0;

intp(?n _=(numbp(?n)&fixp(?n))) :- t;
intp(?n _=(numbp(?n)&~ fixp(?n))) :- 0;

natp(?i _=(numbp(?i)& intp(?i)&?i>0)) :-t;
natp(?i _=(numbp(?i)&~(intp(?i)&?i>0))) :- 0;

oddp(?x _=(numbp(?x)&intp((?x+1)/2))) :- t;
oddp(?x _=(numbp(?x)&~ intp((?x+1)/2))) :- 0;

evnp(?x _=(numbp(?x)&intp(?x/2))) :- t;
evnp(?x _=(numbp(?x)&~ intp(?x/2))) :- 0;

complexp(i) :- t;
complexp(??b*i) :- t;
complexp(??a + i) :- t;
complexp(??a + ??b*i) :- t;

listp({??x}) :- t;
listp(?x) :- 'nil;

%Polyp
%Primep
%Projp
%Ratp
%Contp
%Fullp
%Symbp

endmodule;


end;