DUzun's Web
Programare, proiecte personale, divertisment

{-----------------------------------------------------------------------------}

Program Use_of_QSort;

{ Se citeste o lista de Nume, Prenume si Medii (real) dintr-un fisier

  Apoi, folosind algoritmul de sortare rapida QSort (varianta optimizata

  din punctul de vedere al memoriei), se sorteaza aceasta lista in ordinea 

  crescatoare a mediilor si se salveaza rezultatul in alt fisier

}

uses crt;

const

     lenNume = 20;

     lenRand = 80;

     maxElev = 500;

     surs    = 'BAC.IN';

     dest    = 'BAC.OUT';

​

type  TElev = record

            Nume,

            Prenume: String[lenNume];

            Media:   Real;

      end;

      PElev = ^TElev;

      NElev = 0..maxElev-1;

      NRand = 0..lenRand;

​

var fisier: Text;

    lin:  String[lenRand];

    i, j: NElev;

    Elev: array[NElev] of PElev;

​

{-----------------------------------------------------------------------------}

Procedure Swap(var p1,p2: PElev);  {Interschimba continutul a doi pointeri}

var P: Pointer;

begin

   P:=p1;

   p1:=p2;

   p2:=P;

end;

{-----------------------------------------------------------------------------}

Function  Partition(B, E: NElev): NElev;

{Se ia ca reper ultimul element din lista si se compara cu el toata lista.

{Elementele care au .Media mai mare decs ultimul (decat V), sunt stocate la inceputul listei,

{iar indicatorul inceputului listei (B) se incrementeaza pentru a indica varful elementelor comparate}

var V: Real;

    i: NElev;

begin

     if E>B then begin

        V:=Elev[E]^.Media;   {V - valoarea reperului}

        for i:=B to E-1 do if Elev[i]^.Media>V then

          begin              {toate elementele mai mari ca reperul sunt plasate la inceputul listei}

             Swap(Elev[i], Elev[B]);

             inc(B);         {B indica ultimul element din lista care este mai mare ca reperul}

          end;

          Swap(Elev[E], Elev[B]); {amplasam elementul de reper in pozitia sa finala}

        Partition:=B;

     end;

end;

{-----------------------------------------------------------------------------}

Procedure QuickSort(beginL, endL: NElev);

var Left, Mid: NElev;

   {--------------------------------------------}

   Procedure QSort(Right: NElev);

   {Functia recursiva: are doar un singur argument pentru a folosi cat mai putina memorie}

   begin

     if Right>Left then begin           {Daca nu se compara cu sine acelasi element}

       Mid:=Partition(Left, Right);     {Elementul nr Mid este deja la locul sau}

       if Mid>Left then QSort(Mid-1);   {Aranjeaza toate elementele de la Left pana la Mid si amplaseaza Left pe Mid+1}

       inc(Left,1);

       QSort(Right);

     end;

     Left:=Right+1;

   end;

   {--------------------------------------------}

begin

   Left:=beginL;

   QSort(endL);

end;

{-----------------------------------------------------------------------------}

Function nrElevi: NElev;

var n: NElev;

begin

     n:=0;

     while (Elev[n] <> nil) do inc(n);

     nrElevi:=n;

end;

{-----------------------------------------------------------------------------}

Function nospace(nr:NRand):NRand;

{Nr. urmatorului caracter diferit de ' ' in lin, incepand cu caracterul nr, sau 0, daca nu exista}

begin

     repeat

         inc(nr);

     until (nr>length(lin))or(lin[nr]<>' ');

     if nr<=length(lin) then nospace:=nr

                        else nospace:=0;

end;

{-----------------------------------------------------------------------------}

Function getWord(var nr: NRand): String; {Intoarce cuvantul incepand cu caracterul nr+1 din lin}

var a: NRand;

    w: String;

begin

     w:='';                            {aici se va obtine cuvantul}

     a:=nospace(nr);                   {primul caracter diferit de ' ' de dupa lin[nr]}

     nr:=a-1;

     while (a<>0)and(a=nr+1) do begin  {Cat timp exista caractere diferite de spatiu si acestea sunt consecutive}

            w:=w+lin[a];

            nr:=a;                     {pentru a verifica consecutivitatea}

            a:=nospace(a);             {urmatorul caracter diferit de ' '}

     end;

     if a<>0 then nr:=a-1 else nr:=0;

     getWord:=w;

end;

{-----------------------------------------------------------------------------}

Function  linToElev(nr: NElev):Byte;

var a:    NRand;

    N, P: String[lenNume];

    M:    Real;

    Cod:  Integer;

    Med:  String;

begin

     linToElev:= 0; {Daca formatul linieie nu este corect, functia intoarce 0}

     M:=0;          {Daca campul pentru medie lipseste, media se considera 0}

     a:=0;

     N:=getWord(a);

     if a=0 then exit; {Daca nu exista cuvantul pentru Prenume sau nici pentru Nume, se iese din subprogram}

     P:=getWord(a);

     if a<>0 then begin

        Delete(lin,1,a);

        Val(lin,M,Cod);

        if Cod<>0 then exit;

     end;

     if Elev[nr] = nil then new(Elev[nr]);

     with Elev[nr]^ do begin

          Nume    := N;

          Prenume := P;

          Media   := M;

     end;

     linToElev:= 1;

end;

{-----------------------------------------------------------------------------}

Function  ReadFile:NElev;

begin

     Assign(fisier,surs);

     Reset(fisier);

     i := 0;

     while (not eof(fisier) and (i<maxElev)) do begin

            readln(fisier, lin);

            inc(i, linToElev(i));  {Daca a fost adaugat un Elev, se incrementeaza i}

     end;

     Close(fisier);

     ReadFile := i;

end;

{-----------------------------------------------------------------------------}

Function ElevToLin(nr: NElev):String;

begin

   lin:='';

   if (Elev[nr]<>nil) then

   with Elev[nr]^ do begin

      str(Media:4:2, lin);

      lin:=Nume+' '+Prenume+' '+lin;

   end;

   ElevToLin:=lin;

end;

{-----------------------------------------------------------------------------}

Function WriteFile:NElev;

begin

     Assign(fisier,dest);

     ReWrite(fisier);

     i:=0;

     while (Elev[i]<>nil) do begin

            writeln(fisier, ElevToLin(i));

            inc(i);

     end;

     Close(fisier);

     WriteFile:=i;

end;

{-----------------------------------------------------------------------------}

Procedure Show;

begin

     i:=0;

     while(Elev[i]<>nil) do begin

         writeln(ElevToLin(i));

         inc(i);

     end;

end;

{-----------------------------------------------------------------------------}

Begin

clrscr;

​

ReadFile;

QuickSort(0,nrElevi-1);

Show;

WriteFile;

​

readkey;

End.

{-----------------------------------------------------------------------------}

​

​