Artifact f62993671de7b1b59328df8186ed17f6d76879292beba3c924afdfcf5d14c07f:

• Executable file r37/packages/misc/reddom.red — part of check-in [f2fda60abd] at 2011-09-02 18:13:33 on branch master — Some historical releases purely for archival purposes

  git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/trunk/historical@1375 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 4978) [annotate] [blame] [check-ins using] [more...]

• Executable file r38/packages/misc/reddom.red — part of check-in [f2fda60abd] at 2011-09-02 18:13:33 on branch master — Some historical releases purely for archival purposes

  git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/trunk/historical@1375 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 4978) [annotate] [blame] [check-ins using]

module reddom;   % Reduction of domain elements.

% Author: Anthony C. Hearn.

% Copyright (c) 1989 The RAND Corporation.  All Rights Reserved.

fluid '(mv!-vars!*);

global '(!*xxx !*yyy);

% switch xxx,yyy;

!*xxx := !*yyy := t;


% Operations on domain elements.

symbolic smacro procedure domain!-!+(u,v); u+v;

symbolic smacro procedure domain!-!-(u,v); u-v;

symbolic smacro procedure domain!-!*(u,v); u*v;

symbolic smacro procedure domain!-divide(u,v); divide(u,v);


% Operations on domain element lists.

symbolic procedure mv!-domainlist!-!+(u,v);
   if null u then nil
    else domain!-!+(car u,car v) . mv!-domainlist!-!+(cdr u,cdr v);

symbolic procedure mv!-domainlist!-!-(u,v);
   if null u then nil
    else domain!-!-(car u,car v) . mv!-domainlist!-!-(cdr u,cdr v);

symbolic procedure mv!-domainlist!-!*(u,v);
   if null v then nil
    else domain!-!*(u,car v) . mv!-domainlist!-!*(u,cdr v);

% Procedures for actually reducing domain elements.

symbolic procedure reduce(u,v);
   % Reduce domain element list u with respect to an equal length domain
   % element list v.  We assume that v has been reduced to lowest terms.
   begin scalar weightlist,x;
      % Look for equal ratios of elements.
      x := u;
      IF !*YYY THEN
      x := reduce!-ratios(x,v);
      % Define weighting list.
      weightlist := set!-weights v;
      % Choose column elimination with lowest weight.
      IF !*XXX THEN
      x := reduce!-columns(x,v,weightlist);
      % Look for a reduction in weight of the expression.
      IF !*XXX THEN
      x := reduce!-weights(x,v,weightlist);
      return x
   end;

   symbolic procedure set!-weights v;
      % Define weights to be associated with the reduction test.
      % The current definition is pretty naive.
      begin integer n;
%         return reversip for each j in v collect (n := n+1)
	  return reversip (0 . for each j in cdr v collect 1)
      end;

   symbolic procedure reduce!-ratios(u,v);
      begin scalar x;
	 if null(x := red!-ratios1(u,v)) then return u;
	 x := mv!-domainlist!-!-(mv!-domainlist!-!*(car x,u),
				      mv!-domainlist!-!*(cdr x,v));
	 return if zeros u >= zeros x then u
		 else reduce!-ratios(x,v)
      end;

      symbolic procedure zeros u;
	 if null u then 0
	  else if car u = 0 then 1+zeros cdr u
	  else zeros cdr u;

      symbolic procedure red!-ratios1(u,v);
	 u and (red!-ratios2(cdr u,cdr v,car u,car v)
		   or red!-ratios1(cdr u,cdr v));

	 symbolic procedure red!-ratios2(u,v,u1,v1);
	    % The remainder check is needed for the example
	    % reduce('(3 0 -3 0 0 0 0),(2 -1 -2 -1 3 -1 1));
	    begin integer n;
	       return if null u then nil
		       else if (n := u1*car v) = v1*car u and n neq 0
			 and remainder(gcdn(v1,u1),v1)=0
			then red!-lowest!-terms(v1,u1)
		       else red!-ratios2(cdr u,cdr v,u1,v1)
	    end;

	    symbolic procedure red!-lowest!-terms(u,v);
	       begin scalar x;
		  if u<0 then <<u := -u; v := -v>>;
		  x := gcdn(u,v);
		  % We must have x = u from call in red-ratios2.  If
		  % not, something is awfully wrong.
		  if x neq u then errach list("red-lowest-terms",u,v);
		  return 1 . (v/x)
	       end;

symbolic procedure reduce!-columns(u,v,weightlist);
   begin scalar w,x,y,z,z1;
      x := u;
      y := v;
      w := (u . red!-weight(u,weightlist));
   a: if null x then return car w
       else if car x=0 or car y=0 then nil
       else if cdr(z := domain!-divide(car x,car y))=0
	then <<z := mv!-domainlist!-!-(u,mv!-domainlist!-!*(car z,v));
	       z1 := red!-weight(z,weightlist);
	       if red!-weight!-less!-p(z1,cdr w)
		  and not more!-apartp(z . z1,w)
		 then w := (z . z1)>>;
      x := cdr x;
      y := cdr y;
      go to a
   end;

   symbolic procedure more!-apartp(u,v);
      cadr u=2 and cadr u=cadr v and cadar u=0 and cadar v neq 0;

   symbolic procedure reduce!-weights(u,v,weightlist);
      begin scalar success,x,y,z;
	 x := red!-weight(u,weightlist);
      a: y := mv!-domainlist!-!+(u,v);
	 z := red!-weight(y,weightlist);
	 if red!-weight!-less!-p(z,x)
	   then <<success := t; u := y; x := z; go to a>>;
	 if success then return u;
      b: y := mv!-domainlist!-!-(u,v);
	 z := red!-weight(y,weightlist);
	 if red!-weight!-less!-p(z,x) then <<u := y; x := z; go to b>>;
	 return u
      end;

      symbolic procedure red!-weight(u,weightlist);
	 nonzero!-length u . red!-weight1(u,weightlist);

	 symbolic procedure red!-weight1(u,weightlist);
	    if null u then 0
	     else abs car u*car weightlist
		     + red!-weight1(cdr u,cdr weightlist);

	 symbolic procedure nonzero!-length u;
	    if null u then 0
	     else if car u=0 then nonzero!-length cdr u
	     else add1 nonzero!-length cdr u;

      symbolic procedure red!-weight!-less!-p(u,v);
         if car u=car v then cdr u<cdr v else car u<car v;

endmodule;

end;