Artifact a7e5cef387d3453bbca8315f0b39884dd3be5c071925ca341a1599f98fa40bf8:
- Executable file
r37/packages/pm/pmintrfc.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: 15994) [annotate] [blame] [check-ins using] [more...]
- Executable file
r38/packages/pm/pmintrfc.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: 15994) [annotate] [blame] [check-ins using]
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;