#### pmrules.red1.9 KB Permalink History Raw

 123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108 ``````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; ``````