reduce-historical/r38/packages/scope/codstr.red

module gstructr;  % Generalized structure routines.

% ------------------------------------------------------------------- ;
% Copyright : J.A. van Hulzen, Twente University, Dept. of Computer   ;
%             Science, P.O.Box 217, 7500 AE Enschede, the Netherlands.;
% Author  :   M.C. van Heerwaarden, J.A. van Hulzen                   ;
% ------------------------------------------------------------------- ;

symbolic$

% ------------------------------------------------------------------- ;
% This module contains an extended version of the structr facility of ;
% REDUCE.                                                             ;
%                                                                     ;
% Author of structr-routines: Anthony C. Hearn.                       ;
%                                                                     ;
% Copyright (c) 1987 The RAND Corporation. All rights reserved.       ;
%                                                                     ;
% ------------------------------------------------------------------- ;

% ------------------------------------------------------------------- ;
% This is a generalization of the STRUCTR-command. Instead of one     ;
% expression, GSTRUCTR takes as input a list of assignment statements.;
% SYNTAX:                                                             ;
%        <gstructr-command> ::= GSTRUCTR <ass-list> NAME <id>         ;
%        <ass-list>         ::= {<assignments> | <matrix>}            ;
%        <id>               ::= <name for CSE>                        ;
% As a result, all assignments are printed with substitutions for the ;
% CSE's. Then WHERE is printed, followed by the list of CSE's. These  ;
% CSE's are printed in reversed order. Matrices are treated as if     ;
% assignments were made for all matrix elements.                      ;
% When the switch FORT is ON, the statements will be in  FORTRAN execu;
% table order. Be sure PERIOD is OFF when using a matrix,since FORTRAN;
% expects integer subscripts, and REDUCE generates a floating point   ;
% representation for these subscripts when PERIOD is ON.              ;
% The switch ALGPRI can be turned OFF when the list of assignments is ;
% needed in prefix-form.                                              ;
% ------------------------------------------------------------------- ;

fluid '(countr svar !*varlis);

global '(!*algpri );
%global '(!*fort );
%global '(!*nat );
%global '(!*savestructr);

global'(varnam!*);

switch savestructr, algpri;

% loadtime(on algpri);

% ***** two essential uses of RPLACD occur in this module.

