home *** CD-ROM | disk | FTP | other *** search
/ Prima Shareware 3 / DuCom_Prima-Shareware-3_cd1.bin / PROGRAMO / PASCAL / HEJB / EXAM / SORTPOR.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1994-04-21  |  14.1 KB  |  568 lines
  1. { ********** Program Sort 3D se znázornêním porování ******** }
  2. { ****** program demonstruje pouziti jednotky hejbunit ****** }
  3. {* pri nazornem zobrazeni procedury QuickSort na obrazovce * }
  4.  
  5. uses Dos, Obraz3D, Unhejb, Unobdel, Unvokno, Unmenu, Untimer, Crt, Unfront, Unpisbmp;
  6.  
  7. const N : Integer = 60;
  8.       Poc_Pom  : Integer = 40;
  9.       Metoda : Integer = 0;
  10.       _Qsort    = 1;
  11.       _Qsortpar = 4;
  12.       _Merge    = 4;
  13.       _Buble    = 2;
  14.       _Vyber    = 3;
  15.  
  16.       _Nahodna   = 1;
  17.       _Vzestupna = 2;
  18.       _Sestupna  = 3;
  19.  
  20.       _Posl : Byte = 0;
  21.  
  22.       _Bar_Obyc = 5;
  23.       _Bar_Proh = 14;
  24.       _Bar_Por  = 15;
  25.  
  26.       _Delay_Por = 10;
  27.  
  28.       Jit_Ven   : Boolean = False;
  29.  
  30. type Typ_Prvek = object(Typ_Integer)
  31.                   Klic : Integer;
  32.                   procedure Dodel_Anim_Prohod(var S_Kym : Typ_Prvek);
  33.                 end;
  34.      Typdat   = array[0..100]of Typ_Prvek;
  35. var
  36.      Data : Typdat;
  37.  
  38.  
  39. procedure Cisla_Prvku(Zob : Byte);
  40. const Pomzob : Byte = 0;
  41. var  S    : string[5];
  42.      K    : Integer;
  43.      Pom  : _Bod3D;
  44. begin
  45.   if Pomzob <> Zob then
  46.   for K := 1 to N do
  47.     begin
  48.       Str(K, S);
  49.       Pom := Hezky_Rozmistit(K)^;
  50.       case Zob of
  51.         2 : Obrazovka.Smaz_Retez(Pom.X{&&-Pom.Z}+2, Pom.Y{&&+Pom.Z}, Pom.Z+1, 2, S, True);
  52.         1 : Obrazovka.Pis_Retez(Pom.X{&&-Pom.Z}+2, Pom.Y{&&+Pom.Z}, Pom.Z+1, 2, S, True)
  53.            { zobrazeni prvku v obrazovce }
  54.       end;
  55.     end;
  56.   Pomzob := Zob;
  57. end;
  58.  
  59. const Cesta : array[1..4]of Typ_Instrukce = (Vm0, Jmpa, 0, Endc) ;
  60. const Menudef : string =
  61. '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}
  62.                                   { rozmêr 30x11, 6 prvkû, zaçátek na çtvrtém }
  63. '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,
  64.                                             { zvÿraznênÿ text téæ 96, poçáteçní hodnota 40, minimum 1 a maximum 400 }
  65. 'method~ v 31 15 9 15 112 10 20 7 5 1'+
  66.   'quicksort~o'+
  67.   'bublesort~o'+
  68.   'maxsort~o'+
  69.   'mergesort~o'+
  70.   'paralelni qsort~o';
  71.   Menudef2 : string =
  72. 'Element numbers~v 21 16 5 15 112 10 30 4 2 2'+
  73.   'on~o'+
  74.   'off~o'+
  75. 'sequence~v 36 16 3 15 112 10 15 5 3 1'+
  76.   '''random''~o'+
  77.   'increasing~o'+
  78.   'decreasing~o'+
  79. 'run~v 36 18 1 15 112 10 15 4 2 2'+
  80.   'start~o'+
  81.   'stop~o'+
  82. 'end~o';
  83. type
  84.   Typ_Moje_Menu = object(Typ_Menu_Vyber)
  85.                     procedure Vm0;virtual;
  86.                   end;
  87.  
  88. procedure Typ_Moje_Menu.Vm0;
  89. var C : Word;
  90. begin
  91.   if KeyPressed then
  92.     begin
  93.       C := Byte(ReadKey);
  94.       if C = 0 then  C := 256* Byte(ReadKey);
  95.       Zpracuj_Key(C);
  96.       if (Sub_Menu^[5]^.Out_Hodnota = 2) or
  97.          (Out_Hodnota = 6)
  98.          then Jit_Ven := True
  99.          else Jit_Ven := False;
  100.       if (Sub_Menu^[3]^.Potvrzeno)
  101.          then Cisla_Prvku(Sub_Menu^[3]^.Out_Hodnota);
  102.       if Metoda <> Sub_Menu^[2]^.Out_Hodnota then
  103.         begin
  104.           Metoda := Sub_Menu^[2]^.Out_Hodnota;
  105.           Jit_Ven := True;
  106.         end;
  107.       if Sub_Menu^[1]^.Out_Hodnota <> Poc_Pom then
  108.         begin
  109.           Poc_Pom := Sub_Menu^[1]^.Out_Hodnota;
  110.           Unfront.set_Pomalost(Poc_Pom);
  111.         end;
  112.       if Sub_Menu^[5]^.Out_Hodnota = 2 then
  113.         if Sub_Menu^[4]^.Potvrzeno then
  114.           begin
  115.  
  116.             _Posl := Sub_Menu^[4]^.Out_Hodnota;
  117.             for C := 1 to N do
  118.               begin
  119.                 case _Posl of
  120.                     _Nahodna : Data[C].Klic := Random(1000);
  121.                     _Vzestupna : Data[C].Klic := C;
  122.                     _Sestupna : Data[C].Klic := N-C;
  123.                   end;
  124.                 Data[C].Vytvor(Data[C].Klic, 3,_Bar_Obyc,_Bar_Obyc, Strom_Ram);
  125.               end;
  126.             Sub_Menu^[4]^.__Stav_Menu := Sub_Menu^[4]^.__Stav_Menu and ($Ff xor __Potvrzena_Hodnota)
  127.           end;
  128.  
  129.  
  130.     end;
  131. end;
  132.  
  133.  
  134.  
  135. type Typ_Pocitani = object(Typ_Vokynko)
  136.                       Porovnani, Prohozeni : Integer;
  137.                       constructor Init;
  138.                       procedure Nuluj;
  139.                       procedure Zvets_Porovnani;
  140.                       procedure Zvets_Prohozeni;
  141.                       procedure Zapis;
  142.                     end;
  143.  
  144. constructor Typ_Pocitani.Init;
  145. begin
  146.   Typ_Vokynko.Init;
  147.   Presun(20,25, 0);
  148.   Porovnani := 0;
  149.   Prohozeni := 0;
  150.   Vytvor_Ram(25,4,4,4,Strom_Ram);
  151.   GotoXY(1,1);
  152.   set_Psaci_Barva(14);
  153.   Pis('Poçet porovnání :');
  154.   WriteLn;
  155.   Pis('Poçet p⌐i⌐azení :');
  156.   Zobraz;
  157. end;
  158.  
  159. procedure Typ_Pocitani.Nuluj;
  160. begin
  161.   Porovnani := 0;
  162.   Prohozeni := 0;
  163.   Zapis;
  164. end;
  165.  
  166. procedure Typ_Pocitani.Zapis;
  167. begin
  168.   GotoXY(20,1);Pisint(Porovnani, 4);
  169.   GotoXY(20,2);Pisint(Prohozeni, 4);
  170. end;
  171.  
  172. procedure Typ_Pocitani.Zvets_Porovnani;
  173. begin
  174.   Inc(Porovnani);
  175.   Zapis;
  176. end;
  177.  
  178. procedure Typ_Pocitani.Zvets_Prohozeni;
  179. begin
  180.   Inc(Prohozeni);
  181.   Zapis;
  182. end;
  183.  
  184. var __Pocit : Typ_Pocitani;
  185.  
  186. function Mensi( var Jedno, Druhe : Typ_Prvek ) : Boolean;
  187. var B1, B2 : Byte;
  188.     P1, P2 :_Bod3D;
  189.     F      : Typ_Hejb_Fronta;
  190.     Vysl : Boolean;
  191.  
  192. begin
  193.   B1 := Jedno.Barva;
  194.   B2 := Druhe.Barva;
  195.   P1 := Jedno.Poloha;
  196.   P2 := Druhe.Poloha;
  197.  
  198.   Jedno.set_Barva(_Bar_Por);
  199.   Druhe.set_Barva(_Bar_Por);
  200.  
  201.   if @Jedno <> @Druhe then
  202.     begin
  203.       F.Init;
  204. {      DRUHE.ANIM_POSUN_BOD(XYZ_BOD(JEDNO.POLOHA.X+6,JEDNO.POLOHA.Y,JEDNO.POLOHA.Z)^,F);
  205. }      Jedno.Anim_Posun_Bod(Xyz_Bod(45-5+2,0+5,5)^);
  206.       F.Zarad_Prvek(Jedno);
  207.       Druhe.Anim_Posun_Bod(Xyz_Bod(51-5+2,0+5,5)^);
  208.       F.Zarad_Prvek(Druhe);
  209.  
  210.       F.set_Pomalost(Poc_Pom div 3);
  211.       F.Dodelej_Pohyb;
  212.  
  213.       if Jedno.Klic < Druhe.Klic
  214.         then Vysl := True
  215.         else Vysl := False;
  216.  
  217.       Mensi := Vysl;
  218.  
  219.       if Vysl
  220.         then Obrazovka.Pis_Retez( 50-5+2, +1+5, 5, _Bar_Por,'<',True)
  221.         else if Jedno.Klic = Druhe.Klic
  222.                then Obrazovka.Pis_Retez( 50-5+2, +1+5, 5, _Bar_Por,'=',True)
  223.                else Obrazovka.Pis_Retez( 50-5+2, +1+5, 5, _Bar_Por,'>',True);
  224.  
  225.       __Pocit.Zvets_Porovnani;
  226.       Delay(_Delay_Por*Poc_Pom);
  227.       if Vysl
  228.         then Obrazovka.Smaz_Retez( 50-5+2, +1+5, 5, _Bar_Por,'<',True)
  229.         else if Jedno.Klic = Druhe.Klic
  230.                then Obrazovka.Smaz_Retez( 50-5+2, +1+5, 5, _Bar_Por,'=',True)
  231.                else Obrazovka.Smaz_Retez( 50-5+2, +1+5, 5, _Bar_Por,'>',True);
  232.  
  233.       Jedno.Anim_Posun_Bod(P1);
  234.       F.Zarad_Prvek(Jedno);
  235.       Druhe.Anim_Posun_Bod(P2);
  236.       F.Zarad_Prvek(Druhe);
  237.       F.Dodelej_Pohyb;
  238.     end
  239.   else Mensi := False;
  240.  
  241.   Jedno.set_Barva(B1);
  242.   Druhe.set_Barva(B2);
  243.  
  244. end;
  245.  
  246. function Vetsi( var Jedno, Druhe : Typ_Prvek ) : Boolean;
  247. begin
  248.   Vetsi := Mensi(Jedno, Druhe);
  249.   if Jedno.Klic = Druhe.Klic then Vetsi := False;
  250. end;
  251.  
  252. function Rovno( var Jedno, Druhe : Typ_Prvek ) : Boolean;
  253.  
  254. begin
  255.   Rovno := Mensi(Jedno, Druhe);
  256.   Rovno := Jedno.Klic = Druhe.Klic;
  257. end;
  258.  
  259. procedure Typ_Prvek.Dodel_Anim_Prohod;
  260. var Pom : Typ_Prvek;
  261.     B1,B2 : Byte;
  262. begin
  263.   B1 := Barva;
  264.   B2 := S_Kym.Barva;
  265.   set_Barva(_Bar_Proh);
  266.   S_Kym.set_Barva(_Bar_Proh);
  267.  
  268.   Typ_Obdelnik.Dodel_Anim_Prohod(S_Kym);
  269.   set_Barva(B1);
  270.   S_Kym.set_Barva(B2);
  271.  
  272.   Pom.Init;
  273.   Pom   := Self;
  274.   Self  := S_Kym;
  275.   S_Kym := Pom;
  276.   __Pocit.Zvets_Prohozeni;
  277.   __Pocit.Zvets_Prohozeni;
  278.   __Pocit.Zvets_Prohozeni;
  279. end;
  280.  
  281.  
  282.  
  283. var  __Menu  : Typ_Moje_Menu;
  284.      K    : Integer;
  285.      S    : string;
  286.  
  287. procedure Maxsort(var Data : Typdat);
  288. var I, J : Integer;
  289.     Pom  : Typ_Prvek;
  290. begin
  291.   Pom.Init;
  292.   for I := 1 to N-1 do
  293.     for J := I to N-1 do
  294.       if Vetsi(Data[I], Data[J]) then
  295.         begin
  296.           Data[I].Dodel_Anim_Prohod(Data[J]);
  297.           if Jit_Ven then Exit;{ aby se nemuselo dlouho cekat, nemusí bÿt }
  298.         end;
  299. end;
  300.  
  301. procedure Bublesort(var Data : Typdat);
  302. var I, J : Integer;
  303.     Pom  : Typ_Prvek;
  304. begin
  305.   Pom.Init;
  306.   for I := 1 to N-1 do
  307.     for J := N-1 downto I do
  308.       if Vetsi(Data[J], Data[J+1]) then
  309.         begin
  310.           Data[J+1].Dodel_Anim_Prohod(Data[J]);
  311.           if Jit_Ven then Exit;{ aby se nemuselo dlouho cekat, nemusí bÿt }
  312.         end;
  313. end;
  314.  
  315.  
  316. procedure Quicksort1(var Data : Typdat);
  317. { demonstruje klasickÿ qsort }
  318. var Pombar : Byte;
  319.  
  320. procedure Castecne_Usporadani(K, M : Integer);
  321.  
  322.  var I, J, Fn : Integer;
  323.  
  324.  begin
  325.   Inc(Pombar);
  326.  
  327.   I := K;
  328.   J := M;
  329.  
  330.   Data[(K + M) div 2].set_Barva(Pombar);
  331.  
  332.   if ((K+M) div 2 > N) or ((K+M) div 2 < 1) then
  333.     M := M;
  334.  
  335.   repeat
  336.     if Jit_Ven then Exit;
  337.  
  338.     while Mensi(Data[I], Data[(K + M) div 2]) do I := I+1;
  339. {    DATA[I].SET_BARVA(POMBAR);
  340.  }
  341.     while Vetsi(Data[J], Data[(K + M) div 2]) do J := J-1;
  342. {    DATA[J].SET_BARVA(POMBAR);
  343.  }
  344.     if I <= J then
  345.       begin
  346.         if not Rovno(Data[J], Data[I])
  347.           then Data[I].Dodel_Anim_Prohod(Data[J]);
  348. {        DATA[I].SET_BARVA(_BAR_OBYC);
  349.         DATA[J].SET_BARVA(_BAR_OBYC);
  350.  }
  351.         I := I+1;
  352.         J := J-1;
  353.       end;
  354. {    DATA[I].SET_BARVA(_BAR_OBYC);
  355.     DATA[J].SET_BARVA(_BAR_OBYC);
  356.  }
  357.   until I>J;
  358.  
  359.   if K < J then Castecne_Usporadani(K, J);
  360.   if I < M then Castecne_Usporadani(I, M);
  361.   Dec(Pombar);
  362.  end;  {pomocne procedury Castecne_usporadani}
  363.  
  364. begin
  365.   Pombar := 5;
  366.   Castecne_Usporadani(1,N);
  367. end;
  368.  
  369. procedure Mergesort(var Data : Typdat);
  370. var J : Integer;
  371.  
  372. procedure Vnitrek;
  373. var Pompole : array[0..9]of Integer;
  374.     Pomdata : Typdat;
  375.     Pomind  : array[0..9,1..30]of Integer;
  376.     I, J, Pom, Pomid : Integer;
  377.  
  378.  
  379.   procedure Trida(var Prvek : Typ_Prvek; Ktera : Integer);
  380.   begin
  381.     Prvek.Dodel_Anim_Posun_Bod(Xyz_Bod(Ktera*5+Pompole[Ktera], Obrazovka.Y_Obr -5- (Pompole[Ktera]*2+1), -Pompole[Ktera])^);
  382.     Inc(Pompole[Ktera]);
  383.     Pomind[Ktera, Pompole[Ktera]] := J;
  384.     Pomind[Ktera, Pompole[Ktera]+1] := 0;
  385.     __Pocit.Zvets_Prohozeni;
  386.   end;
  387.  
  388.   function Moc(Co, Nakolik : Integer):Integer;
  389.   var I, A : Integer;
  390.   begin
  391.     A := 1;
  392.     for I := 1 to Nakolik do A := A*Co;
  393.     Moc := A;
  394.   end;
  395.  
  396. begin
  397.   for J := 1 to N do Pomdata[J].Init;
  398.   for I := 0 to 2 do
  399.     begin
  400.       for J := 0 to 9 do
  401.         begin
  402.           Pompole[J] := 0;
  403.           Pomind[J,1]:=0;
  404.         end;
  405.  
  406.       for J := 1 to N do
  407.         begin { rozmístêní objektû do t⌐íd podle I-té çíslice }
  408.           Trida(Data[J], (Data[J].Klic div Moc(10,I)) mod 10);
  409.           if Jit_Ven then Exit;{ aby se nemuselo dlouho cekat, nemusí bÿt }
  410.         end;
  411.  
  412.       Pomid := 1;
  413.       for J := 0 to 9 do
  414.         begin
  415.           Pom := 1;
  416.           while Pomind[J, Pom] <> 0 do
  417.             begin
  418.               Pomdata[Pomid] := Data[Pomind[J, Pom]];
  419.               Inc(Pomid);
  420.               Inc(Pom)
  421.             end;
  422.         end;
  423.       for J := 1 to N do Data[J] := Pomdata[J];
  424.       for J := 1 to N do
  425.         begin
  426.           Data[J].Dodel_Anim_Posun_Bod(Hezky_Rozmistit(J)^);
  427.           if Jit_Ven then Exit;{ aby se nemuselo dlouho cekat, nemusí bÿt }
  428.           __Pocit.Zvets_Prohozeni;
  429.         end;
  430.     end;
  431. end;
  432.  
  433. begin
  434.   Vnitrek;
  435.   for J := 1 to N do Data[J].Presun_Bod(Hezky_Rozmistit(J)^);
  436. end;
  437.  
  438. (*procedure Quicksort2(var Data : Typdat);
  439. { demonstruje moænost paralelního zpracování p⌐i qsotu }
  440. var Pom : Typ_Prvek;
  441.     I   : Integer;
  442. procedure Castecne_Usporadani(K,M:Integer);
  443.  
  444.  var I, J, Y, Fn : Integer;
  445.  
  446.  begin
  447.   I := K;
  448.   J := M;
  449.   Y := Data[(K + M) div 2].Klic;
  450.   repeat
  451.     while Data[I].Klic < Y do I := I+1;
  452.     while Data[J].Klic > Y do J := J-1;
  453.     if I <= J then
  454.      begin
  455.        if Data[J].Klic <> Data[I].Klic  then
  456.          begin
  457.            repeat
  458.            until ((Data[I].Stav and __Pohyb) = 0) and
  459.                  ((Data[J].Stav and __Pohyb) = 0);
  460.  
  461.            Data[I].Anim_Prohod(Data[J], __Timer);
  462.             { prohozeni na obrazovce }
  463.  
  464.  
  465.            Pom     := Data[I];
  466.            Data[I] := Data[J];
  467.            Data[J] := Pom;
  468.             { prohozeni v pameti }
  469.            if Metoda <> _Qsortpar then Exit;{ aby se nemuselo dlouho cekat, nemusí bÿt }
  470.          end;
  471.        I := I+1;
  472.        J := J-1;
  473.      end;
  474.   until I>J;
  475.  
  476.   if K < J then Castecne_Usporadani(K, J);
  477.   if I < M then Castecne_Usporadani(I, M);
  478.  
  479.  end;  {pomocne procedury Castecne_usporadani}
  480.  
  481. begin
  482.    Pom.Init(__Nula_3D);
  483.    Castecne_Usporadani(1,N);
  484.    __Timer.Off;
  485.    for I:=1 to N do
  486.      Data[I].Dodelej_Pohyb(__Timer);
  487.    __Timer.On;
  488. end;
  489. *)
  490.  
  491.  
  492. var P : Pchar;
  493.     I, J : Word;
  494.  
  495. begin
  496.   J := Length(Menudef)+Length(Menudef2);
  497.   GetMem(P, J+1);
  498.   for I := 0 to Length(Menudef) do
  499.     P^[I] := Menudef[I+1];
  500.   for I := Length(Menudef)  to J-1 do
  501.     P^[I] := Menudef2[I-Length(Menudef)+1];
  502.  
  503.   Randomize;
  504.  
  505.   Obrazovka.Nastav_mod(3+__Sada_3D_8X8);   { nastavi hezky vypadajici sadu }
  506.   Obrazovka.ClrScr;
  507.   I := 0;
  508.   Unfront.set_Pomalost(Poc_Pom);
  509.   __Menu.Init(P,I);
  510.   __Menu.Hejbej(Cesta);
  511.   __Timer.Zarad_Prvek(__Menu);
  512.   __Menu.GotoXY(1,7);
  513.   __Menu.set_Psaci_Barva(LightRed);
  514.   __Menu.Pis('   Demo k jednotce Unhejb');
  515.   __Menu.WriteLn;
  516.   __Menu.Pis('   Vyrobeno ve Praze 1993');
  517.   __Menu.WriteLn;
  518.   __Menu.Pis('PrScr uloæí obrazovku do BMP');
  519.  
  520.   set_Pomalost(Poc_Pom);
  521.  
  522.   __Pocit.Init;
  523.  
  524.   __Timer.On;
  525.   __Menu.Otevri;
  526.  
  527.   for K := 1 to N do
  528.     begin
  529.       Data[K].Init;
  530.       Data[K].Presun_Bod(Hezky_Rozmistit(K)^);
  531.        { inicialisace data[k]  - nutná ! }
  532.       Data[K].Klic := {1000-k}Random(1000);
  533.        { prirazeni klice }
  534.       Data[K].Vytvor(Data[K].Klic, 3,_Bar_Obyc,_Bar_Obyc, Strom_Ram);
  535.            { vytvoreni tvaru tak, aby to hezky vypadalo }
  536.       Data[K].Zobraz;
  537.     end;
  538.  
  539.   set_Par_Pisbmp('sort',nil);
  540.   On_Pisbmp;
  541.   repeat
  542. {    __menu.krok;}
  543.     if __Menu.Sub_Menu^[5]^.Out_Hodnota = 1 then
  544.       begin
  545.         __Pocit.Nuluj;
  546.         case Metoda of
  547.           _Qsort    : Quicksort1(Data);
  548. {          _Qsortpar : Quicksort2(Data);}
  549.           _Buble    : Bublesort(Data);
  550.           _Vyber    : Maxsort(Data);
  551.           _Merge    : Mergesort(Data);
  552.         end;
  553.         Jit_Ven := False;
  554.         __Menu.Sub_Menu^[5]^.Pom_set(2);
  555.         __Menu.Prekresli;
  556.       end;
  557.   until (__Menu.Out_Hodnota = 6);
  558.   Off_Pisbmp;
  559.   __Timer.Off;
  560.   __Menu.Zrus;
  561.   __Pocit.Zrus;
  562.   for K := 1 to N do Data[K].Zrus;
  563.    { vyruseni pameti, kterou zabiraji objekty a zhasnuti }
  564.  
  565.   Konec;    { vyruseni pameti, kterou zabirá obrazovka }
  566. end.
  567.  
  568.