unit LongNum;
{------------------------------------------------------------------------}
interface
uses
     dos, crt, strings;
{------------------------------------------------------------------------}
const
     maxBuf  = 1024;  {4..65535}
     tmpName = '_lnm';
     numExt  = '.num';
     M1      = $FF;
     S1      = $80;
     chZero  = $30; {cod ASCII}
{------------------------------------------------------------------------}
type
    TBufSize = 0..maxBuf;
    TBuf     = record len: TBufSize; s: PChar; end;
    PBuf     = ^TBuf;

    BFile = file of byte;
{------------------------------------------------------------------------}
var 
    AddOverFlow: boolean;

{------------------------------------------------------------------------}
{         Operatii cu numere file                                        }
{------------------------------------------------------------------------}
{
   
   src <> dst si src1 <> src2 sunt conditii necesare
   rs - valoarea ramasa de la ultima operatie
   by - factor sau impartitor
   
   
}
procedure fAdd(var src1, src2, dst: BFile);
procedure fMul(var src: BFile; by: word; rs: word);
function  fDiv(var src: BFile; by: word): word; {intoarce restul impartirii}
function  fNeg (var src, dst: BFile): byte; {intoarce byte-ul superior din dst}
function  fReduce(var src: BFIle): byte;    {reduce octetii inutili din src}
procedure fReverse(var src, dst: BFile);    {inverseaza ordinea octetilor in src}
function  fIsNull(var src: BFile): boolean; {verifica daca valoarea src este 0}

         {Functii de conversie dintre formele binara si textual-zecimala}
function fBin2Dec(var src, dst: BFile): longint;
function fDec2Bin(var src, dst: BFile): longint;

{------------------------------------------------------------------------}
{         Operatii cu numere string                                      }
{------------------------------------------------------------------------}
{Aceste functii sunt proiectate pentru a fi chemate de catre functiile 
 ce opereaza pe fisiere, de aceea nu recomand utilizarea lor independenta 
 daca nu intelegi mecanismul lor de functionare }         
function sAdd(var src, dst: TBuf; rs: word): word;  {signed operations}
function sDiv(var src: TBuf; by: word; rs: word): word;
function sMul(var src: TBuf; by: word; rs: word): word;
function sNot(var src: TBuf): byte; {Intoarce ultimul byte}
function sNeg(var src: TBuf; rs: byte): byte;
function sReduce(var src: TBuf): TBufSize;
function sReverse(var src: TBuf): TBufSize;
function snAdd(var src: TBuf; n: word): word;

{------------------------------------------------------------------------}
{         Functii ajutatoare                                             }
{------------------------------------------------------------------------}
function readBufDec(var src: BFile; var buf: TBuf; nr: TBufSize): TBufSize;
function readBuf (var src: BFile; var buf: TBuf): TBufSize;
function writeBuf(var dst: BFile; var buf: TBuf): TBufSize;
function copyFile(var src, dst: BFile): longint;
function fileExists(fn: string): boolean;
function tempFileName: string;
function tempFile(var f: BFile): string;

function setBLen(var src: TBuf; l: TBufSize): TBufSize;
function Str2Buf(st: string; var b: TBuf): TBufSize;
{------------------------------------------------------------------------}

implementation
{$I-}
{------------------------------------------------------------------------}
var
{ 
  b - la citirea/scrierea datelor din/in fisier
  g - operatii cu semnul numarului
  w - counter la citire/scriere
  r - restul de la operatia precedenta
  pcl si pcr - pointeri la lr si r, respectiv
  plX - pointer la lr incepand cu octetul X
  Daca lr   ::= (00, 01, 02, 03), atunci  
       pl0^ ::= (00, 01), 
       pl1^ ::= (01, 02), 
       pl2^ ::= (02, 03)
  Am avut in vedere faptul ca octetii intr-o variabila de tip longint 
  (4 la numar) sunt aranjati de la cel de jos spre cel de sus in memorie. 
}
   b, g: byte;
   w, r: word;
   lr: longint;
   pcl, pcr: PChar;
   pl0, pl1, pl2: ^Word; 
   buf1, buf2: TBuf;
{------------------------------------------------------------------------}
function setBLen(var src: TBuf; l: TBufSize): TBufSize;
var i: TBufSize;
    p: Pointer;
