module pmintrfc; % Interface for pattern matcher.
% Author: Kevin McIsaac.
% Changes by Rainer M. Schoepf 1991.
% For some reason, this doesn't like being compiled as a module.
% REDUCE syntax for pattern matching.
%
% ?a
% This is an ordinary pattern matching variable. It can any value.
%
% ??a
% This is a segment pattern variable. I can take any value as does ?a
% or a set of values.
%
% ?a_=cond
% ?a can only be matched is the condition does not evaluate to false
%
% exp1 -> exp2
% exp1 is replaced by exp2
%
% exp1 --> exp2
% exp1 is replaced by exp2, RHS is quoted. exp2 is simplified after
% replacement
%
% M(exp,pat)
% Returns a list of replacements for pm variables in pat such that pat
% and exp are equal. Where defined the properties of symmetry, assoc-
% iativity and the identity element are used to match the expressions.
%
% S(exp,rep,rpt:1,depth:Inf) or S(exp,{rep1,rep2,...},rpt:1,depth:Inf)
% The lhs of rep is matched against exp and subexpressions of exp.
% When a match is found the replacements for pm variables in rhs are
% substituted into the lhs and the resultant expression is used as a
% replacement. This is done to a maximum (tree) depth of dept, with a
% maximum number of repeats rpt, to a (tree) depth of dept.
% S(exp,rep,depth:Inf) or S(exp,{rep1,rep2,...},depth:Inf)
% Shorthand notation for S with Inf number of rpt's
%
% exp1 :- exp2
% exp1 is added to a global list of automatic replacements. Most
% specific rules are ordered before less specific rules. If a rule
% already exists the the rule is replaced unless exp2 is null in which
% case the rule is deleted.
%
% exp1 ::- exp2
% as above except the RHS is quoted.
%
fluid '(!*trpm rpt subfg!* substitution varstack!*);
switch trpm;
put('m,'psopfn,'mx);
symbolic procedure mx u; m1(reval car u,reval cadr u);
symbolic procedure m1(exp, temp);
begin scalar substitution, mmatch, count, freevars;
count := 0;
freevars := idsort union(findnewvars temp,nil);
substitution := if freevars then freevars else t;
for each j in freevars do newenv j;
mmatch := amatch(temp, exp, t, nil);
for each j in freevars do restorenv j;
if mmatch then return
if freevars then 'list . for each j in pair(freevars, mmatch)
collect list('rep, car j, cdr j)
else t
end;
symbolic procedure fixreplist(repset);
% Check that repset is properly formed and add multi-generic
% variables to assoc functions.
begin scalar replist;
if car(repset) memq '(rep repd) then replist := list(repset)
else replist := cdr repset;
replist := for each rep in replist collect fixrep(rep);
return replist
end;
Comment It is necessary to replace all free variables by unique ones
in order to avoid confusion during the superset operation.
To this end we generate replace them by special gensyms
before putting them in the rules database. This is not
visible to the user;
fluid '(pm!:gensym!-count!*);
symbolic (pm!:gensym!-count!* := 0);
symbolic procedure pm!:gensym;
compress ('!? . '!_ .
explode (pm!:gensym!-count!* := pm!:gensym!-count!* + 1));
fluid '(freevarlist!*);
symbolic procedure make!-unique!-freevars form;
if atom form then
if get(form,'gen) then begin scalar x;
x := atsoc (form, freevarlist!*);
if null x then << x := (form . pm!:gensym());
put (cdr x, 'gen, t);
freevarlist!* := x . freevarlist!*>>;
return cdr x
end
else form
else for each x in form collect make!-unique!-freevars x;
symbolic procedure fixrep(repl);
<< (repl := make!-unique!-freevars repl) where freevarlist!* := nil;
% Should check if the extra multi-generic variables are required.
if flagp(caadr repl,'assoc) then
if flagp(caadr repl,'symmetric) then
list(car repl,append(cadr repl,list('!?!?!;)),
list(caadr repl,caddr repl,'!?!?!;))
else
list(car repl,caadr(repl) .
('!?!?!^ . append(cdadr repl,list('!?!?!;))),
list(caadr repl,'!?!?!^,caddr repl,'!?!?!;))
else repl >>;
put('s,'psopfn,'sx);
symbolic procedure sx arg;
% Fill in args for s0. Default: repeat 1, depth Inf.
reval
s0(reval car arg, reval cadr arg,
if cddr arg then reval caddr arg else 1,
if cddr arg and cdddr arg then reval car cdddr arg
else 'inf);
put('si,'psopfn,'si!-x);
symbolic procedure si!-x arg;
% Fill in args for s0. Default: repeat Inf, depth Inf.
reval
s0(reval car arg,reval cadr arg, 'inf,
if cddr arg then reval caddr arg else 'inf);
symbolic procedure s0(exp, repset,rpt,depth);
% Breadth first search. Rpt is passed as a fluid.
if length repset <= 1 or not memq(car repset,'(rep repd list))
then exp
else if (depth neq 'inf and depth < 0)
or (rpt neq 'inf and rpt <=0) or atom(exp) then exp
else sbreadth(exp,fixreplist repset,depth) ;
symbolic procedure sbreadth(exp,replist,depth);
% Substitute a set of replacements into the root expression until
% expression stops changing, then recurse on all the sub expressions.
<<exp:= sroot(exp,replist);
if (depth neq 'inf and depth <= 0)
or (rpt neq 'inf and rpt <=0) or atom(exp) then exp
else ssbreadth(exp,replist,
if depth neq 'inf then depth-1 else depth)>>;
symbolic procedure ssbreadth(exp,replist,depth);
begin scalar newexp, new, reps;
if (depth neq 'inf and depth < 0)
or (rpt neq 'inf and rpt <= 0) or atom(exp) then return exp;
repeat
begin
new := nil;
reps := replist;
a: exp := reval for each subexp in exp collect
<< newexp := sroot1(subexp,car reps) ;
new := new or (subexp neq newexp);
newexp
>>;
if not (new or null(reps := cdr reps)) then go to a;
end
until(atom exp or not new);
return
if (depth neq 'inf and depth <= 0)
or (rpt neq 'inf and rpt <= 0) or atom(exp) then exp
else for each subexp in exp collect
ssbreadth(subexp,replist,
if depth neq 'inf then depth-1 else depth)
end;
put('sd,'psopfn,'sdx);
symbolic procedure sdx arg;
% Fill in args for sd0. Default: repeat 1, depth inf.
reval
sd0(reval car arg,reval cadr arg,
if cddr arg then reval caddr arg else 1,
if cddr arg and cdddr arg then reval car cdddr arg
else 'inf);
put('sdi,'psopfn,'sdi);
symbolic procedure sdi arg;
% Fill in args for sd0. Default: repeat Inf, depth Inf.
reval
sd0(reval car arg,reval cadr arg, 'inf,
if cddr arg then reval caddr arg else 'inf);
symbolic procedure sd0(exp, repset,rpt,depth);
% Depth first search.
if length repset <= 1 or not memq(car repset,'(rep repd list))
then exp
else if (depth neq 'inf and depth < 0)
or (rpt neq 'inf and rpt <= 0) or atom(exp) then exp
else sdepth(exp,fixreplist repset,depth) ;
symbolic procedure sdepth(exp,replist,depth);
<<exp:= sroot(exp,replist);
if (depth neq 'inf and depth <= 0)
or (rpt neq 'inf and rpt <= 0) or atom(exp) then exp
else car(exp) . for each subterm in cdr exp collect
sdepth(subterm,replist,
if depth neq 'inf then depth-1 else depth)>>;
symbolic procedure sroot(exp,replist);
% Substitute a set of replacements into a root expression until the
% expression stops changing. When a replacement succeeds the
% substitution process restarts on the new expression at the
% beginning of the replacement list.
begin scalar oldexp, reps;
if (rpt neq 'inf and rpt <=0) or atom(exp) then return exp;
repeat
begin
oldexp := exp;
reps := replist;
a: exp := sroot1(exp,car reps);
if not(exp neq oldexp or null(reps := cdr reps)) then go to a;
if exp neq oldexp then exp := reval exp
end
until(atom exp or exp eq oldexp);
return exp;
end;
symbolic procedure sroot1(exp,rep);
% Try to substitute a single replacement into a root expression once
% only.
begin scalar freevars,substitution,mmatch;
if (rpt neq 'inf and rpt <=0) or
atom(exp) or (car(exp) neq caadr(rep)) then return exp;
freevars := union(findnewvars cadr rep,nil);
substitution := caddr rep;
for each j in freevars do newenv j;
if !*trpm then <<write("Trying rule "); rprint(rep);
write("against "); rprint(exp)>>;
mmatch := amatch(cadr rep, exp, t,nil);
if !*trpm
then <<if mmatch then <<write("producing ");
rprint(mmatch := embed!-null!-fn mmatch)>>
else <<write("failed"); terpri()>>;
terpri()>>;
for each j in freevars do restorenv j;
return if mmatch then
<< if (rpt neq 'inf) then rpt := rpt - 1;
embed!-null!-fn mmatch>>
else exp
end;
symbolic procedure embed!-null!-fn u;
if atom u then u
else for each j in u conc
if atom j then list(j)
else if car j eq 'null!-fn then embed!-null!-fn cdr j
else list(embed!-null!-fn j);
algebraic operator null!-fn;
% Code for printing null-fn(a,b,...) as [a,b,...]. Modeled on LIST code.
put('null!-fn,'prifn,'null!-fn!-pri);
fluid '(orig!* posn!*);
symbolic procedure null!-fn!-pri l;
% This definition is basically that of INPRINT, except that it
% decides when to split at the comma by looking at the size of
% the argument.
(begin scalar split,u;
u := l;
l := cdr l;
prin2!* "[";
orig!* := if posn!*<18 then posn!* else orig!*+3;
if null l then go to b;
split := treesizep(l,40); % 40 is arbitrary choice.
a: maprint(negnumberchk car l,0);
l := cdr l;
if null l then go to b;
oprin '!*comma!*;
if split then terpri!* t;
go to a;
b: prin2!* "]";
return u
end)
where orig!* := orig!*;
% Assignments and automatic replacements.
symbolic operator rset;
symbolic procedure rset(temp,exp);
% Add new rule to rule list. If RHS is null then delete rule.
if atom temp then setk(temp,exp)
else begin scalar oldsubfg!*,varstack!*;
%rebind subfg. Don't do this do that(yuck..lisp..)
% rebind varstack!* since the template is simplified again
oldsubfg!* := subfg!*; subfg!* := nil;
temp := reval temp;
put(car temp,'opmtch,
rinsert(fixrep('rset . list(temp,exp)),
get(car temp,'opmtch)));
subfg!* := oldsubfg!*;
return exp
end;
symbolic operator rsetd;
symbolic procedure rsetd(temp,exp);
% Delayed version.
if atom temp then 'hold . setk(temp,exp)
else 'hold . list
begin scalar oldsubfg!*,varstack!*;
%rebind subfg. Don't do this do that(yuck..lisp..)
oldsubfg!* := subfg!*; subfg!* := nil;
temp := reval temp;
put(car temp,'opmtch,
rinsert(fixrep('rsetd . list(temp,exp)),
get(car temp,'opmtch)));
subfg!* := oldsubfg!*;
return exp
end;
symbolic procedure rinsert(rule,rulelist);
% Insert rule in rule list so that most specific rules are found first.
% Use super-set idea, due to Grief. If an equivalent rule exits then
% replace with new rule. A new rule will be placed as far down the rule
% list as possible If the RHS of rule is nil then delete the rule.
if null rulelist or not atom caar rulelist then rule . rulelist
else
(lambda ss;
if ss eq 'equal then
if cadr rule then rule . cdr(rulelist)
else cdr(rulelist)
else if ss eq 't then rule . rulelist
else car(rulelist) . rinsert(rule,cdr rulelist))
superset(cadar rulelist,cadr rule);
symbolic procedure superset(temp1,temp2);
begin scalar mmatch;
mmatch := m1(temp2,temp1);
return(
if null mmatch then nil
else if mmatch eq 't then 'equal
else if not bound2gen(cdr mmatch) then t
else if null (mmatch := m1(temp1,temp1)) then t
else 'equal)
end;
symbolic procedure bound2gen(replist);
% True if all Generic variables are bound to generic variables.
null replist or (genp(caddar replist) and bound2gen(cdr replist));
symbolic operator arep;
symbolic procedure arep(replist);
% Add the replacements in replist to the list of automatically
% applied replacements.
if atom replist then replist
else if car replist eq 'rep
then list('rset ,cadr replist,caddr replist)
else if car replist eq 'repd
then list('rsetd,cadr replist,caddr replist)
else if car replist eq 'list then
% '!*set!* . for each rep in cdr replist collect arep(rep)
'list . for each rep in cdr replist collect arep(rep)
else nil;
symbolic operator drep;
symbolic procedure drep(replist);
% Delete the replacements in replist from the list of automatically
% applied replacements.
if atom replist then replist
else if car replist eq 'rep then list('rset ,cadr replist,nil)
else if car replist eq 'repd then list('rsetd,cadr replist,nil)
else if car replist eq 'list then
% '!*set!*.for each rep in cdr replist collect Drep(rep)
'list . for each rep in cdr replist collect drep(rep)
else nil;
symbolic procedure opmtch(exp);
begin scalar oldexp, replist, rpt;
rpt := 'inf;
replist := get(car exp, 'opmtch);
if null(replist) or null subfg!* then return nil;
oldexp := exp;
repeat
exp := if (atom caar replist) then sroot1(exp, car replist)
else oldmtch(exp,car replist)
until (exp neq oldexp or null(replist := cdr replist));
return if exp eq oldexp then nil else exp
end;
symbolic procedure oldmtch(exp,rule);
begin scalar x, y;
y := mcharg(cdr exp, car rule,car exp);
while (y and null x) do
<<x := if eval subla(car y,cdadr rule)
then subla(car y,caddr rule);
y := cdr y>>;
return if x then x else exp
end;
put('!?,'gen,t);
put('!?!?!;,'mgen,t);
put('!?!?!$,'mgen,t);
put('!?!?!^,'mgen,t);
symbolic operator prop!-alg;
newtok '((!_) prop!-alg);
symbolic procedure prop!-alg(f);
begin scalar x;
x := prop f;
while x do <<prin2(car x); prin2(" "); print(cadr x); print(" ");
x := cddr x>>
end;
symbolic operator preceq;
symbolic procedure preceq(u,v);
% Give u same precedence as v.
<<put(u,'op,get(v,'op));
put(u,'infix,get(v,'infix));>>;
newtok '((!: !- ) rset);
newtok '((!: !: !- ) rsetd);
newtok '((!- !>) rep);
newtok '((!- !- !>) repd);
newtok '((!_ !=) such!-that);
flag ('(such!-that), 'spaced); % _ adjacent to symbols causes problems.
algebraic;
infix :-;
nosimp(:-,'(t nil));
%precedence :-,:=; %can't do this
infix ::-;
nosimp(::-,'(t t));
precedence rsetd,rset;
infix ->;
precedence ->,rsetd;
infix -->;
nosimp(-->,'(nil t));
precedence -->,->;
infix _=;
nosimp(_=,'(nil t));
precedence _=,-->;
operator hold;
nosimp(hold,t);
flag('(rset rsetd rep repd such!-that), 'right);
preceq(rsetd,rset);
preceq(-->,->);
flag('(plus times expt),'assoc);
endmodule;
end;