Check-ins Using Download Hex

Artifact feb86803b0c1b6aa8c932a28408dae81087ae43a49d84c0fbd14406f0c83ec88:

module transfrm;

% Cobasis transformations

% Author: David Hartley

Comment. Data structure:

	xform	::= list of 1-form kernel . 1-form pf

endcomment;


fluid '(xvars!* kord!* subfg!*);
global '(!*sqvar!*);

fluid '(cfrmcob!* cfrmcrd!* cfrmdrv!* cfrmrsx!* !*edssloppy);


% Type coersions


symbolic procedure !*a2xform u;
   % u:list of equation -> !*a2xform:xform
   % Turn off subfg!* to stop let rules being applied.
   % should remove x=x entries
   for each j in getrlist u collect
      if eqexpr j then !*a2k lhs j . xpartitop rhs j where subfg!* = nil
      else rerror(eds,000,"Incorrectly formed transform");


symbolic procedure !*xform2map x;
   % x:xform -> !*xform2map:map
   foreach p in x collect
      car p . mk!*sq !*pf2sq cdr p;


symbolic procedure !*map2xform u;
   % u:map -> !*map2xform:xform
   % Turn off subfg!* to stop let rules being applied.
   (for each x in u collect
      car u . xpartitop cadr u) where subfg!* = nil;