begin
  if l < 0      then l := 0;
  if l > maxBuf then l := maxBuf;
  i := src.len;
  if i <> l then with src do begin
     p   := s;
     len := l;
     if l = 0 then s := nil else begin
       GetMem(s, l);
       if l > i then l := i;
       StrMove(s, p, l);
     end;
     FreeMem(p, i);
  end;
  setBLen := src.len;
end;
{------------------------------------------------------------------------}
function Str2Buf(st: string; var b: TBuf): TBufSize;
begin
   setBLen(b, length(st));
   StrPCopy(b.s, st);
   Str2Buf := b.len;
end;
{------------------------------------------------------------------------}
procedure fAdd(var src1, src2, dst: BFile);
var f: ^BFile;
begin
     reset (src1);
     reset (src2);
     rewrite(dst);
     r := 0;

     while not (eof(src1) or eof(src2)) do
        begin
           readBuf(src1, buf1);
           readBuf(src2, buf2);
           sAdd(buf1, buf2, r);
           writeBuf(dst, buf2);
        end;

    g := $00;
    if eof(src2) then begin
       f := @src1;
       with buf2 do if (len <> 0) and (ord(s[len-1])and S1 <> 0) then g := M1;
    end else begin
       f := @src2;
       with buf1 do if (len <> 0) and (ord(s[len-1])and S1 <> 0) then g := M1;
    end;

    while ( (r xor g)and 1 <> 0  ) and not eof(f^) do
       begin
          readBuf(f^, buf2);
          snAdd(buf2, r);
          writeBuf(dst, buf2);
       end;

    while not eof(f^) do begin readBuf(f^, buf2); writeBuf(dst, buf2); end;
end;
{------------------------------------------------------------------------}
function  fNeg (var src, dst: BFile): byte; 
begin
     reset (src);
     rewrite(dst);
     r := 1;
     while (readBuf(src, buf1) or r) > 0 do
        begin
           sNeg(buf1, r);
           writeBuf(dst, buf1);
        end;
fNeg := b;
end;
{------------------------------------------------------------------------}
function sReduce(var src: TBuf): TBufSize;
begin
   r := src.len;
   if r > 1 then with src do
   begin
     dec(r);
     g := ord(s[r]);
     if (g = $00) or (g = M1) then
     begin
       repeat
         dec(r);
         b := ord(s[r]);
       until (g <> b)or(r = 0);
       if (g xor b) and S1 <> 0 then inc(r);
       setBLen(src, r+1);
     end;
   end;
   sReduce := src.len;
end;
{------------------------------------------------------------------------}
function fReduce(var src: BFIle): byte;
begin
   reset(src);
   lr := FileSize(src);
   if lr = 0 then g := 0 else begin
     dec(lr); 
     seek(src, lr); 
     read(src, g);
     if (lr > 0) and ((g = $00) or (g = M1)) then begin
       repeat
         dec(lr); seek(src, lr); read(src, b);
       until (g <> b) or (lr = 0);
       if (g xor b) and S1 <> 0 then inc(lr);
       seek(src, lr+1); truncate(src);
     end;
   end;  
   fReduce := g;
end;
{------------------------------------------------------------------------}
function sReverse(var src: TBuf): TBufSize;
var c: char;
begin
   with src do if len > 0 then begin
     r := len div 2;
     dec(len);
     while r > 0 do begin
        dec(r);
        c := s[r]; s[r] := s[len-r]; s[len-r] := c;
     end;
     inc(len);
   end;
sReverse := src.len;
end;
{------------------------------------------------------------------------}
procedure fReverse(var src, dst: BFile);
var l: longint;
begin
  reset(src);
  rewrite(dst);
  l := FileSize(src);
  l := l - ((l-1) mod maxBuf + 1);
  repeat
    seek(src, l);
    readBuf(src, buf2);
    sReverse(buf2);
    writeBuf(dst, buf2);
    dec(l, maxBuf);
  until l < 0;
