DUzun's Web
Programare, proiecte personale, divertisment

DUzun it's ME
 
 Home >> Fișiere \ 09 aprilie 2025, 16:38:25 \  
*
Conținut

longnum.pas

​x
 
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.
​
​

*

Aici acumulez programe şi algoritmi interesanti alcătuiţi de mine (cu mici excepţii) pe parcursul studierii unor limbaje de programare.

Cea mai mare parte din ele sunt realizate în Pascal. 

Nu am scopul creării unui curs specializat sau a descrierii detaliate a anumitor limbaje, ci doar prezint informaţii utile, plus ceva exemple interesante...

 

Răsfoitorul de fișiere (File Browser):

Codul sursă al programelor este organizat în mape şi fişiere.

Paginile care conțin cod sursă de programe de regulă au un răsfoitor de fișiere în partea stangă a paginii reprezentat de un bloc cu titlul „File Browser”.

Pentru a vizualiza un program sau conţinutul unei mape, faceţi click pe numele fişierului / mapei. Dacă fişierul nu este textual, el se va descărca automat, iar dacă este textual, conținutul lui se va afișa într-un bloc pe centrul paginii.

Pentru a descărca un fişier, faceţi click pe dimensiunea (size) lui.
arr_d Limba / Language


 

arr_r Login
 
 
Loading...