symbolic procedure !*xform2drv x;
   % x:xform -> !*xform2drv:drv
   % Turn off subfg!* to stop let rules being applied.
   (foreach p in x collect
      {'replaceby,car p,!*pf2a cdr p}) where subfg!* = nil;


symbolic procedure !*xform2sys x;
   % x:xform -> !*xform2sys:sys
   foreach p in x collect addpf(!*k2pf car p,negpf cdr p);


% Transform


put('transform,'rtypefn,'getrtypecar);
put('transform,'cfrmfn,'transformcfrm);
put('transform,'edsfn,'transformeds);


symbolic procedure transformcfrm(m,x);
   % m:cfrm, x:list of equation -> transformcfrm:cfrm
   % Transform m using map x.
   checkcfrm xformcfrm(m,!*a2xform x);


symbolic procedure transformeds(s,x);
   % s:eds, x:list of equation -> transform:eds
   % pulls back s using map x
   xformeds(s,!*a2xform x);


symbolic procedure xformcfrm(m,x);
   % m:cfrm, x:xform -> xformcfrm:cfrm
   % Apply transform x to m, where x may be either old=f(new,old) or
   % new=f(old).
   xformcfrm1(m,car u,cadr u,caddr u)
      where u = getxform(x,cfrm_cob m);


symbolic procedure xformcfrm1(m,x,y,new);
   % m:cfrm, x,y:xform, new:cob -> xformcfrm1:cfrm
   % Apply transform x to m, where x is old=f(new,old), y is x inverse,
   % and new gives the new cobasis elements.
   begin scalar p,z;
   m := copycfrm m;
   z := pair(foreach p in x collect car p,new);
   cfrm_cob m :=	       % replace old by new in-place
      foreach k in cfrm_cob m collect % sublis here destroys kernels
      	       	   if p := atsoc(k,z) then cdr p else k;
   cfrm_crd m :=        % retain all old coordinates (may appear in eds)
       reverse union(foreach k in new join if exact k then {cadr k},
	     	     reverse cfrm_crd m);
   cfrm_drv m := 	% add new differentials and structure equations
      append(xformdrv(cfrm_drv m,x),
      append(!*xform2drv foreach p in x join if exact car p then {p},
	     structeqns(y,x)));
   if !*edssloppy then m := updatersx m; % invxform may have added new
					 % rsx
   m := purgecfrm m;
   return m;
   end;


symbolic procedure xformcfrm0(m,x,new);
   % m:cfrm, x:xform, new:cob -> xformcfrm0:cfrm
   % Cut down version of xformcfrm1 which doesn't update structure
   % equations. Useful when following operations are purely algebraic.
   begin scalar p,z;
   m := copycfrm m;
   z := pair(foreach p in x collect car p,new);
   cfrm_cob m :=	       % replace old by new in-place
      foreach k in cfrm_cob m collect % sublis here destroys kernels
      	       	   if p := atsoc(k,z) then cdr p else k;
   cfrm_crd m :=        % retain all old coordinates (may appear in eds)
       reverse union(foreach k in new join if exact k then {cadr k},
	     	     reverse cfrm_crd m);
   if !*edssloppy then m := updatersx m; % invxform may have added new
					 % rsx
   m := purgecfrm m;
   return m;
   end;


symbolic procedure xformdrv(d,x);
   % d:drv, x:xform -> xformdrv:drv
   % Apply xform to drv. Must suppress active rules, for example if d a
   % => d b is active and x = {d b => d a}, then after applying x, it
   % will be undone immediately.
   pullbackdrv(d,!*xform2map x) where subfg!* = nil;


symbolic procedure updatersx m;
   % m:cfrm -> updatersx:cfrm
   % Reinstall restrictions in s from global variable, typically
   % after solvepfsys when !*edssloppy is t.
   begin
   m := copycfrm m;
   cfrm_rsx m := foreach f in purge cfrmrsx!* collect !*pf2a f;
   return m;
   end;


symbolic procedure xformeds(s,x);
   % s:eds, x:xform -> xformeds:eds
   % Apply transform x to m, where x may be either old=f(new,old) or
   % new=f(old).
   % possibly changes kernel order
   xformeds1(s,car u,cadr u,caddr u)
      where u = getxform(x,edscob s);



symbolic procedure xformeds1(s,x,y,new);
   % s:eds, x,y:xform, new:cob -> xformeds1:eds
   % Apply transform x to m, where x is old=f(new,old), y is x inverse,
   % and new gives the new cobasis elements.  Changes background
   % coframing.
   begin scalar k;
   s := copyeds s;
   % Transform coframing
   eds_cfrm s := xformcfrm1(eds_cfrm s,x,y,new);
   % Make sure old get eliminated (and add new to kord!* for safety)
   k := updkordl append(foreach p in x collect car p,new);
   x := !*xform2sys x;
   % Transform rest of eds
   eds_sys s := foreach f in eds_sys s collect xreduce(xreorder f,x);
   eds_ind s := foreach f in eds_ind s collect xreduce(xreorder f,x);
   remkrns s;
   s := purgeeds!* s;
   rempropeds(s,'jet0);
   foreach f in {'solved,'reduced} do rempropeds(s,f);
   setkorder k;
   s := normaleds s; % Refine this a bit?
   setcfrm eds_cfrm!* s;
   return s;
   end;


symbolic procedure xformeds0(s,x,new);
   % s:eds, x:xform, new:cob -> xformeds0:eds
   % Cut down version of xformeds1 which doesn't care about structure
   % equations (some are lost). Useful when following operations are
   % purely algebraic. Changes background coframing.
   begin scalar k;
   s := copyeds s;
   % Transform coframing (ignore structure equations)
   eds_cfrm s := xformcfrm0(eds_cfrm s,x,new);
   % Make sure old get eliminated (and add new to kord!* for safety)
   k := updkordl append(foreach p in x collect car p,new);
   x := !*xform2sys x;
   % Transform rest of eds
   eds_sys s := foreach f in eds_sys s collect xreduce(xreorder f,x);
   eds_ind s := foreach f in eds_ind s collect xreduce(xreorder f,x);
   remkrns s;
   s := purgeeds!* s;
   rempropeds(s,'jet0);
   foreach f in {'solved,'reduced} do rempropeds(s,f);
   setkorder k;
   s := normaleds s; % Refine this a bit?
   setcfrm eds_cfrm!* s;
   return s;
   end;


symbolic procedure getxform(x,cob);
   % x:xform, cob:cob -> getxform:{xform,xform,cob}
   % Analyse transform x, which may be either old=f(new,old) or
   % new=f(old). The sense is established by cob, which contains the old
   % cobasis. Return value is {x,y,new} where x is in the sense old =
   % f(new,old), and y is the inverse of x (ie new = f(old)).  The
   % inverse y is calculated only if x is old = f(new,old) and there
   % are anholonomic forms in new.
   begin scalar old,new,y;
   foreach p in x do
   << new := union(xpows cdr p,new);
      old := car p . old >>;
   if not xnp(old,cob) then  % x is new=f(old), must invert
   << y := x; x := invxform x;
      new := old; old := foreach p in x collect car p >>;
   new := sort(setdiff(new,cob),'termordp);
   edsdebug("New cobasis elements...",new,'cob);
   edsdebug("... replacing old cobasis elements",old,'cob);
   if length new neq length old or not subsetp(old,cob) then
      rerror(eds,000,"Bad cobasis transformation");
   if not allexact new and null y then
      y := invxform x; % for structure equations
   return {x,y,new};
   end;


% Structure equations


symbolic procedure xformdrveval u;
   % u:{rlist,rlist} or {rlist} -> xformdrveval:rlist
   begin scalar x,y,k;
   y := !*a2xform car u;
   x := if cdr u then !*a2xform cadr u else invxform y;
   k := updkordl foreach p in x collect car p;
   y := structeqns(y,x);
   setkorder k;
   return makelist y;
   end;

symbolic procedure xformdrveval u;
   % u:{rlist,rlist} or {rlist} -> xformdrveval:rlist
   begin scalar x,y,xvars!*;
   y := !*a2xform car u;
   x := if cdr u then !*a2xform cadr u else invxform y;
   y := structeqns(y,x);
   return makelist y;
   end;


symbolic procedure structeqns(y,x);
   % y,x:xform -> structeqns:list of rule
   % y is the inverse of x, and d lhs x are known.
   % Returns rules for d lhs y.
   begin scalar ok;
   ok := updkordl foreach p in x collect car p;
   x := !*xform2sys x;
   y := foreach p in y join
      	   if not exact car p then
	      {{'replaceby,
	        {'d,car p},
	    	!*pf2a xreduce(exdfpf cdr p,x)}};
   setkorder ok;
   return y;
   end;

symbolic procedure structeqns(y,x);
   % y,x:xform -> structeqns:list of rule
   % y is the inverse of x, and d lhs x are known.
   % Returns rules for d lhs y.
   begin scalar ok;
   ok := updkordl sort(foreach p in x collect car p,function ordop);
   x := !*xform2sys x;
   y := foreach p in y join
      	   if not exact car p then
	      {{'replaceby,
	        {'d,car p},
	    	!*pf2a xreduce(exdfpf cdr p,x)}};
   setkorder ok;
   return y;
   end;

% Inverting tranformations


put('invert,'rtypefn,'quotelist);
put('invert,'listfn,'inverteval);

symbolic procedure inverteval(u,v);
   % u:{prefix list of eqn} -> inverteval:{prefix list of eqn}
   % u is unevaluated.
   makelist foreach p in invxform !*a2xform(u := reval car u) collect
      {'equal,car p,!*pf2a1(cdr p,v)};


symbolic procedure invxform x;
   % x:xform -> invxform:xform
   % Returns inverse transformation. Selects kernels to eliminate based
   % on prevailing order
   begin scalar old,y,k, subfg!*;
   subfg!* := nil;
   foreach p in x do old := union(xpows cdr p,old);
   old := sort(old,'termordp);
   % ensure old eliminated, and add new to kord!* for safety
   k := updkordl append(old,foreach p in x collect car p);
   edsdebug("Inverting transform",nil,nil);
   y := solvepfsys1(!*xform2sys x,old);	% invert transformation
   if cadr y then
      rerror(eds,000,"Cobasis transform could not be inverted");
   setkorder k;
   return foreach f in car y collect
      lpow f . negpf xreorder red f;
   end;
   

symbolic procedure tmpind s;
   % s:eds -> tmpind:{eds,xform}
   % Returns s with eds_ind s all kernels, transforming to a new
   % cobasis if necessary.  Second return value is nil if no change
   % made, or the list of transformation relations.  Structure
   % equations are not transformed, so s should be closed first if
   % necessary.  NB.  Background coframing changed.
   begin scalar new,x;
   if singleterms eds_ind s then return {s,nil};
   new := foreach f in eds_ind s collect mkform!*(intern gensym(),1);
   x := invxform pair(new,eds_ind s);
   updkordl foreach p in x collect car p;
   return {xformeds0(s,x,new),x};
   end;

endmodule;

end;
REDUCE Historical
[ REDUCE Sourceforge Project | Historical SVN Repository | GitHub Mirror | SourceHut Mirror | NotABug Mirror | Chisel Mirror | Chisel RSS ]