end;
{------------------------------------------------------------------------}
function fIsNull(var src: BFIle): boolean;
begin
  reset(src);
  b := 0;
  while not eof(src) and (b=0) do read(src, b);
  fIsNull := b=0;
end;
{------------------------------------------------------------------------}
function fBin2Dec(var src, dst: BFile): longint;
var sn: byte;
    l : longint;
    f : BFile;
begin
  fReduce(src);
  if g and S1 <> 0 then begin
     sn := ord('-');
     fNeg(src, dst);
  end else begin
     sn := ord('+');
     copyFile(src, dst);
  end;
  tempFile(f);
  setBLen(buf1,4);
  repeat
     fDiv(dst, 10000);   {in lr se obtine restul de la impartire}
     for b := 0 to 3 do with buf1 do begin
         s[b] := chr((lr mod 10) + chZero);
         lr   := lr div 10;
     end;
     writeBuf(f, buf1);
     fReduce(dst);
  until fIsNull(dst);
  l := FileSize(f);
  if l = 0 then begin
     b := 0; write(f, b); inc(l);
  end else begin
     b := chZero;
     while (b=chZero)and(l>0)do begin
       dec(l);
       seek(f, l);
       read(f, b);
     end;
     if l = 0 then inc(l);
     seek(f, l+1); truncate(f);
     if sn = ord('-') then write(f, sn);
  end;
  fReverse(f, dst);
  fBin2Dec := FileSize(dst);
  close(f);
  erase(f);
end;
{------------------------------------------------------------------------}
function fDec2Bin(var src, dst: BFile): longint;
var sn: byte;
    f : BFile;
    i : word;
begin
  rewrite(dst);
  reset(src);  
  read(src, sn);
  reset(src);  

  repeat
     i := readBufDec(src, buf1, 4);
     w := 1;
     r := 0;
     b := 0;
     while b < i do with buf1 do begin r := 10*r + (ord(s[b])-chZero); w := 10*w; inc(b); end;
     if w > 1 then fMul(dst, w, r);
  until i < 4;
  seek(dst, FileSize(dst));
  b := $00;
  write(dst, b); {numar pozitiv}
  fReduce(dst);
  if sn = ord('-') then begin
     tempFile(f);  {close(f); reset(f);}
     fNeg(dst, f);
     copyFile(f, dst);
     close(f);  erase(f);
  end;
  fDec2Bin := FileSize(dst);
end;
{------------------------------------------------------------------------}
function snAdd(var src: TBuf; n: word): word;
var l: word;
begin
   r := n;
   if src.len > 0 then with src do begin
      l := 0;
      while ( (g xor r)and 1 <> 0 ) and (l < len) do begin
        inc(r, ord(s[l]) + g);
        s[l] := chr(r and M1);
        r := r shr 8;
        inc(l);
      end;
   end;
snAdd := r;
end;
{------------------------------------------------------------------------}
function sAdd(var src, dst: TBuf; rs:word): word;
var i, m: word;
    lw, hg: PBuf;
