module pattperm; % Rest of unify --- argument permutation, etc.
% Author: Kevin McIsaac.
% When sym!-assoc is off, PM does not force normal generic variables to
% take more than one argument if a multi-generic symbol is present. This
% makes the patterns much more efficient but not fully searched. Sane
% patterns do not require this. For example
% m(a+b+c,?a+??c) will return {?a -> a, ??c -> null!-fn(b,c)} but not
% {?a -> a+b, ??c -> c} or {?a -> a+b+c, ??c -> null!-fn()}
fluid '(symm op r p i upb identity expand acontract mcontract comb);
global('(!*sym!-assoc))$
global('(!*udebug))$ %print out next information
symbolic procedure first0(u,n);
if n>0 then car u . first0(cdr u,n-1) else nil;
symbolic procedure last0(u,n);
if n<1 then u else last0(cdr u,n-1);
symbolic procedure list!-mgen u;
% Count the number of top level mgen atoms.
begin integer i;
for each j in u do if atom j and mgenp(j) then i := i+1;
return i
end;
symbolic procedure initarg(u);
begin scalar assoc, mgen, flex, filler; integer n, lmgen;
symm := flagp(op,'symmetric);
n := length(p) - length(r) + 1;
identity := ident(op);
mgen := mgenp(car r);
lmgen := list!-mgen(cdr r);
assoc := flagp(op,'assoc)
and not(symm and(lmgen > 0) and not !*sym!-assoc);
flex := (length(r)>1) and (assoc or lmgen);
filler:= n > 1 or (identity and length p > 0);
%
mcontract := mgen and filler;
acontract := assoc and filler and not mgen;
expand := identity and (n < 1 or flex);
%
i := if flex or n < 1 then
if mgen then 0
else 1
else n;
upb := if identity then length p else n + lmgen;
if symm then comb := initcomb u
end;
symbolic procedure nextarg u;
if symm then s!-nextarg u else o!-nextarg u;
symbolic procedure o!-nextarg u;
begin scalar args;
if !*udebug then uprint(nil);
args :=
if (i = 1) and (i <= upb) then u
else if (i = 0) and (i <= upb) then '(null!-fn).u
else if acontract and (i <= upb)
then mval((op . first0(u,i)) . last0(u,i))
else if mcontract and (i <= upb)
then ('null!-fn . first0(u,i)) . last0(u,i)
else if expand then <<expand := nil; identity . u>>;
i := i + 1;
return args
end;
symbolic procedure s!-nextarg u;
begin scalar v, args;
if !*udebug then uprint(nil);
if null comb then<< i := i + 1; comb := initcomb u>>;
args :=
if (v := getcomb(u,comb) ) then
if (i = 1) and (i <= upb) then caar v . cdr v
else if (i = 0) and (i <= upb) then '(null!-fn).u
else if acontract and (i <= upb) then mval((op.car(v)).cdr v)
else if mcontract and (i <= upb) then ('null!-fn.car(v)).cdr v
else if expand then <<expand := nil; identity . u>>
else nil
else if (i = 0) and (i <= upb) then '(null!-fn).u
else if expand then <<expand := nil; identity.u>>;
return args
end;
symbolic procedure getcomb(u,v);
begin scalar group;
comb := nextcomb(v,i);
group := car comb;
comb := cdr comb;
return if group then group . setdiff(u,group) else nil
end$
symbolic procedure uprint(u);
<<if expand then <<prin2('expand);prin2(" ")>>;
if mcontract then <<prin2('mcontract);prin2(" ")>>;
if acontract then <<prin2('acontract);prin2(" ")>>;
prin2(" upb = ");prin2(upb); prin2(" i = ");prin2(i);
if symm then <<prin2('symmetric);prin2(comb)>>;
terpri()>>$
symbolic procedure initcomb(u); u.nil$
symbolic procedure nextcomb(env,n);
% Env is of the form args . env, where args is a list of arguments.
% Value is list of all combinations of n elements from the list u.
begin scalar args, nenv, v; integer i;
args := car env; nenv := cdr env;
return
if n=0 then nil.nil
else if (i:=length(args) - n)<0 then list(nil)
else if i = 0 then args.nil
else if nenv then <<v := nextcomb(nenv,n - 1);
(car(args) . car(v)) .
(if cdr v then args . cdr v
else list cdr(args))>>
else <<v := nextcomb(initcomb(cdr args),n - 1);
(car(args) . car(v)) . (if cdr v then args . cdr v
else list cdr(args))>>
end;
endmodule;
end;