Artifact add42ce901c8aa7feef35670b428a670102b8f19d696a2afeab9f8af8ea6fae6:
- Executable file
r38/packages/alg/opmtch.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: 10705) [annotate] [blame] [check-ins using] [more...]
module opmtch; % Functions that apply basic pattern matching rules. % Author: Anthony C. Hearn. % Copyright (c) 2000 Anthony C. Hearn. All rights reserved. fluid '(frlis!* matchlength!* subfg!*); matchlength!* := 5; % Maximum number of arguments checked in matching. share matchlength!*; % Operator // for extended quotient match to be used only in the % lhs of a rule. newtok '((!/ !/) slash); mkop 'slash; infix slash; precedence slash, quotient; % put('slash,'simpfn, function(lambda(u); typerr("//",'operator))); symbolic procedure emtch u; if atom u then u else (lambda x; if x then x else u) opmtch u; symbolic procedure opmtch u; begin scalar q,x,y,z; if null(x := get(car u,'opmtch)) then return nil else if null subfg!* then return nil % null(!*sub2 := t). else if q := assoc(u,cdr alglist!*) then return cdr q; z := for each j in cdr u collect emtch j; a: if null x then go to c; y := mcharg(z,caar x,car u); b: if null y then <<x := cdr x; go to a>> else if lispeval subla(car y,cdadar x) then <<q := subla(car y,caddar x); go to c>>; y := cdr y; go to b; c: rplacd(alglist!*,(u . q) . cdr alglist!*); return q end; symbolic procedure mcharg(u,v,w); <<if atsoc('minus,v) then mcharg1(reform!-minus(u,v),v,w) else if v and eqcar(car v,'slash) then for each f in reform!-minus2(u,v) join mcharg1(car f,cdr f,w) else mcharg1(u,v,w)>>; symbolic procedure mcharg1(u,v,w); % Procedure to determine if an argument list matches given template. % U is argument list of operator W, V is argument list template being % matched against. If there is no match, value is NIL, % otherwise a list of lists of free variable pairings. if null u and null v then list nil else begin integer m,n; m := length u; n := length v; if flagp(w,'nary) and m>2 then if m<=matchlength!* and flagp(w,'symmetric) then return mchcomb(u,v,w) else if n=2 then <<u := cdr mkbin(w,u); m := 2>> else return nil; % We cannot handle this case. return if m neq n then nil else if flagp(w,'symmetric) then mchsarg(u,v,w) else if mtp v then list pair(v,u) else mcharg2(u,v,list nil,w) end; symbolic procedure reform!-minus(u,v); % Convert forms (quotient (minus a) b) to (minus (quotient a b)) % if the corresponding pattern in v has a top level minus. if null v or null u then u else ((if eqcar(car v,'minus) and eqcar(c,'quotient) and eqcar(cadr c,'minus) then {'minus,{'quotient,cadr cadr c,caddr c}} else c) . reform!-minus(cdr u,cdr v)) where c=car u; symbolic procedure reform!-minus2(u,v); % Prepare an extended quotient match; v is a pattern with leading "//". % Create for a form (quotient a b) a second form % (quotient (minus a) (minus b)) if b contains a minus sign. if null u or not eqcar(car u,'quotient) then nil else <<v := ('quotient . cdar v) . cdr v; if not smemq('minus,caddar u) then {u.v} else {u . v, ({'quotient,reval {'minus,cadar u},reval {'minus,caddar u}} . cdr u) . v}>>; symbolic procedure mchcomb(u,v,op); begin integer n; n := length u - length v +1; if n<1 then return nil else if n=1 then return mchsarg(u,v,op) else if not smemqlp(frlis!*,v) then return nil; return for each x in comb(u,n) join if null ncmp!* then mchsarg((op . x) . setdiff(u,x),v,op) % (reversip!* (for each j in permutations v collect pair(j,w)) % where w=(op . x) . setdiff(u,x)) % else if length v>2 % then rederr "noncom with 3 free args not implemented" else (if null y then nil % else if cdr y then mchsarg(aconc(car y,op . x),v,op) % else mchsarg((op . x) . car y,v,op)) else mchsarg((op . x) . car y, if cdr y then reverse v else v,op)) where y = mchcomb2(x,u,nil,nil,nil) end; symbolic procedure mchcomb2(u,v,w,bool1,bool2); % Determines if v can be removed from u according to noncom rules, % and whether remaining terms must be on the left (t) or right (nil). if null u then nconc(reversip w,v) . bool2 % (bool2 or null noncomlistp v and noncomlistp w and 'ok) else if car u = car v then if noncomp car u then mchcomb2(cdr u,cdr v,w,t,bool2) else mchcomb2(cdr u,cdr v,w,bool1,bool2) else if noncomp car u then if bool1 then nil else mchcomb2(u,cdr v,car v . w,t,if bool2 then bool2 else t) else mchcomb2(u,cdr v,car v . w,bool1,bool2); symbolic procedure comb(u,n); % Value is list of all combinations of N elements from the list U. begin scalar v; integer m; if n=0 then return list nil else if (m:=length u-n)<0 then return nil else for i := 1:m do <<v := nconc!*(v,mapcons(comb(cdr u,n-1),car u)); u := cdr u>>; return u . v end; symbolic procedure mcharg2(u,v,w,x); % Matches compatible list U of operator X against template V. begin scalar y; if null u then return w; y := mchk(car u,car v); u := cdr u; v := cdr v; return for each j in y join mcharg2(u,updtemplate(j,v,x),msappend(w,j),x) end; symbolic procedure msappend(u,v); % Mappend u and v with substitution. for each j in u collect append(v,sublis(v,j)); symbolic procedure updtemplate(u,v,w); begin scalar x,y; return for each j in v collect if (x := subla(u,j)) = j then j else if (y := reval!-without(x,w)) neq x then y else x end; symbolic procedure reval!-without(u,v); % Evaluate U without rules for operator V. This avoids infinite % recursion with statements like % for all a,b let kp(dx a,kp(dx a,dx b)) = 0; kp(dx 1,dx 2). begin scalar x; x := get(v,'opmtch); remprop(v,'opmtch); u := errorset!*(list('reval,mkquote u),t); put(v,'opmtch,x); if errorp u then error1() else return car u end; symbolic procedure mchk(u,v); % Extension to optional arguments for binary forms suggested by % Herbert Melenk. if u=v then list nil else if eqcar(u,'!*sq) then mchk(prepsqxx cadr u,v) else if eqcar(v,'!*sq) then mchk(u,prepsqxx cadr v) else if atom v then if v memq frlis!* then list list (v . u) else nil else if atom u % Special check for negative number match. then if numberp u and u<0 and eqcar(v,'minus) then mchk(list('minus,-u),v) else mchkopt(u,v) % "difference" may occur in a pattern like (a - b)^~n. else if car v = 'difference then mchk(u,{'plus,cadr v,{'minus,caddr v}}) else if get(car u,'dname) or get(car v,'dname) then nil else if car u eq car v then mcharg(cdr u,cdr v,car u) else if car v memq frlis!* % Free operator. then for each j in mcharg(subst(car u,car v,cdr u), subst(car u,car v,cdr v), car u) collect (car v . car u) . j else if car u eq 'minus then mchkminus(cadr u,v) else mchkopt(u,v); symbolic procedure mchkopt(u,v); % Check whether the pattern v is a binary form with an optional % argument. (if o then mchkopt1(u,v,o)) where o=get(car v,'optional); symbolic procedure mchkopt1(u,v,o); begin scalar v1,v2,w; if null (w:=cdr v) then return nil; v1:=car w; if null (w:=cdr w) then return nil; v2:=car w; if cdr w then return nil; return if flagp(v1,'optional) then for each r in mchk(u,v2) collect (v1.car o) . r else if flagp(v2,'optional) then for each r in mchk(u,v1) collect (v2.cadr o) . r else nil; end; put('plus,'optional,'(0 0)); put('times,'optional,'(1 1)); put('quotient,'optional, '((rule_error "fraction with optional numerator") 1)); put('expt,'optional, '((rule_error "exponential with optional base") 1)); symbolic procedure rule_error u; rederr{"error in rule:",u,"illegal"}; symbolic operator rule_error; % The following function pushes a minus sign into a term. % E.g. a + ~~y*~z matches % y z % (a + b) 1 b % (a - b) -1 b % (a -3b) -3 b % b -3 % (a - b*c) -b c % c -b % % For products, the minus is assigned to a numeric coefficient or % an artificial factor (-1) is created. For quotients the minus is % always put in the numerator. symbolic procedure mchkminus(u,v); if not(car v memq '(times quotient)) then nil else if atom u or not(car u eq car v) then if car v eq 'times then mchkopt1(u,v,'((minus 1)(minus 1))) else mchkopt({'minus,u},v) else if numberp cadr u or pairp cadr u and get(caadr u,'dname) or car v eq 'quotient then mcharg({'minus,cadr u}.cddr u,cdr v,car v) else mcharg('(minus 1).cdr u,cdr v,'times); symbolic procedure mkbin(u,v); if null cddr v then u . v else list(u,car v,mkbin(u,cdr v)); symbolic procedure mtp v; null v or (car v memq frlis!* and not(car v member cdr v) and mtp cdr v); symbolic procedure mchsarg(u,v,w); % From ACH: I don't understand why I put in the following reversip, % since it causes the least direct match to come back first. reversip!* if mtp v and (W NEQ 'TIMES OR noncomfree u) then for each j in noncomperm v collect pair(j,u) else for each j in noncomperm u join mcharg2(j,v,list nil,w); symbolic procedure noncomfree u; if idp u then not flagp(u,'noncom) else atom u or noncomfree car u and noncomfree cdr u; symbolic procedure noncomperm u; % Find possible permutations when non-commutativity is taken into % account. if null u then list u else for each j in u join (if x eq 'failed then nil else mapcons(noncomperm x,j)) where x=noncomdel(j,u); symbolic procedure noncomdel(u,v); if null NONCOMP!* u then delete(u,v) else noncomdel1(u,v); symbolic procedure noncomdel1(u,v); begin scalar z; a: if null v then return reversip!* z else if u eq car v then return nconc(reversip!* z,cdr v) else if NONCOMP!* car v then return 'failed; z := car v . z; v := cdr v; go to a end; symbolic procedure NONCOMP!* u; noncomp u or eqcar(u,'expt) and noncomp cadr u; flagop antisymmetric,symmetric; flag ('(plus times),'symmetric); endmodule; end;