begin
    g := 0;
    if dst.len > src.len then begin lw := @src; hg := @dst; end
                         else begin lw := @dst; hg := @src; end;

    m := lw^.len;                     {Pana la m exista cifre si in dst, si in src}
    if (m > 0) and (ord(lw^.s[m-1])and S1 <> 0) then g := M1 else g := 0; {Semnul nr mai mic}

    r := rs;                          {Restul de la operatia precedenta}
    i := 0;
    while (i < m) do begin
       inc( r, ord(dst.s[i]) + ord(src.s[i]) );
       dst.s[i] := chr(Lo(r));  r := Hi(r);  inc(i);
    end;

    if i < hg^.len then begin
       m := setBLen(dst, hg^.len);       {Pana la m exista cifre numai in hg^}
       while ( (r xor g)and 1 <> 0 ) and (i < m) do begin
         inc( r, ord(hg^.s[i]) + g );
         dst.s[i] := pcr[0]; r := Hi(r);  inc(i);
       end;
       {In locul buclei de mai sus pot fi folosite urmatoarele doua bucle}
       {
       if( g and $80 <> 0 ) then
          while (r = 0) and (i < m) do begin
            inc( r, ord(hg^.s[i]) + M1 );
            dst.s[i] := chr(Lo(r));  r := Hi(r);  inc(i);
          end
       else
          while (r <> 0) and (i < m) do begin
            inc( r, ord(hg^.s[i]) );
            dst.s[i] := chr(Lo(r));  r := Hi(r);  inc(i);
          end;
       } 
       if hg<>@dst then while (i < m) do begin dst.s[i] := src.s[i]; inc(i); end;
    end;

