reduce-historical/r38/packages/pm/pm.red

module pm;   % The PM Pattern Matcher.

% Author: Kevin McIsaac.

create!-package('(pm pmpatch pattdefn pmintrfc pattperm unify pmrules),
		'(contrib pm));

remflag('(i),'reserved);  % This package uses I as a global index!!

remprop('gamma,'simpfn);  % These routines clash with SPECFN.


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 = 1 then list(1, car arg, 1)
	      else if l = 2 then list(car arg, cadr arg, 1)
	      else if l = 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);


% Form function for !?.

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;

put('!?,'formfn,'formgen)$

endmodule;

end;



endmodule;

end;