Prima Shareware 3/DuCom_Prima-Shareware-3_cd1.bin/PROGRAMO/PASCAL/HEJB/EXAM/SORT.PAS

Pascal/Delphi Source File | 1994-04-21 | 14.1 KB | 539 lines

{ ******************** Program Sort 3D ********************** }
{ ****** program demonstruje pouziti jednotky hejbunit ****** }
{* pri nazornem zobrazeni procedury QuickSort na obrazovce * }
{$define intr}
uses Dos, Obraz3D, Unhejb, Unobdel, Unvokno, Unmenu, Untimer, Crt, Unpisbmp;

const N            : Integer = 60; { poçet prvkû }
      Poc_Pom      : Integer = 40; { poçáteçní pomalost animace }
      Metoda       : Integer = 0;  { zvolená metoda }

      _Qsort    = 1;               { çísla metod }
      _Buble    = 2;
      _Vyber    = 3;
      _Merge    = 4;
      _Qsortpar = 5;

      _Nahodna   = 1;              { çísla posloupností }
      _Vzestupna = 2;
      _Sestupna  = 3;

      _Posl        : Byte    = 0;  { zvolená posloupnost }

      Jit_Ven      : Boolean = False; { Tato promênná se stará o vypadnutí ze Sortu, ve kterém se nám uæ nechce bÿt }

type
  Typ_Moje_Menu = object(Typ_Menu_Vyber)
                    procedure Vm0;virtual;
                  end;

  Typ_Prvek = object(Typ_Integer)
                Klic : Integer;
                procedure Dodel_Anim_Prohod(var S_Kym : Typ_Prvek);
              end;

  Typdat   = array[0..100]of Typ_Prvek;

var  Data : Typdat; { pole t⌐ídênÿch prvkû }

procedure Cisla_Prvku(Zob : Byte);
{ procedura zobrazuje a zhasíná na obrazovce çísla prvkû }
const Pomzob : Byte = 0;
var  S    : string[5];
     K    : Integer;
     Pom  : _Bod3D;
begin
  if Pomzob <> Zob then
  for K := 1 to N do
    begin
      Str(K, S);
      Pom := Hezky_Rozmistit(K)^;
      case Zob of
        2 : Obrazovka.Smaz_Retez(Pom.X+2, Pom.Y, Pom.Z+1, 2, S, True);
        1 : Obrazovka.Pis_Retez(Pom.X+2, Pom.Y, Pom.Z+1, 2, S, True)
      end;
    end;
  Pomzob := Zob;
end;

const Cesta : array[1..3]of Typ_Instrukce = (Vm0, Jmpa0, Endc) ;

const Menudef : string =
'49 15 5  15 112 10  30 11  6 4'+ { posice [53, 11, 4] barva textu 15, barva zvyraznêného ⌐ádku 112, barva rámeçku 10}
                                  { rozmêr 30x11, 6 prvkû, zaçátek na çtvrtém }