put('gstructr, 'stat, 'gstructrstat);

symbolic procedure gstructrstat;
begin
    scalar x,y;
    flag('(name), 'delim);
    if eqcar(x := xread t, 'progn)
    then x := cdr x
    else x := list x;
    if cursym!* = 'name
    then y := xread t;
    remflag('(name), 'delim);
    return list('gstructr, x, y)
end;

put('gstructr, 'formfn, 'formgstructr);

symbolic procedure formgstructr(u, vars, mode);
list('gstructr, mkquote cadr u, mkquote caddr u);

symbolic procedure gstructr(assset, name);
begin
  !*varlis := nil;
  countr := 0;
  for each ass in assset
  do if not pairp ass
     then if get(ass, 'rtype) = 'matrix
	    then prepstructr(cadr get(ass,'avalue),name,ass)
	   else rederr {ass, "is not a matrix"}
     else prepstructr(caddr ass, name, cadr ass);
  if !*algpri
  then print!*varlis()
  else return remredundancy(for each x in reversip!* !*varlis
              collect list('setq, cadr x, cddr x))
end;

symbolic procedure prepstructr(u, name, fvar);
   begin scalar i, j;
      %!*VARLIS is a list of elements of form:
      %(<unreplaced expression> . <newvar> . <replaced exp>);
      if name
      then svar := name
      else svar := varnam!*;
      u := aeval u;
      if flagpcar(u, 'struct)
      then << i := 0;
              u:= car u .
                   (for each row in cdr u collect 
                    << i := i + 1;
                       j := 0;
                       for each column in row collect 
                       << j := j + 1;
                          !*varlis := (nil .
                                       list(fvar,i,j) .
                                       prepsq prepstruct!*sq column) .
                                       !*varlis
                    >> >>
                   )
           >>
      else if getrtype u
           then typerr(u,"STRUCTR argument")
           else !*varlis:=(nil.fvar.prepsq prepstruct!*sq u).!*varlis
   end;

symbolic procedure print!*varlis;
begin
  if !*fort 
  then !*varlis := reversip!* !*varlis;
  if not !*fort 
  then << for each x in reverse !*varlis 
          do if null car x
	     then << assgnpri(cddr x,list cadr x,t);
                     if not flagpcar(cddr x,'struct) then terpri();
                     if null !*nat then terpri()
                  >>;
          if countr=0 then return nil;
          prin2t "   where"
       >>;
  for each x in !*varlis 
  do if !*fort or car x
     then <<terpri!* t;
            if null !*fort then prin2!* "      ";
	    assgnpri(cddr x,list cadr x,t)
          >>;
  if !*savestructr
    then <<if arrayp svar
           then <<put(svar,'array,
                      %  mkarray(list(countr+1),'algebraic));
                        mkarray1(list(countr+1),'algebraic));
                  put(svar,'dimension,list(countr+1))>>;
           for each x in !*varlis do
              if car x then setk2(cadr x,mk!*sq !*k2q car x)>>
end;

symbolic procedure prepstruct!*sq u;
if eqcar(u,'!*sq)
   then prepstructf numr cadr u ./ prepstructf denr cadr u
   else u;

symbolic procedure prepstructf u;
if null u
then nil
else if domainp u
     then u
     else begin
            scalar x,y;
            x := mvar u;
            if sfp x
            then if y := assoc(x,!*varlis)
                 then x:=cadr y
                 else x:=prepstructk(prepsq!*(prepstructf x ./ 1),
                                     prepstructvar(),x)
            else if not atom x and not atomlis cdr x
                 then if y := assoc(x,!*varlis)
                      then x := cadr y
                      else x := prepstructk(x,prepstructvar(),x);
            return x .** ldeg u .* prepstructf lc u .+ prepstructf red u
          end;

symbolic procedure prepstructk(u,id,v);
begin
  scalar x;
  if x := prepsubchk1(u,!*varlis,id)
     then rplacd(x,(v . id . u) . cdr x)
     else if x := prepsubchk2(u,!*varlis)
             then !*varlis := (v . id . x) . !*varlis
             else !*varlis := (v . id . u) . !*varlis;
  return id
end;

symbolic procedure prepsubchk1(u,v,id);
   begin scalar w;
      while v do
       <<smember(u,cddar v)
            and <<w := v; rplacd(cdar v,subst(id,u,cddar v))>>;
         v := cdr v>>;
      return w
   end;

symbolic procedure prepsubchk2(u,v);
   begin scalar bool;
      for each x in v do
       smember(cddr x,u)
          and <<bool := t; u := subst(cadr x,cddr x,u)>>;
      if bool then return u else return nil
   end;

symbolic procedure prepstructvar;
   begin
      countr := countr + 1;
      return if arrayp svar then list(svar,countr)
       else compress append(explode svar,explode countr)
   end;

symbolic procedure remredundancy setqlist;
% -------------------------------------------------------------------- ;
% This function is used for backsubstitution of values of identifiers  ;
% in rhs's if the corresponding identifier occurs only once in the set ;
% of rhs's. SetqList is thus made shorter if possible.                 ;
% An element of Setqlist has the form (SETQ assname value), where      ;
% assname can be redundant if                                          ;
% Atom(assname) and Letterpart(assname) = svar                         ;
% -------------------------------------------------------------------- ;
begin scalar lsl,lhs,rhs,relevant,j,var,freq,k,firstocc,templist;
 lsl:=length(setqlist);
 lhs:=mkvect(lsl); rhs:=mkvect(lsl); relevant:=mkvect(lsl);
 j:=0; var:=explode(svar);
 foreach item in setqlist do
  <<putv(lhs,j:=j+1,cadr item); putv(rhs,j,caddr item);
    if atom(cadr item ) and letterparts(cadr item) = var
     then putv(relevant,j,t)
  >>;
 for j:=1:lsl do
  if getv(relevant,j)
   then
    << var:=getv(lhs,j); freq:=0; k:=j; firstocc:=0;
       while freq=0 and k<lsl do
       << if (freq:=numberofoccs(var,getv(rhs,k:=k+1)))=1 and firstocc=0
           then <<firstocc:=k; freq:=0>>;
          if firstocc>0 and freq>0 then firstocc:=0
       >>;
       if firstocc=0
        then templist:=list('setq,getv(lhs,j),getv(rhs,j)) . templist
        else  putv(rhs,firstocc,
                            subst(getv(rhs,j),var,getv(rhs,firstocc)))
    >>
    else templist:=list('setq,getv(lhs,j),getv(rhs,j)) . templist;
 return reverse(templist);
end;

symbolic procedure letterparts(name);
   % ----------------------------------------------------------------- ;
   % Eff: The exploded form of the Letterpart of Name returned, i.e.   ;
   % (!a !a) if Name=aa55.                                             ;
   % ----------------------------------------------------------------- ;
   begin scalar letters;
       letters:=reversip explode name;
       while digit car letters do letters:=cdr letters;
       return reversip letters
   end;

symbolic procedure numberofoccs(var,expression);
% -------------------------------------------------------------------- ;
% The number of occurrences of Var in Expression is computed and       ;
% returned.                                                            ;
% -------------------------------------------------------------------- ;
if atom(expression)
 then
  if var=expression then 1 else 0
 else
 (if cdr expression
   then numberofoccs(var,cdr expression)
   else 0)
 +
 (if var=car expression
   then 1
   else
    if not atom car expression
     then numberofoccs(var,car expression)
     else 0);

 

%-----------------------------------------------------------------------
% Algebraic mode psop-function definition.
%-----------------------------------------------------------------------

symbolic procedure algstructreval u;
% -------------------------------------------------------------------- ;
% Variant of gstructr-command. Accepts list of equations and optionally
% an initial part of a subpart recognizer name.
% -------------------------------------------------------------------- ;
begin scalar algpri,name,period,res; integer nargs;
 nargs:=length u;
 name:= (if nargs=1 and getd('newsym) then fnewsym()
         else if nargs=2 then cadr u
         else '!*!*error!*!*);
 if eq(name,'!*!*error!*!*)
  then rederr("WRONG NUMBER OF ARGUMENTS ALGSTRUCTR")
  else << algpri:=!*algpri; period:=!*period; !*algpri:=!*period:=nil;
          res:=apply('gstructr,list(cdar u,name));
          !*period:=period;
          if (!*algpri:=algpri)
           then return 
	     algresults1(foreach el in res
			    collect cons(cadr el,caddr el))
           else return res
       >>
end;

put('algstructr,'psopfn,'algstructreval)$

endmodule;
end;