
A N E X A  1

Sursele Pascal ale unitatii B2TOZ


{ ===================== B2TOZ  ========================== }
{ Numerele prelucrabile prin aceasta unitate sunt stringuri
      care contin cifre zecimale si litere ale alfabetului,
      folosite ca simboluri de cifre. Fiecare string are pe
    ultima pozitie simbolul bazei de numeratie in care este
                                   scris numarul respectiv.
     Orice neconcordanta in ceea ce priveste corectitudinea
          parametrilor este semnalata de catre functii prin
  intoarcerea, dupa caz, a stringului vid sau a valorii -1.}

{$I-,R-,D-,B-,S-,V-}

UNIT B2TOZ;

INTERFACE

  const    MAXBASE   = 35;      { Valoarea maxima a bazei }
           MAXDIGITS = 253;      { Numarul maxim de cifre }
  type tb255 = array[0..MAXDIGITS + 2] of byte;
   { In astfel de tablouri sunt trecute valorile cifrelor }

  procedure parsstring(var s: string;
                       var t: tb255 ;  var n, P: byte);
  function  makestring(t: tb255;  n, P: byte ): string;

  function plus(  Ra, Rb: string             ): string;
  function minus( Ra, Rb: string             ): string;
  function times( Ra, Rb: string             ): string;
  function divide(Ra, Rb: string             ): string;

  function  valinthorner( Ra: string         ): longint;
  function  valfrachorner(Ra: string         ): real;
  function  inttobase(    l: longint; P: byte): string;

  function  tobaseint( Ra: string;     P: byte): string;
  function  tobasefrac(Ra: string;  n, P: byte): string;

IMPLEMENTATION

{ ===================== PARSSTRING ====================== }
    { Primeste la intrare sirul s, despre care se presupune
      ca ar contine un numar natural intr-o anumita baza.
      Se elimina mai intai spatiile de la inceputul lui s.
      Apoi de la sfarsit spre inceput, se determina baza P
      si se determina multimea m a simbolurilor de cifre.
      In sfarsit, se determina rangul maxim n si valorile
      celor n+1 cifre, care se vor depune in tabloul t. }
procedure parsstring(var s: string;
                     var t: tb255;  var n, P: byte);
