123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086 |
- module pm; % The PM Pattern Matcher.
- % Author: Kevin McIsaac.
- % create!-package('(pm pmpatches 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) eq 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 pmpatches; % 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);
- global '(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.
- %
- global '(subfg!*);
- fluid '(!*trpm rpt 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()}
- 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;
|