reduce-historical/r38/packages/rataprx/decrep.red

module decrep;  % Periodic Decimal Representation.

% Author: Lisa Temme

% Date:   August 1995.

algebraic;

% Procedure to check if an argument is a list.

procedure paarp(x); lisp eqcar(x,'list);

procedure tidy(u);
   % tidy {wholepart, {non_recursive_decimal_part},
   %    {recursive_decimal_part}}
   % to {{num_non_per_part, den_non_per_part}, {recursive_decimal_part}}
  begin
   scalar a, b, b1, c, num_non_per_part, den_non_per_part;
    
    a := part(u,1);
    b := part(u,2);
    c := part(u,3);  %recursive part
    
    if length(b)=0 then << b1 := 0 >>
    else b1 := digits2number(b);

%%match -ve value
    if a<0 
    then num_non_per_part :=a*(10^length(b)) - b1
    else num_non_per_part :=a*(10^length(b)) + b1;

    den_non_per_part := 10^length(b);
    
    return list(list(num_non_per_part, den_non_per_part), c)
  end;

%******************

procedure digits2number(x);
%%convert an list of digits to a number
  begin 
     scalar j, number, !*rounded, dmode!*;

     if x={} OR NOT(paarp x)  %check for empty list OR non-list
     then rederr 
     "argument of digits2number should be list of non-negative digits";

     number := part(x,1);

     for j:=1:(length(x)-1) do 
     << 
        if (numberp(part(x,j)) and part(x,j)>0 and part(x,j)<10) 
           OR part(x,j)=0
        then number := number*10 + part(x,j+1)
        else rederr 
       "argument of digits2number should be list of non-negative digits"
     >>;
     return number
  end;


procedure number2digits(n);
%%convert a number to a list of digits
  begin 
    scalar number, list_of_ints, tmp, next_number, flg, 
           !*rounded, dmode!*;

    flg := 0;

%%check for integer argument
    if NOT(fixp n) then 
         rederr "argument must be an integer";

%%match -ve Input => -ve Output
    if n<0 then << flg:=1; n:=-n >>;

%%match zero Input => zero Output
    if n=0 then return {0}
	   else list_of_ints := {};

    tmp := n;
    while tmp>0 do
       <<  next_number := remainder(tmp,10);
	   list_of_ints := next_number.list_of_ints;
 	   tmp := (tmp - next_number)/10
       >>;

%%match -ve Input => -ve Output
    if flg=1 
    then return append(list(- first list_of_ints), rest list_of_ints)
    else return list_of_ints;

%    if flg=1 then return list("-",list_of_ints)
%             else return list_of_ints;
  end;

%***********************
operator periodic;

procedure rational2periodic(xx);
%%gives periodic decimal representation of integer division
 %%check to see if rounded switch is off
  if lisp !*rounded 
  then rederr "operator to be used in off rounded mode"
  else
  <<begin
      scalar n, m, z, n_repr, answer, numerator, wholepart,
             nexttryresult, result, numb, remd, negflg, 
             !*rounded, dmode!*;

%%check for rational number argument
      if NOT(numberp xx) 
      then rederr "argument must be a rational number";

      n := num xx;
      m := den xx;

%%match -ve Input => -ve Output
      negflg := 0;
      if xx<0
      then 
        << n_repr := append(list(- first number2digits(n)),
                                    rest number2digits(n));
           negflg := negflg + 1
        >>
      else n_repr := number2digits(n);

%%calculate before decimal point
    answer := {};
    numerator := first(n_repr);
    while length(n_repr) >1 do
    <<
      n_repr := rest n_repr;
      answer := ((numerator - remainder(numerator, m))/m).answer;
      numerator := remainder(numerator, m) * 10 + first n_repr
    >>;
    answer := ((numerator - remainder(numerator, m))/m).answer ;
    wholepart := digits2number(reverse(answer));
               
%%calculate first decimal digit
    numerator := remainder(numerator,m)*10;
    numb := (numerator - remainder(numerator, m))/m;
    remd := remainder(numerator, m);
    z := {};
    numerator := remd*10;

%%calculate decimal part & check for recursion
    while length(nexttry(numb, remd, z)) neq 2
    do
    << z := {numb, remd}.z;
       numb := (numerator - remainder(numerator, m))/m;
       remd := remainder(numerator,m);
       numerator   := remd*10;
    >>;

%%nexttry returns either {} or {decimal_ans, recurrence}
    nexttryresult := nexttry(numb, remd, z);

%%put result in form 
%% { {numerator non-periodic part, denominator non-periodic part}, 
%%                                                       {period} }

    %%match -ve Input => -ve Output
    if negflg neq 0
    then 
      << if wholepart=0
         then 
           << partresult := tidy(list(wholepart, 
                                       first(nexttryresult), 
                                       second(nexttryresult)));

              if length(first(nexttryresult))=0
              then
                << result := list(first  first partresult, 
                                  - second first partresult).
                             rest partresult;
                >>
              else
                << result := list(-first  first partresult, 
                                   second first partresult).
                             rest partresult
                >>;
           >>
         else 
           << partresult := tidy(list(wholepart, 
                                       first(nexttryresult), 
                                       second(nexttryresult)));

              result := list(-first  first partresult, 
                              second first partresult).
                        rest partresult
           >>;
      >>
    else
      << result := tidy(list(wholepart, 
                             first(nexttryresult), 
                             second(nexttryresult)))
      >>;

%return result;
    return periodic(first result, second result);
  end
  >>;
 
 
procedure nexttry(x,y,z);
%%compare {x,y} with z (the list of previous ordered pairs {x,y})
  begin
   scalar recurrence, decimal_ans, num_rem, ans, h, k, j, 
          !*rounded, dmode!*; %added dmode!* here

     recurrence :={};
     decimal_ans := {};
     num_rem := {x,y};   
     ans := {};
     h:=0;
     k := length(z);

%%look through z to see if {x,y} has already occured
     while (k>0 and h=0) do
     << 
        if num_rem = part(z,k) then 
        <<
           for j := 1:k do recurrence  := first(part(z,j)).recurrence;
           for j := k+1:length(z) 
                        do decimal_ans := first(part(z,j)).decimal_ans;
           h:=1;
        >>;
     k := k-1;
     if h=1 then ans := list(decimal_ans,recurrence)
     >>;
     
%%return list(decimal_ans,recurrence)
    return ans
  end;



operator periodic2rational;

%% Ruleset to allow two types of periodic input.
per2ratRULES := 
{
    periodic2rational(periodic(~x,~y)) => periodic2rational(x,y)
                                          when paarp x and length x=2
                                                       and paarp y,

    periodic2rational(~x,~y) => per2rat(x,y)
                                when paarp x and length x=2
                                             and paarp y

};
let per2ratRULES;



%% Procedure to convert a periodic representation to a rational one.
procedure per2rat(ab,c);
 %%check to see if rounded switch is off
  if lisp !*rounded 
  then rederr "operator to be used in off rounded mode"
  else
  <<begin
      scalar a, b, number_c, power, fract;

      a := first ab;
      b := second ab;

      if a<0 then << a:=-a; b:=-b>>;

      if NOT(fixp b) OR 
         ( (remainder(b,10) neq 0)  AND (b neq 1) AND (b neq -1) )
      then rederr "denominator must be 1, -1 or a multiple of 10";

      if length c = 0 then number_c = 0
      else number_c := digits2number c;
      
      power := length c;
    
      fract := a/b + 1/b*(number_c/10^power*(1/(1-1/10^power)));
    
      return fract
    
    end
  >>;

% printers

symbolic procedure print_periodic (u);

   if not(!*nat) or
	(length caddr u + 10) > (linelength nil) then 'failed else

   begin scalar oo,x,intpart,intstring,l1,l2,perio,minussign;

    intpart := cdr cadr u;
    if cadr intpart= (-1) then
	<< minussign := t; intpart := list (car intpart, 1)>>;
    if car intpart < 0 then
	<< minussign := t;
	   intpart := list (-(car intpart),cadr intpart)>>;
    intstring :=  explode car intpart;
    l1 := length intstring;
    l2 := length explode cadr intpart;
    
    perio   := cdr caddr u;
    ycoord!* := ycoord!* +1;
    oo := posn!*;
    ymax!* := max(ymax!*,ycoord!*);
    x:= max(l1,l2);
    if minussign then x  := x + 1;
    for i:=0:x do prin2!* " ";
    x := for each q in perio sum length explode q;
    if not(caddr u = '(list 0)) then
	    for i:=1:x do prin2!* "_";

    posn!* := oo;
    ycoord!* := ycoord!* -1;
    if minussign then prin2!* "-";

    if l1 < l2 then <<l2 := l2 -1; prin2!* "0.">> else
      while l1 > 0 do << 
	prin2!* car intstring;
	intstring := cdr intstring;
        l1 := l1 -1;
	if l1 < l2 then << l1 := 0; l2 := l2 -1;  prin2!* ".">>;
	>>;
    while l2 > 0 do <<
	if intstring then <<prin2!* car intstring;
			    intstring := cdr intstring;>>
		else prin2!* '!0;
	l2 := l2 -1 >>;

    if not(caddr u = '(list 0)) then for each q in perio do prin2!* q;
    return t;
end;

put('periodic,'prifn,'print_periodic);

endmodule;

end;