'delay~ i 42 14 7  10 10 96  40  1 400  1'+ { editace çísla, posice [46, 10, 4], barva textu 10, barva rámeçku 10,
                                            { zvÿraznênÿ text téæ 96, poçáteçní hodnota 40, minimum 1 a maximum 400 }
'method~ v 31 15 9 15 112 10 20 7 5 1'+
  'quicksort~o'+
  'bublesort~o'+
  'maxsort~o'+
  'mergesort~o'+
  'paralelni qsort~o';
  Menudef2 : string =
'Element numbers~v 21 16 5 15 112 10 30 4 2 2'+
  'on~o'+
  'off~o'+
'sequence~v 36 16 3 15 112 10 15 5 3 1'+
  '''random''~o'+
  'increasing~o'+
  'decreasing~o'+
'run~v 36 18 1 15 112 10 15 4 2 2'+
  'start~o'+
  'stop~o'+
'end~o';

procedure Typ_Moje_Menu.Vm0;
var C : Word;
    S : string[5];
begin
  if KeyPressed then
    begin
      C := Byte(ReadKey);
      if C = 0 then  C := 256* Byte(ReadKey);

      Zpracuj_Key(C); { pokud je stisknuta klávesa, ovlivní se stav menu }

      { çtení hodnot menu }
      if (Sub_Menu^[5]^.Out_Hodnota = 2) or
         (Out_Hodnota = 6)
         then Jit_Ven := True
         else Jit_Ven := False;
      if (Sub_Menu^[3]^.Potvrzeno)
         then Cisla_Prvku(Sub_Menu^[3]^.Out_Hodnota);
      if Metoda <> Sub_Menu^[2]^.Out_Hodnota then
        begin
          Metoda := Sub_Menu^[2]^.Out_Hodnota;
          Jit_Ven := True;
        end;
      if Sub_Menu^[1]^.Out_Hodnota <> Poc_Pom then
        begin
          Poc_Pom := Sub_Menu^[1]^.Out_Hodnota;
          Unfront.set_Pomalost(Poc_Pom);
        end;
      if Sub_Menu^[5]^.Out_Hodnota = 2 then
        if Sub_Menu^[4]^.Potvrzeno then
          begin
            _Posl := Sub_Menu^[4]^.Out_Hodnota;
            for C := 1 to N do
              begin
                case _Posl of
                    _Nahodna : Data[C].Klic := Random(1000);
                    _Vzestupna : Data[C].Klic := C;
                    _Sestupna : Data[C].Klic := N-C;
                  end;
                Data[C].Vytvor(Data[C].Klic, 3, C mod 10 + 5, C mod 10 + 5, Strom_Ram);
              end;
            Sub_Menu^[4]^.__Stav_Menu := Sub_Menu^[4]^.__Stav_Menu and ($Ff xor __Potvrzena_Hodnota)
          end;
    end;
end;

type Typ_Pocitani = object(Typ_Vokynko) { t⌐ída, ve které se sçítá p⌐i⌐azení a porovnání }
                      Porovnani, Prohozeni : Integer;
                      constructor Init;
                      procedure Nuluj;
                      procedure Zvets_Porovnani;
                      procedure Zvets_Prohozeni;
                      procedure Zapis;
                    end;

constructor Typ_Pocitani.Init;
begin
  Typ_Vokynko.Init;
  Presun(11, 18, 1);
  Porovnani := 0;
  Prohozeni := 0;
  Vytvor_Ram(27,4,4,4,Strom_Ram);
  set_Psaci_Barva(27);
  GotoXY(1,1);
  Pis('Num of comparisons  :');
  WriteLn;
  Pis('Num of assignements :');
  Zobraz;
end;

procedure Typ_Pocitani.Nuluj;
begin
  Porovnani := 0;
  Prohozeni := 0;
  Zapis;
end;

procedure Typ_Pocitani.Zapis;
begin
  GotoXY(22,1);Pisint(Porovnani, 4);
  GotoXY(22,2);Pisint(Prohozeni, 4);
end;

procedure Typ_Pocitani.Zvets_Porovnani;
begin
  Inc(Porovnani);
  Zapis;
end;

procedure Typ_Pocitani.Zvets_Prohozeni;
begin
  Inc(Prohozeni);
  Zapis;
end;

var __Pocit : Typ_Pocitani; {objekt, ve kterém se zobrazuje poçet p⌐i⌐azení a porovnání }

function Vetsi( Jedno, Druhe : Integer ) : Boolean;
begin
   if Jedno > Druhe
                  then Vetsi := True
                  else Vetsi := False;
  __Pocit.Zvets_Porovnani;
end;

function Mensi( Jedno, Druhe : Integer ) : Boolean;
begin
if Jedno < Druhe
                  then Mensi := True
                  else Mensi := False;
  __Pocit.Zvets_Porovnani;
end;

function Rovno( Jedno, Druhe : Integer ) : Boolean;
begin
  if Jedno = Druhe
    then Rovno := True
    else Rovno := False;
  __Pocit.Zvets_Porovnani;
end;


procedure Typ_Prvek.Dodel_Anim_Prohod;
var Pom : Typ_Prvek;
begin
  Typ_Obdelnik.Dodel_Anim_Prohod(S_Kym);

  Pom.Init;
  Pom   := Self;
  Self  := S_Kym;
  S_Kym := Pom;
  __Pocit.Zvets_Prohozeni;
  __Pocit.Zvets_Prohozeni;
  __Pocit.Zvets_Prohozeni;
end;

var  __Menu : Typ_Moje_Menu;
     K      : Integer;
     S      : string;

procedure Maxsort(var Data : Typdat);
var I, J : Integer;
begin
  for I := 1 to N-1 do
    for J := I to N-1 do
      if Vetsi(Data[I].Klic, Data[J].Klic) then
        begin
          Data[I].Dodel_Anim_Prohod(Data[J]);
          if Jit_Ven then Exit;{ aby se nemuselo dlouho cekat, nemusí bÿt }
        end;
end;

procedure Bublesort(var Data : Typdat);
var I, J : Integer;
begin
  for I := 1 to N-1 do
    for J := N-1 downto I do
      if Vetsi(Data[J].Klic, Data[J+1].Klic) then
        begin
          Data[J+1].Dodel_Anim_Prohod(Data[J]);
          if Jit_Ven then Exit;{ aby se nemuselo dlouho cekat, nemusí bÿt }
        end;
end;

procedure Quicksortpar(var Data : Typdat);
{ demonstruje moænost paralelního zpracování p⌐i qsotu }
var Pom : Typ_Prvek;
    I   : Integer;
procedure Castecne_Usporadani(K,M:Integer);

 var I, J, Y, Fn : Integer;

 begin
  I := K;
  J := M;
  Y := Data[(K + M) div 2].Klic;
  repeat
    while Mensi(Data[I].Klic, Y) do I := I+1;
    while Vetsi(Data[J].Klic, Y) do J := J-1;
    if I <= J then
     begin
       if not Rovno(Data[J].Klic, Data[I].Klic) then
         begin
           repeat
           until (not Data[I].Hejbe_Se) and (not Data[J].Hejbe_Se);

           Data[I].Anim_Prohod(Data[J]);
           __Timer.Zarad_Prvek(Data[I]);
           __Timer.Zarad_Prvek(Data[J]);
            { prohozeni na obrazovce }

           Pom     := Data[I];
           Data[I] := Data[J];
           Data[J] := Pom;
            { prohozeni v pameti }
           __Pocit.Zvets_Prohozeni;
           __Pocit.Zvets_Prohozeni;
           __Pocit.Zvets_Prohozeni;

           if Jit_Ven then Exit;{ aby se nemuselo dlouho cekat, nemusí bÿt }
         end;
       I := I+1;
       J := J-1;
     end;
  until I>J;

  if K < J then Castecne_Usporadani(K, J);
  if I < M then Castecne_Usporadani(I, M);

 end;  {pomocne procedury Castecne_usporadani}

begin
   Pom.Init;
   Castecne_Usporadani(1,N);
   __Timer.Dodelej_Pohyb_Na_Pocet(1); { ve frontê __timer zûstane pouze prvek - menu }
end;

procedure Quicksort(var Data : Typdat);
{ demonstruje klasickÿ qsort }
var Pom : Typ_Prvek;

procedure Castecne_Usporadani(K, M : Integer);

 var I, J, Y, Fn : Integer;

 begin
  I := K;
  J := M;
  Y := Data[(K + M) div 2].Klic;
  repeat
    while Mensi(Data[I].Klic, Y) do I := I+1;
    while Vetsi(Data[J].Klic, Y) do J := J-1;
    if I <= J then
     begin
       if not Rovno(Data[J].Klic, Data[I].Klic) then
         begin
           Data[I].Dodel_Anim_Prohod(Data[J]);

           if Jit_Ven then Exit;{ aby se nemuselo dlouho cekat, nemusí bÿt }
         end;
       I := I+1;
       J := J-1;
     end;
  until I>J;

  if K < J then Castecne_Usporadani(K, J);
  if I < M then Castecne_Usporadani(I, M);

 end;  {pomocne procedury Castecne_usporadani}

begin
   Pom.Init;
   Castecne_Usporadani(1,N);
end;

procedure Mergesort(var Data : Typdat);
var J : Integer;

procedure Vnitrek;
var Pompole : array[0..9]of Integer;
    Pomdata : Typdat;
    Pomind  : array[0..9,1..30]of Integer;
    I, J, Pom, Pomid : Integer;


  procedure Trida(var Prvek : Typ_Prvek; Ktera : Integer);
  begin
    Prvek.Dodel_Anim_Posun_Bod(Xyz_Bod(Ktera*5, Obrazovka.Y_Obr- 5- (Pompole[Ktera]*2+1), -Pompole[Ktera])^);
    Inc(Pompole[Ktera]);
    Pomind[Ktera, Pompole[Ktera]] := J;
    Pomind[Ktera, Pompole[Ktera]+1] := 0;
    __Pocit.Zvets_Prohozeni;
  end;

  function Moc(Co, Nakolik : Integer):Integer;
  var I, A : Integer;
  begin
    A := 1;
    for I := 1 to Nakolik do A := A*Co;
    Moc := A;
  end;

begin
  for J := 1 to N do Pomdata[J].Init;
  for I := 0 to 2 do
    begin
      for J := 0 to 9 do
        begin
          Pompole[J] := 0;
          Pomind[J,1]:=0;
        end;

      for J := 1 to N do
        begin { rozmístêní objektû do t⌐íd podle I-té çíslice }
          Trida(Data[J], (Data[J].Klic div Moc(10,I)) mod 10);
          if Jit_Ven then Exit;{ aby se nemuselo dlouho cekat, nemusí bÿt }
        end;

      Pomid := 1;
      for J := 0 to 9 do
        begin
          Pom := 1;
          while Pomind[J, Pom] <> 0 do
            begin
              Pomdata[Pomid] := Data[Pomind[J, Pom]];
              Inc(Pomid);
              Inc(Pom)
            end;
        end;
      for J := 1 to N do Data[J] := Pomdata[J];
      delay(1400);
      for J := 1 to N do
        begin
          Data[J].Dodel_Anim_Posun_Bod(Hezky_Rozmistit(J)^);
          if Jit_Ven then Exit;{ aby se nemuselo dlouho cekat, nemusí bÿt }
          __Pocit.Zvets_Prohozeni;
        end;
    end;
end;

begin
  Vnitrek;
  for J := 1 to N do Data[J].Presun_Bod(Hezky_Rozmistit(J)^);
end;











var P    : Pchar;
    I, J : Word;

begin
  J := Length(Menudef)+Length(Menudef2);
  GetMem(P, J+1);
  for I := 0 to Length(Menudef) do
    P^[I] := Menudef[I+1];
  for I := Length(Menudef)  to J-1 do
    P^[I] := Menudef2[I-Length(Menudef)+1];

  Randomize;

  Obrazovka.Nastav_mod(3+__Sada_3D_8X8);   { nastavi hezky vypadajici sadu }
  Obrazovka.ClrScr;
  I := 0;
  Unfront.set_Pomalost(Poc_Pom);
  __Menu.Init(P,I);
  __Menu.Hejbej(Cesta);
  __Timer.Zarad_Prvek(__Menu);
  __Menu.GotoXY(1,7);
  __Menu.set_Psaci_Barva(LightRed);
  __Menu.Pis('   Demo k jednotce Unhejb');
  __Menu.WriteLn;
  __Menu.Pis('   Vyrobeno ve Praze 1993');
  __Menu.WriteLn;
  __Menu.Pis('PrScr uloæí obrazovku do BMP');

   { Pro zkopírování obrazovky na disk, viz UnPisBMP }
   { Obrazovkové soubory na disku se jmenují postupnê sort1.bmp, sort2.bmp }

  set_Par_Pisbmp('sort',nil);
  On_Pisbmp;

   { Inicializace poçítadla porovnání a prohození }
  __Pocit.Init;

  {$ifdef intr}
  __Timer.On;
  {$endif}

   { Zobrazení menu }
  __Menu.Otevri;

  for K := 1 to N do
    begin
       { inicialisace data[k]  - nutná ! }
      Data[K].Init;
      Data[K].Presun_Bod(Hezky_Rozmistit(K)^);
       { prirazeni klice }
      Data[K].Klic := {1000-k}Random(1000);
           { vytvoreni tvaru tak, aby to hezky vypadalo }
      Data[K].Vytvor(Data[K].Klic, 3, K mod 10 + 5, K mod 10 + 5, Strom_Ram);
      Data[K].Zobraz;
    end;


  repeat
  {$ifndef intr}
    __Menu.Krok;
  {$endif}
    if __Menu.Sub_Menu^[5]^.Out_Hodnota = 1 then
      begin { Pokud je vybráno Run - Start, vunuluje se poçítadlo a spustí se p⌐íslu¿nÿ SORT }
        __Pocit.Nuluj;
        case Metoda of
          _Qsort    : Quicksort(Data);
          _Qsortpar : Quicksortpar(Data);
          _Buble    : Bublesort(Data);
          _Vyber    : Maxsort(Data);
          _Merge    : Mergesort(Data);
        end;
        Jit_Ven := False;
          { Skonçeno t⌐ídêní, tak se nastaví Run - Stop }
        __Menu.Sub_Menu^[5]^.Pom_set(2);
        __Menu.Prekresli;
      end;
  until (__Menu.Out_Hodnota = 6);

    { vypnutí tisku obrazovky }
  Off_Pisbmp;

    { Likvidace odpadkû }
  __Timer.Off;
  __Menu.Zrus;
  __Pocit.Zrus;

  for K := 1 to N do Data[K].Zrus;
   { vyruseni pameti, kterou zabiraji objekty a zhasnuti }

  Konec;    { vyruseni pameti, kterou zabirá obrazovka }
end.

procedure Bublesortpar(var Data : Typdat);
var I, J : Integer;
    Pom  : Typ_Prvek;
begin
  Pom.Init;
  for I := 1 to N-1 do
    for J := N-1 downto I do
      if Vetsi(Data[J].Klic, Data[J+1].Klic) then
        begin
          repeat
          until (not Data[J+1].Hejbe_Se) and (not Data[J].Hejbe_Se);
          Data[J+1].Anim_Prohod(Data[J]);
           __Timer.Zarad_Prvek(Data[J+1]);
           __Timer.Zarad_Prvek(Data[J]);
           Pom     := Data[J+1];
           Data[J+1] := Data[J];
           Data[J] := Pom;
            { prohozeni v pameti }
           __Pocit.Zvets_Prohozeni;
           __Pocit.Zvets_Prohozeni;
           __Pocit.Zvets_Prohozeni;

          if Jit_Ven then Break;{ aby se nemuselo dlouho cekat, nemusí bÿt }
        end;
  __Timer.Dodelej_Pohyb_Na_Pocet(1); { ve frontê __timer zûstane pouze prvek - menu }
end;