Check-ins Using Download Hex

Artifact 4f880aa4211ec33b1e8e5052bed3dc097c1165c04ef9b9b7744dcec28eb80e32:

module invol;

% Cartan characters, reduced characters, involution test

% Author: David Hartley

fluid '(!*edsverbose !*edsdebug !*edssloppy !*genpos !*ranpos);


put('characters,'psopfn,'chareval);

symbolic procedure chareval u;
   if length u < 1 or length u > 2 then
      rerror(eds,000,"Wrong number of arguments to characters")
   else if edsp car(u := revlis u) then
      makelist characters(car u,if cdr u then !*a2sys cadr u)
   else
      makelist characterstab !*a2tab u;


symbolic procedure characterstab u;
   % u:tab -> characterstab:list of int
   countchars tp1 foreach r in cdr u collect
      foreach c in r collect c; % copy u because tp1 destroys it


symbolic procedure characters(s,x);
   % s:eds, x:sys -> characters:list of int
   % Have to protect call since kernel ordering changes
   edscall characters1(s,x);


symbolic procedure characters1(s,x);
   % s:eds, x:sys -> characters1:list of int
   begin scalar prl,x,ind,q,sp;
   if not normaledsp s then
      rerror(eds,000,"System not in normal form");
   if scalarpart eds_sys s then
      rerror(eds,000,"Characters with 0-forms not yet implemented");
   s := closure s;
   if quasilinearp s then
      s := car tmpind changeposition lineargenerators s
   else if null x then
      rerror(eds,000,
	     "Integral element required for nonlinear EDS characters")
   else
      s := car tmpind changeposition linearise(s,x);
   if not normaledsp s or scalarpart eds_sys s then
      errdhh "Result from tmpind has 0-forms or is not in normal form";
   prl := prlkrns s; ind := indkrns s;
   q := foreach f in nonpfaffpart eds_sys s join
           if f := linearpart(f,prl) then {f};
   x := reversip foreach w on reverse ind collect
           foreach f in q join
              foreach c in ordcomb(cdr w,degreepf f - 2) join
                 if c := xcoeff(f,car w . c) then {c};
   % Get characters from tableau
   x := reverse countchars x;
   % Get last character from s(p) = n - (p + s(0) + s(1) + ... + s(n-1))
   sp := length edscob s - (length ind + length pfaffpart eds_sys s +
      	    foreach si in cdr x sum si);
   % Compare the two, since we have them
   if sp neq car x then
      edsverbose("Cauchy characteristics detected from characters",
		 nil,nil);
   return reverse(sp . cdr x);
   end;


symbolic procedure changeposition s;
   % s:eds -> changeposition:eds
   % Transform system to general or random position, depending on
   % switches. Ordering of lists is arranged so that transforms are
   % lower triangular, since this should suffice.  Derivatives are not
   % updated, so s should be closed first if necessary.
   % NB Kernel order changed.
   if !*genpos then
      begin scalar x,new;
      new := for i:=1:length eds_ind s collect
	        mkform!*(intern gensym(),1);
      x := reversip foreach k in new collect !*k2pf k;
      x := foreach l on x collect
	      zippf(l,(1 ./ 1) . for i:=2:length l collect
		       	     	    !*k2q intern gensym());
      x := pair(indkrns s,reverse x);
      edsdebug("Transformation to general position",x,'xform);
      return xformeds0(s,x,new);
      end
   else if !*ranpos then
      begin scalar x,y,k,new;
      new := for i:=1:length eds_ind s collect
	        mkform!*(intern gensym(),1);
      x := reversip foreach k in new collect !*k2pf k;
      k := updkordl lpows x;
      for i:=1:length eds_ind s do
         begin scalar f;
       	    while null(f := xreduce(f,y)) do
	       f := zippf(x,ranlistsq(length eds_ind s,10,5));
	    y := f . y;
	 end;
      setkorder k;
      x := pair(indkrns s,foreach f in y collect xreorder f);
      edsdebug("Transformation to random position",x,'xform);
      return xformeds0(s,x,new);
      end
   else s;


symbolic procedure ranlistsq(n,p,m);
   % n,p,m:int -> ranlist:list of sq
   % Produces a list of n random numbers between -m and m, with
   % at most p non-zero elements.
   begin scalar u,v;
   p := min2(n,p);
   u := for i:=1:p collect simpatom(random(2*m+1) - m);
   while length v < p do
      (if not(x memq v) then v := x . v) where x = 1 + random n;
   u := pair(v,u);
   return for i:=1:n collect
      	   if v := atsoc(i,u) then cdr v else nil ./ 1;
   end;


symbolic procedure countchars x;
   % x:list of list of pf -> list of int
   % all pf are 1-forms
   begin scalar p,ri,si;
   foreach r in x do
      begin
      p := weak_xautoreduce append(r,p);
      ri := length p . ri;
      end;
   while cdr ri do
      <<si := (car ri - cadr ri) . si;
        ri := cdr ri>>;
   return car ri . si;
   end;


symbolic procedure involutionchk(s0,s1);
   % s0,s1:eds -> involutionchk:bool
   % s1 is prolongation of s0
   cartantest(characters(s0,eds_sys s1),
      	       length edscob s1 - length edscob s0);


symbolic procedure cartantest(c,d);
   % c:list of int, d:int
   % c is list of characters, d is dimension of solution variety
   begin integer m;
   c := reverse c;
   foreach k on c do
      m := length k*car k + m;
   if d > m then errdhh {"Inconsistency in Cartan's test:",reverse c,d}
   else return d = m;
   end;


put('involutive,'psopfn,'involutiveeval);

symbolic procedure involutiveeval s;
   % s:{eds} -> involutiveeval:0 or 1
   if edsp(s := reval car s) then
      if knowntrueeds(s,'involutive) or
      	 not knownfalseeds(s,'involutive) and
      	 edscall involutive s then 1 else 0
   else typerr(s,'eds);


symbolic procedure involutive s;
   % s:eds -> involutive:bool
   knowntrueeds(s,'involutive) or
      not knownfalseeds(s,'involutive) and
      begin scalar s0,s1,flg;
      s0 := closure s;
      if semilinearp s0 then
	 flg := cartantest(characters(s0,nil),
			   dimgrassmannvariety(s0,nil))
		 and null grassmannvarietytorsion s0
      else
      << s1 := prolong s0;
	 while s1 and (caar s1='prolonged) and involutionchk(s0,cdar s1)
	    do s1 := cdr s1;
      	 flg := null s1 >>;
      if flg
      then <<flagtrueeds(s,'involutive); return t>>;
      %%% We mustn't flag involutive FALSE since it might be an accident
      %%% of the integral flag and not a property of the system we want
      %%% to immortalise.
      % else <<flagfalseeds(s,'involutive); return nil>>;
   end;


put('involution,'rtypefn,'quoteeds);
put('involution,'edsfn,'involutioneds);

symbolic procedure involutioneds s;
   % s:eds -> involutioneds:xeds
   if not edsp s then typerr(s,'eds)
   else mkxeds makelist
      foreach x in edscall involution s collect
          if null car x then {'involution,cdr x}
          else cdr x;


symbolic procedure involution s;
   % s:eds -> involution:list of tag.eds
   % where tag = t if eds is involutive
   %             nil if prolongation failed
   % NEEDS WORK!!!
   begin scalar r,s0;
   s0 := closure s;
   if semilinearp s0 and
      cartantest(characters(s0,nil),dimgrassmannvariety(s0,nil)) and
      null grassmannvarietytorsion s0
   then return {t.s};
   foreach s1 in edscall prolong s0 do
      if car s1 = 'inconsistent then nil
      else if car s1 = 'failed then r := union({nil . cdr s1},r)
      else if car s1 = 'prolonged and involutionchk(s0,cdr s1) then
              r := union({t.s},r)
      else r := union(edscall involution cdr s1,r);
   return r;
   end;

endmodule;

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