Artifact da3f0a7b66df8038da0f0711bc4b73aedb80a253a8314f70473c953e21c941bd:
- Executable file
r36/src/pm.red
— part of check-in
[f2fda60abd]
at
2011-09-02 18:13:33
on branch master
— Some historical releases purely for archival purposes
git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/trunk/historical@1375 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 35224) [annotate] [blame] [check-ins using] [more...]
module pm; % The PM Pattern Matcher. % Author: Kevin McIsaac. create!-package('(pm pmpatch formgen pattdefn pmintrfc pattperm unify), '(contrib pm)); remflag('(i),'reserved); % This package uses I as a global index!! Comment This is a fairly basic set of definitions for Ap, Map and Ar. It needs some work. The routine Ar is particularly bad; % Pattern directed application. symbolic operator ap; symbolic procedure ap(f,v); if car v neq 'list then typerr(v,'ap) else if not genexp f then if atom f then f . cdr v else append(f,cdr v) else begin scalar nv; nv := idsort union(findnewvars f,nil); v := cdr v; f := sublis(npair(nv, v), f); if length nv < length v then f := append(f,pnth(v,length nv +1)); return f end; symbolic procedure npair(u, v); % Forms list of pairs from unequal length list. Terminates at end of % shortest list. if u and v then (car u . car v) . npair(cdr u, cdr v) else nil; %Pattern directed MAP put('map,'psopfn,'map0); symbolic procedure map0 arg; if length arg < 2 then nil else map1(car arg,cadr arg,if length arg >= 3 then caddr arg else 1); symbolic procedure map1(fn,v,dep); if dep>0 then car v . for each j in cdr v collect map1(fn,j,dep-1) else ap(fn,if atom v or car v neq 'list then list('list, v) else v); put('ar, 'psopfn, 'ar0); % ARange of ARray statement. symbolic procedure ar0 arg; if length arg <= 1 then nil else ar1(car arg, if length arg >= 2 then cadr arg else 'list); symbolic procedure ar1(arg,fn); if fixp arg then ar4(list(list(1,arg,1)),fn) else if atom arg or car arg neq 'list then typerr(arg,'ar) else ar4(for each j in cdr arg collect aarg(j), fn); symbolic procedure aarg(arg); revlis( if fixp arg or genp(arg) then list(1, arg, 1) else if atom arg or car arg neq 'list then typerr(arg,'ar) else begin scalar l; arg := cdr arg; l := length arg; return if l eq 1 then list(1, car arg, 1) else if l eq 2 then list(car arg, cadr arg, 1) else if l eq 3 then list(car arg, cadr arg, caddr arg) else typerr(arg,"Ar") end); symbolic procedure ar4(lst,fn); begin scalar s, u, v, w; u := caar lst; v := cadar lst; w := caddar lst; lst := cdr lst; while u <= v do << s := append(s,list u); u := u + w>>; return if length(lst)=0 then if fn eq 'list then 'list . s else map1(fn, 'list . s, 1) else 'list . for each j in cdr map1(list(lst, fn),'list . s, 1) collect ar4(car j, cdr j); end; put('cat, 'psopfn, 'catx); symbolic procedure catx u; % Concatenate two lists. (if not eqcar(x,'list) then typerr(car u,"list") else if not eqcar(y,'list) then typerr(cadr u,"list") else 'list . append(cdr x,cdr y)) where x=reval car u, y=reval cadr u; %Relational operators. symbolic procedure simpeq(arg); begin scalar x; if length arg < 2 then typerr('equal . arg,"relation"); arg := reval('difference . arg); arg := if numberp arg then reval(arg = 0) else <<arg := list('equal,arg, 0); if x := opmtch(arg) then x else arg>>; return mksq(arg,1) end; symbolic procedure simpgt(arg); begin scalar x; if length arg < 2 then typerr('greaterp . arg,"relation"); arg := reval('difference . arg); arg := if numberp arg then reval(arg > 0) else <<arg := list('greaterp,arg, 0); if x := opmtch(arg) then x else arg>>; return mksq(arg,1) end; symbolic procedure simpge(arg); begin scalar x; if length arg < 2 then typerr('geq . arg,"relation"); arg := reval('difference . arg); arg := if numberp arg then reval(arg >= 0) else <<arg := list('geq,arg, 0); if x := opmtch(arg) then x else arg>>; return mksq(arg,1) end; symbolic procedure simplt(arg); simpgt(list(cadr arg,car arg)); symbolic procedure simple(arg); simpge(list(cadr arg,car arg)); put('equal, 'simpfn, 'simpeq); put('greaterp, 'simpfn, 'simpgt); put('geq, 'simpfn, 'simpge); put('lessp, 'simpfn, 'simplt); put('leq, 'simpfn, 'simple); endmodule; 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; module formgen; % Form function for !?. % Author: Kevin McIsaac. put('!?,'formfn,'formgen)$ symbolic procedure formgen(u,vars,mode); begin scalar x; u := cadr u; if atom u then if u eq '!? then <<u := intern '!?!?; x := list(mkquote u,mkquote 'mgen,t)>> else <<u := intern compress('!! . '!? . explode u); x := list(mkquote u,mkquote 'gen,t)>> else if car u neq '!? then <<u := intern compress('!! . '!? . explode car u) . cdr u; x := list(mkquote car u,mkquote 'gen,t)>> else if car u eq '!? and atom cadr u then <<u := intern compress('!! . '!? . '!! . '!? . explode cadr u); x := list(mkquote u,mkquote 'mgen,t)>> else <<u := cadr u; u := intern compress('!! . '!? . '!! . '!? . explode car u) . cdr u; x := list(mkquote car u,mkquote 'gen,t)>>; return list('progn,'put . x,form1(u,vars,mode)) end; endmodule; module pattdefn; %Notational conveniences and low level routines for the % UNIFY code. % Author: Kevin McIsaac. % Changes by Rainer M. Schoepf 1991. fluid('(freevars op r p i upb identity expand acontract mcontract comb count symm ))$ % Binding routines. These would be more efficient with a more direct % mechanism. symbolic procedure bind(u, v); %push the value of v onto the put(u,'binding,v.get(u,'binding))$ %binding stack of u symbolic procedure binding(u); %Top most binding on stack (lambda x; if x then car x) get(u,'binding)$ symbolic procedure unbind(u); %pop binding off stack put(u,'binding, cdr get(u,'binding))$ symbolic procedure newenv(u); % Mark a new environment. bind(u, 'unbound)$ % Give UNIFY lexical scoping. symbolic procedure restorenv(u); % Should include error checks? unbind(u)$ symbolic procedure pm!:free(u); % Is u a pm unbound free variable? binding(u) eq 'unbound$ symbolic procedure bound(u); % Is u a pm bound free variable? (lambda x; x and (x neq 'unbound)) binding u; symbolic procedure meq(u,v); (lambda x; % (if (x and (x neq 'unbound)) then x else u) eq meval v ) (if (x and (x neq 'unbound)) then x else u) = v) binding u; % This has been fixed. % symbolic procedure meval(u); % if eqcar(u,'minus) and numberp cadr u then -cadr u else u; % Currently Mval does nothing. It should be defined so that nosimp % functions are handled properly. By leaving it out the PM will not % dynamically change pattern it is working on. I.e., % m(f(1,2,3+c),f(?a,?b,?a+?b+?c)) will now return True. If the code % commented out is restored then this will give the expected result. % However m(f(1_=natp 1),f(?a_=natp ?a)), where natp(?x) :- t, will not % work. symbolic procedure mval(u); u; %===> if not atom u then (reval bsubs(car u)) . cdr u %===> else bsubs u; symbolic procedure bsubs(u); % Replaces free atoms by their bindings. Would be nice to mark % expressions that no longer contain bunbound free variables if null u then u else if atom u then if bound(u) then binding u else u else for each j in u collect bsubs j; symbolic procedure ident(op); get(op,'identity)$ symbolic procedure genp(u); atom u and (get(u,'gen) or mgenp(u))$ symbolic procedure mgenp(u); atom u and get(u,'mgen)$ symbolic procedure suchp u; %Is this a such that condition? not atom u and car u eq 'such!-that$ % False if any SUCH conditions are in wich all free variable are bound % does not simplify to T. Should we return free expressions partially % simplified? symbolic procedure chk u; null u or u eq t or (lambda x; if freexp(x) then (lambda y; if null y then nil else if y eq t then list x else x.y) chk(cdr u) else if reval(x) eq t then chk(cdr u) else nil) bsubs car u$ symbolic procedure findnewvars u; if atom u then if genp u then list u else nil else for each j in u conc findnewvars j; symbolic procedure freexp u; if atom u then pm!:free u else freexp car u or freexp cdr u; symbolic procedure genexp u; if atom u then genp u else genexp car u or genexp cdr u; endmodule; 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; 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; module unify; % Main part of unify code. % Author: Kevin McIsaac. % Changes by Rainer M. Schoepf 1991. % The switch semantic, default on, controls use of semantic matching. fluid '(!*semantic substitution); switch semantic; !*semantic := t; symbolic procedure amatch(r,p,suchl,pmstack); if atom r then unify(nil,mval list r,list p,suchl, pmstack) else if not(atom p or (car r neq car p)) then unify(car r,mval cdr r, cdr p, suchl, pmstack) else if suchp r then amatch(cadr r, p, caddr r . suchl, pmstack) else if !*semantic then resume(list('equal,r,p).suchl, pmstack); symbolic procedure suspend(op,r,p,suchl, pmstack); % Process the interrupting operator. amatch(car r, car p,suchl,list(op.cdr r,op.cdr p ). pmstack); symbolic procedure resume(suchl,pmstack); % Resume interrupted operator. if pmstack then amatch(caar pmstack,cadar pmstack,suchl,cdr pmstack) else if chk(suchl) eq t then bsubs substitution; symbolic procedure unify(op,r,p,suchl,pmstack); if null r and null p then resume(suchl,pmstack) % Bottom of arg list. else if null(r) then <<prin2("UNIFY:pattern over-run for function ");print(op);nil>> else if null(p) and not (ident(op ) or mgenp(car r)) then % <<prin2("UNIFY:rule over-run for function ");print(op);NIL>> nil else begin scalar mmatch, st, arg, symm, comb, identity, mcontract, acontract, expand; integer i, upb; if pm!:free(car r) then suchl := genp(car r).suchl; initarg(p); while (not(mmatch) and (arg := nextarg(p))) do begin if not atom(car r) then mmatch := suspend(op,r,arg,suchl, pmstack) else if (pm!:free(car r)) then begin bind(car r, car arg); if (st := chk suchl) then mmatch := unify(op,mval cdr r,cdr arg,st, pmstack); unbind(car r); end else if meq(car r, car arg) then mmatch := unify(op,mval cdr r,cdr arg,suchl, pmstack) end; return mmatch end; endmodule; end;