sAdd := r;
end;
{------------------------------------------------------------------------}
function sMul(var src: TBuf; by: word; rs: word): word;
var i: word;
begin
       with src do begin
          r  := rs;
          lr := 0;
          i  := 0;
          while (i+1<len) do begin {32 bits}
               pcl[0]:= s[i];
               pcl[1]:= s[i+1];
               lr   := lr * by + r;
               s[i] := pcl[0]; inc(i);
               s[i] := pcl[1]; inc(i);
               r    := pl2^;
               pl2^ := 0;
          end;
          if i<len then begin    {16 bits}
               pl1^ := 0;
               pcl[0]:= s[i];
               lr   := lr * by + r;
               s[i] := pcl[0]; inc(i);
               r    := pl1^;
          end;
          if AddOverFlow and (len < maxBuf)and(r <> 0) then begin
              if( pcr[1] <> #0) then begin
                setBLen(src, i+2);
                s[i]:= pcr[0]; inc(i);
                s[i]:= pcr[1];
              end else begin
                setBLen(src, i+1);
                s[i]:= pcr[0];
              end;
              r := 0;
          end;
       end;
sMul := r; {se intoarce valoarea aflata in lr - ceea ce nu a incaput in maxBuf bytes}
end;
{------------------------------------------------------------------------}
procedure fMul(var src: BFile; by: word; rs: word);
var aof: boolean;
begin
     reset (src);
     r := rs;
     aof := AddOverFlow;
     repeat
       readBuf(src, buf2);
       AddOverFlow := w = 0;
       sMul(buf2, by, r);
       seek(src, filePos(src)-w);
       writeBuf(src, buf2);
     until (r = 0) and eof(src);
     AddOverFlow := aof;
end;
{------------------------------------------------------------------------}
{ Imparte numarul continut in s la by si intoarce restul acestei impartiri }
function sDiv(var src: TBuf; by: word; rs: word): word;
var i: word;
begin
       pl0^ := rs;
       with src do begin
          i := len;
          while (i>1) do begin {32 bits}
               dec(i, 2);
               pl2^  := pl0^;
               pcl[0]:= s[i];
               pcl[1]:= s[i+1];
               r     := lr div by;
               lr    := lr mod by;
               s[i]  := pcr[0];
               s[i+1]:= pcr[1];
          end;
          if i>0 then begin    {16 bits}
               dec(i);
               pl1^   := pl0^;
               pcl[0] := s[i];
               r  := lr div by;
               lr := lr mod by;
               s[i] := pcr[0];
          end;
       end;
sDiv := lr; {se intoarce valoarea aflata in lr - restul impartirii la by a shirului}
end;
{------------------------------------------------------------------------}
function fDiv(var src: BFile; by: word): word;
var l: longint;
begin
     reset (src);
     lr := 0;
     l  := FileSize(src);
     l  := l - ((l-1) mod maxBuf + 1);
     repeat
       seek(src, l);
       readBuf(src, buf2);
       sDiv(buf2, by, lr);
       seek(src, l);
       writeBuf(src, buf2);
       dec(l, maxBuf);
     until l < 0;
fDiv := lr;
end;
{------------------------------------------------------------------------}
function sNot(var src: TBuf): byte;
begin
   r := 0;
   if src.len = 0 then begin setBLen(src, 1); src.s[0] := #$FF; end else
   with src do while r<len do begin s[r] := chr(not ord(s[r])); inc(r);  end;
   sNot := ord(src.s[r-1])
end;
{------------------------------------------------------------------------}
function sNeg(var src: TBuf; rs: byte): byte;
var l: word;
begin
   r := rs;
   l := 0;
   with src do while l<len do begin
      inc(r, not ord(s[l]));
      s[l] := chr(lo(r));
      r := hi(r);
      inc(l);
   end;
   sNeg := r;
end;
{------------------------------------------------------------------------}
function readBufDec(var src: BFile; var buf: TBuf; nr: TBufSize): TBufSize;
{Aceasta functie citeste nr octeti din src, si numai cifre zecimale
 Intoarce nr de octeti cititi din src, iar restul octetilor din buf, 
 pana la nr, sunt completati cu #0 }
begin
     w := 0;
     setBLen(buf, nr);
     while not eof(src) and (w<nr) do begin
         read(src, b); 
         if b in [chZero..chZero+9] then begin
            buf.s[w] := chr(b); 
            inc(w);
         end;
     end;
     readBufDec := w;
     while w<nr do with buf do begin s[w] := #0; inc(w); end;
end;
{------------------------------------------------------------------------}
function readBuf(var src: BFile; var buf: TBuf): TBufSize;
begin
     w := 0;
     if eof(src) then begin readBuf := 0; setBLen(buf,0); exit; end;
     setBLen(buf, maxBuf);
     while not eof(src) and (w<maxBuf) do begin
         read(src, b);
         buf.s[w] := chr(b);
         inc(w);
     end;
     if w<maxBuf then setBLen(buf, w);
readBuf := w;
end;
{------------------------------------------------------------------------}
function writeBuf(var dst: BFile; var buf: TBuf): TBufSize;
begin
     w := 0;
     while w<buf.len do begin
         b := ord(buf.s[w]);
         write(dst, b);
         inc(w);
     end;
writeBuf := w;
end;
{------------------------------------------------------------------------}
function copyFile(var src, dst: BFile): longint;
var r: longint;
begin
     r := 0;
     reset(src);
     rewrite(dst);
     repeat
        readBuf(src, buf2);
        inc(r, w);
        writeBuf(dst, buf2);
     until w < maxBuf;
copyFile := r;
end;
{------------------------------------------------------------------------}
function fileExists(fn: string): boolean;var Dir: SearchRec;
begin findFirst(fn, $3F, Dir); fileExists := DosError = 0; end;
{------------------------------------------------------------------------}
function tempFileName: string;
var t: string;
begin
    t := getenv('temp')+'\'+tmpName+'AAA.tmp';
    b := length(t)-4;
    while fileExists(t) do begin
     if t[b] = 'Z' then begin
        t[b]:='A';
        if t[b-1]='Z' then begin
           t[b-1]:='A';
           if t[b-2]='Z' then t[b-2]:='A' else inc(char(t[b-2]))
        end else inc(char(t[b-1]))
     end else inc(char(t[b]));
    end;
    tempFileName := t;
end;
{------------------------------------------------------------------------}
function tempFile(var f: BFile): string;
var fn: string;
begin
  fn := tempFileName;
  assign(f, fn);
  rewrite(f);
  tempFile := fn;
end;
{------------------------------------------------------------------------}
procedure Init;
var p: Pointer;
begin
 buf1.s := nil;
 buf2.s := nil;
 buf1.len := 0;
 buf2.len := 0;
 AddOverFlow := true;
 g := 0;
 p  := @r;                pcr := p;
 p  := @lr;     pl0:= p;  pcl := p;
 p  := pcl + 1; pl1:= p;
 p  := pcl + 2; pl2:= p;
end;
{------------------------------------------------------------------------}
begin
    Init;
end.