var  i: byte;   m: set of char;
begin
  s := '#' + s + '#';
  for i := 2 to length(s) - 1 do s[i] := upcase(s[i]);
  while s[2] = ' ' do delete(s, 2, 1);
  i := length(s) - 1;
  while not (s[i] in ['2'..'9','A..'Z','#']) do  i := i-1;
  delete(s, i + 1, length(s) - i);
  if s = '#' then  s := '0A else delete(s, 1, 1);
  n := length(s);
  if s[n] in ['2'..'9'] then begin
    m := ['0'..pred(s[n])];
    P := ord(s[n]) - ord('0')
  end else begin
    m := ['0'..'9','A..pred(s[n])];
    P := 10 + ord(s[n]) - ord('A)
  end;
  i := 1;
  while s[i] in m do i := i + 1;
  s := copy(s, 1, i - 1) + s[n];
  if length(s) = 1 then s := '0' + s;
  n := length(s) - 2;
  for i := 0 to n do
    if s[n + 1 - i] in ['0'..'9'] then
      t[i] := ord(s[n + 1 - i]) - ord('0')
    else
      t[i] := 10 + ord(s[n + 1 - i]) - ord('A)
end; { parsstring }

{ ===================== MAKESTRING ====================== }
        { In ipoteza ca in vectorul t se afla n+1 valori de
          cifre in baza P, intoarce reprezentarea numarului
          ca un string continand simbolurile cifrelor dupa
          care urmeaza simbolul cifrei baza. Nu sunt
          eliminate zerourile nesemnificative! }
function  makestring(t: tb255; n, P: byte): string;
var  s: string;  i: byte;
begin
  makestring := '';
  if (not (P in [2..MAXBASE])) or (n > MAXDIGITS) then EXIT;
  s[0] := chr(n + 2);  t[n + 1] := 255;
  if P < 10 then s[length(s)] := chr(P + ord('0'))
            else s[length(s)] := chr(P - 10 + ord('A));
  i := 0;
  while t[i] in [0..P - 1] do begin
    if t[i] < 10 then s[n + 1 - i] := chr(t[i] + ord('0'))
            else s[n + 1 - i] := chr(t[i] - 10 + ord('A));
    i := i + 1
  end;
  delete(s, 1, n - i + 1); if length(s)=1 then s := '0'+s;
  makestring := s
end; { makestring }

{ ===================== PLUS ============================ }
     { Efectueaza suma numerelor reprezentate prin sirurile
      Ra si Rb. Sunt eliminate zerourile nesemnificative. }
function plus(Ra, Rb: string): string;
var  a, b, c: tb255;   m, n, t, i, k, l, P: byte;  W: word;
begin
  plus := '';
  parsstring(Ra, a, m, P);
  parsstring(Rb, b, n, t);
  if P <> t then     EXIT;
  if n < m then begin  k := m;  l := n end
           else begin  k := n;  l := m end;
  t := 0;
  for i := 0 to l do begin
    W := a[i] + b[i] + t;
    t := W div P        ;  c[i] := W mod P
  end;
  for i := n + 1 to m do begin
    W := a[i] + t       ;
    t := W div P        ;  c[i] := W mod P
  end;
  for i := m + 1 to n do begin
    W := b[i] + t       ;
    t := W div P        ;  c[i] := W mod P
  end;
  if t = 1 then begin  k := k + 1;  c[k] := 1  end;
  while (k > 0) and (c[k] = 0) do   k := k - 1;
  plus := makestring(c, k, P)
end; { plus }

{ ===================== MINUS =========================== }
       { Efectueaza diferenta dintre numarul reprezentat Ra
        (descazut) si numarul Rb (scazator). Sunt eliminate
        zerourile nesemnificative. }
function minus(Ra, Rb: string): string;
var  a, b, c: tb255;   m, n, t, i, k, l, P: byte;  W: word;
begin
  minus := '';
  parsstring(Ra, a, m, P);
  parsstring(Rb, b, n, t);
  if P <> t then     EXIT;
  if n < m then begin  k := m; l := n  end
           else begin  k := n; l := m  end;
  t := 0;
  for i := 0 to l do begin
    W := P + a[i] - b[i] - t;
    t := 1 - W div P        ;  c[i] := W mod P
  end;
  for i := n + 1 to m do begin
    W := P + a[i] - t       ;
    t := 1 - W div P        ;  c[i] := W mod P
  end;
  for i := m + 1 to n do begin
    W := P - b[i] - t       ;
    t := 1 - W div P        ;  c[i] := W mod P
  end;
  while (k > 0) and (c[k] = 0) do  k := k - 1;
  if t = 1 then minus := ''
           else  minus := makestring(c, k, P)
end; { minus }


{ ===================== TIMES =========================== }
 { Efectueaza produsul numerelor reprezentate prin sirurile
      Ra si Rb. Sunt eliminate zerourile nesemnificative. }
function times(Ra, Rb: string): string;
var  a, b, c: tb255;  
     k, m, n, i, j, addt, mult, P: byte;   W: word;
begin
  times := '';
  parsstring(Ra, a, m, P);
  parsstring(Rb, b, n, addt);
  if P <> addt then     EXIT;
  k := m + n + 1;
  fillchar(c[0], k+1, 0);
  for i := 0 to n do if b[i] <> 0 then begin
    addt := 0;          mult := 0;
    for j := 0 to m do begin
      W  := a[j] * b[i] + mult;
      mult := W div P;  W  := W mod P;
      W  := c[i + j] + W + addt;
      addt := W div P;  c[i + j] := W mod P
    end;
    c[i + m + 1] := mult + addt
  end;
  while (k > 0) and (c[k] = 0) do k := k - 1;
  times := makestring(c, k, P)
end; { times }


{ ===================== DIVIDE ========================== }
  { Efectueaza catul dintre deimpartitul Ra si impartitorul
         Rb. Sirul rezultat contine mai intai catul si apoi
                restul impartirii. Sunt eliminate zerourile
                 nesemnificative din cele doua rezultate. }
function divide(Ra, Rb: string): string;
var  a, b, t, u, x, y, z: tb255;
     m, s, n, k, i, j, d, q, P: byte;
     W: word;   ok: boolean;    Rx, Ry, Rt, Ru: string;
begin
  divide := '';
  parsstring(Ra, a, s, P);
  parsstring(Rb, b, n, q);
  if (P <> q) or (b[n] = 0) then    EXIT;
  if b[n] > P div 2 then d := 1
                    else d := P div (b[n] + 1);
  t[0] := d;
  Rt := makestring(t, 0, P);
  Rx := times(Ra, Rt);
  parsstring(Rx, x, m, P);
  Ry := times(Rb, Rt);
  parsstring(Ry, y, n, P);
  x[m + 1] := 0;
  fillchar(z[0], m+1, 0);
  for i := m downto n do begin
    W := x[i + 1] * P + x[i];
    q := W div y[n]; if q > P-1 then q := P-1;
    move(x[i-n], u[0], n+2);
    Ru := makestring(u, n+1, P);
    repeat
      t[0] := q;
      Rt := makestring(t, 0, P);
      Rt := times(Rt, Ry);
      while length(Rt) < n+3 do Rt := '0' + Rt;
      ok := Rt <= Ru;
      if not ok then q := q - 1
    until ok;
    if q <> 0 then begin
      z[i-n] := q;
      Rt := minus(Ru, Rt);
      parsstring(Rt, t, k, P);
      fillchar(t[k+1], n+1-k, 0);
      move(t[0], x[i-n], n+2)
    end
  end;
  s := m;
  while (m > 0) and (z[m] = 0) do m := m - 1;
  k := 0;
  for i := s + 1 downto 0 do begin
    W := k * P + x[i];
    k := W mod d     ;
    x[i] := W div d
  end;
  k := s + 1;
  while (k > 0) and (x[k] = 0) do k := k - 1;
  divide := makestring(z, m, P) + makestring(x, k, P)
end; { divide }


{ ===================== VALINTHORNER ==================== }
{ Transforma intregul reprezentat in Ra intr-o anumita baza
                      intr-un intreg lung, forma interna. }
function valinthorner( Ra: string): longint;
var  i, n, P: byte;   x: tb255;  l: longint;
begin
  valinthorner := - 1;
  parsstring(Ra, x, n, P);
  l := 0;
  for i := n downto 0 do begin
    l := l * P + x[i];
    if l < 0 then      EXIT
  end;
  valinthorner := l
end; { valinthorner }

{ ===================== VALFRACHORNER =================== }
      { Presupune ca numarul reprezentat in Ra este o parte
   fractionara scrisa intr-o anumita baza. Transforma acest
       numar intr-un numar real, in reprezentare interna. }
function valfrachorner(Ra: string): real;
var  i, n, P: byte;  x: tb255;  l, q: real;
begin
  valfrachorner := - 1.0;
  parsstring(Ra, x, n, P);
  l := 0.0;   q := 1.0 / P;
  for i := 0 to n do l := l * q + x[i];
  valfrachorner := l * q
end; { valfrachorner }


{ ===================== INTTOBASE ======================= }
  { Transforma intregul lung l din reprezentarea interna in
                       reprezentarea ca string in baza P. }
function inttobase(l: longint; P: byte): string;
var  i, n: byte;  x: tb255;
begin
  inttobase := '';
  if (l < 0) or (not (P in [2..MAXBASE])) then    EXIT;
  n := 0;
  repeat
    x[n] := l mod P;
    l := l div P;
    n := n + 1;
  until l = 0;
  n := n - 1;
  inttobase := makestring(x, n, P)
end; { inttobase }


{ ===================== TOBASEINT ======================= }
{ Trece numarul intreg din Ra, scris intr-o baza oarecare
                              (notata Q), in baza data P.
              Sunt eliminate zerourile nesemnificative. }
function  tobaseint(Ra: string; P: byte): string;
var  d, i, c, r: string;   Cb: char;
     n, Q, k: byte;        x: tb255;  l: longint;
begin
  tobaseint := '';
  if not (P in [2..MAXBASE]) then    EXIT;
  parsstring(Ra, x, n, Q);
  Cb := Ra[length(Ra)];
  l := P;
  i := inttobase(l, Q);
  d := Ra;
  n := 0;
  repeat
    c := divide(d, i);
    k := pos(Cb, c);
    r := copy(c, k + 1, length(c) - k);
    d := copy(c, 1, k);
    x[n] := valinthorner(r);
    n := n + 1
  until d = '0'+Cb;
  x[n] := 0;
  while (n > 0) and (x[n] = 0) do n := n - 1;
  tobaseint := makestring(x, n, P)
end; { tobaseint }


{ ===================== TOBASEFRAC ====================== }
  { Presupune ca in Ra este reprezentata partea fractionara
   a unui numar real scris intr-o baza oarecare (notata Q).
    Intoarce stringul ce contine primele n cifre ale partii
                fractionare reprezentate in baza in baza P.
                Sunt eliminate zerourile nesemnificative. }
function tobasefrac(Ra: string; n, P: byte): string;
var  c, d, i: string;     Cb: char;
     np, nq, Q, k: byte;  x: tb255;  l: longint;
begin
  tobasefrac := '';
  if (np > MAXDIGITS) or (not (P in [2..MAXBASE])) then
    exit;
  parsstring(Ra, x, nq, Q);
  Cb := Ra[length(Ra)];
  l := P;
  i := inttobase(l, Q);
  d := Ra;
  np := 0;
  for k := 1 to n do begin
    c := times(d, i);
    if length(c) < nq + 2 then
      x[np] := 0
    else begin
      x[np] := valinthorner(copy(c, 1, length(c)-nq-2)+Cb);
      delete(c, 1, length(c) - nq - 2)
    end;
    d := c;
    np := np + 1
  end;
  np := n - 1;
  for k := 0 to (n - 1) div 2 do begin
    nq := x[k];
    x[k] := x[np];
    x[np] := nq;
    np := np - 1
  end;
  np := n - 1;
  c := makestring(x, np, P);
  while (length(c) > 2) and (c[length(c) - 1] = '0') do
    delete(c, length(c) - 1, 1);
  tobasefrac := c
end; { tobasefrac }

END.  { B2TOZ }
