CD-X 1/cdx_01.iso/demodisc/tyrant/rendezes/rendezes.pas

Pascal/Delphi Source File | 1994-01-05 | 10.5 KB | 339 lines

program Rendezes;
{ Rendezôalgoritmusok összehasonlító elemzése }
uses
  crt;
const
  MaxExample = 2500;
  BarLength = 58;
  MS = 0.055;
type
  TExamples = array [1..MaxExample] of word;
  PNode = ^TNode;
  TNode = record
    Value : word;
    Left, Right, Parent : PNode;
    end;
var
  Examples, Original : TExamples;              { rendezendô példaadatok    }
  i, ConvertI : integer;
  TimeStamp : longint absolute $0040:$006C;    { 55 ms-os órajel, BIOS     }
  Started : longint;
  LongestTime, Duration, Ratio : real;
  SaveColor : byte;
  Tree : PNode;

{ SEGÉDRUTINOK *********************************************************** }
procedure Swap (i, j : word);                  { két elem kicserélése      }
var
  dummy : word;
begin
  dummy := Examples [i]; Examples [i] := Examples [j]; Examples [j] := dummy;
end; { Swap }

function Bar (Duration : real) : string;       { idôjelzô csík             }
var
  i, len : byte;
  dummy : string;
begin
  dummy := ''; len := round (Duration / Ratio);
  for i := 1 to len  do dummy := dummy + #219;
  for i := len + 1 to BarLength do dummy := dummy + '_';
  Bar := dummy;
end; { Bar }

procedure Results (Duration : real);
begin
  TextAttr := LightGreen + Blue shl 4; write (Bar (Duration));
  TextAttr := LightRed + Blue shl 4; writeln (Duration:7:3, ' s');
end; { Results }

{ FA-RUTINOK ************************************************************* }
procedure InOrder (Tree : PNode);
begin
  if Tree <> nil then
    begin
      InOrder (Tree^.Left);
      Examples [ConvertI] := Tree^.Value; inc (ConvertI);
      InOrder (Tree^.Right);
    end;
end; { InOrder }

{ RENDEZºALGORITMUSOK **************************************************** }
procedure BubbleSort;
{ Szokásos buborékos rendezés                                              }
var
  j : word;
begin
  for i := MaxExample downto 1 do
    for j := 1 to i do
      if Examples [j] > Examples [j + 1] then
        Swap (j, j + 1);
end; { BubbleSort }

procedure ImpBubbleSort;
{ Javított buborékos rendezés - csak addig cserélünk, amíg van mit         }
var
  Swapped : Boolean;
  start : word;
begin
  start := 1;
  repeat
    Swapped := false;
    for i := start to pred (MaxExample) do
      if Examples [i] > Examples [i + 1] then
        begin Swap (i, i + 1); Swapped := true; end;
    inc (start);
  until not Swapped;
end; { ImpBubbleSort }

procedure ShellSort;
{ B W Kernighan - P J Plauger: A programozás magasiskolája. Mûszaki 1982   }
{ GAP távolságú elemekbôl álló részsorozatokat rendezünk                   }
var
  gap, j, jg : integer;
begin
  gap := MaxExample div 2;
  while gap > 0 do
    begin
      for i := succ (gap) to MaxExample do
        begin
          j := i - gap;
          while j > 0 do
            begin
              jg := j + gap;
              if Examples [j] <= Examples [jg] then j := 0
              else Swap (j, jg);
              dec (j, gap);
            end;
        end;
      gap := gap div 2;
    end;
end; { ShellSort }

procedure JumpUp;
{ L Artiaga - L D Davis: Algoritmusok és FORTRAN programjaik. Mûszaki 1977 }
{ Hasonló a buborékoshoz, de csak az elôl rendezôdô elemek utáni, egyre
  csökkenô hosszúságú még rendezetlen részen dolgozunk; nem a szomszédosokat
  cseréljük, hanem a rendezetlen balszélét a jobbról jövô elemekkel        }
var
  i, j : word;
begin
  for i := 1 to pred (MaxExample) do
    for j := i + 1 to MaxExample do
      if Examples [i] > Examples [j] then Swap (i, j);
end; { JumpUp }

procedure InsertSort;
{ Szokásos beszúrásos rendezés                                             }
var
  i, j : word;
begin
  for i := 2 to MaxExample do
    begin
      j := i;
      while (j > 1) and (Examples [j - 1] > Examples [j]) do
        begin Swap (j, j - 1); dec (j); end;
    end;
end; { InsertSort }

procedure InsertSortB;
{ Jon Louis Bentley: Programming Pearls                                    }
{ Szokásos beszúrásos rendezés, Jon L Bentley optimalizálásával            }
var
  i, j, temp : word;
begin
  for i := 2 to MaxExample do
    begin
      j := i; temp := Examples [j];
      while (j > 1) and (Examples [j - 1] > temp) do
        begin Examples [j] := Examples [j - 1]; dec (j); end;
      Examples [j] := temp;
    end;
end; { InsertSortB }

procedure SortI;
{ L Artiaga - L D Davis: Algoritmusok és FORTRAN programjaik. Mûszaki 1977 }
{ Sorban mindenkit kicserélünk a minimumelemmel                            }
var
  i : word;

  function Minimum : word;
  var
    j, Min, Temp : word;
  begin
    Min := Examples [i];
    for j := 1 to MaxExample do
      if Min < Examples [j] then
        begin Temp := Min; Min := Examples [j]; Examples [j] := Temp; end;
    Minimum := Min;
  end; { Minimum of SortI }

begin
  for i := 1 to MaxExample do Examples [i] := Minimum;
end; { SortI }

procedure HeapSort;
{ Szokásos heapsort                                                        }

  procedure Stack (i, j : word);
  var
    k : word;
  begin
    k := 2 * i;
    if k <= j then
      begin
        if k < j then
          if Examples [k] < Examples [k + 1] then inc (k);
        if Examples [i] < Examples [k] then
          begin Swap (i, k); Stack (k, j); end;
      end;
  end; { Stack of HeapSort }

begin
  for i := (MaxExample div 2) downto 1 do Stack (i, maxExample);
  for i := MaxExample downto 2 do begin Swap (1, i); Stack (1, i-1); end;
end; { HeapSort }

procedure QuickSort (left, right : word);
{ Szokásos quicksort rendezés                                              }
var
  up, down, compare : word;
begin
  up := left; down := right; compare := Examples [(left + right) div 2];
  repeat
    while Examples [up] < compare do inc (up);
    while compare < Examples [down] do dec (down);
    if up <= down then
      begin Swap (up, down); inc (up); dec (down); end;
  until up > down;
  if left < down then QuickSort (left, down);
  if up < right then QuickSort (up, right);
end; { QuickSort }

procedure TreeSort;
{ Szokásos rendezés rendezôfával                                           }
var
  i : word;
  P, Node : PNode;
  HeapState : pointer;
begin
  Mark (HeapState); new (Tree);
  Tree^.Value := Examples [1]; Tree^.Left := nil; Tree^.Right := nil;
  for i := 2 to MaxExample do
    begin
      P := Tree;
      while ((P^.Left <> nil) and (Examples [i] <= P^.Value)) or
        ((P^.Right <> nil) and (Examples [i] > P^.Value)) do
        if Examples [i] <= P^.Value then P := P^.Left else P := P^.Right;
      new (Node); Node^.Parent := P; Node^.Value := Examples [i];
      Node^.Left := nil; Node^.Right := nil;
      if Examples [i] <= P^.Value then P^.Left := Node else P^.Right := Node;
    end;
  ConvertI := 1; InOrder (Tree);
  Release (HeapState);
end; { TreeSort }

procedure BinExch (left, right, digits : word);
{ Bináris csere rendezés                                                   }
var
  Mask, LeftMost, RightMost : word;
begin
  RightMost := right; LeftMost := left; Mask := $8000 shr (digits-1);
  while (right > left) and (digits <= 16) do
    begin
      while (Examples [left] and Mask = 0) and (right >= left) do inc (left);
      while (Examples [right] and Mask > 0) and (right >= left) do dec (right);
      if right > left then Swap (right, left)
      else
        begin
          BinExch (LeftMost, right, digits+1);
          BinExch (left, RightMost, digits+1);
        end;
    end;
end; { BinExch }

{ FºPROGRAM ************************************************************** }
begin
  { Képernyôfeliratok                                                      }
  SaveColor := TextAttr;
  TextAttr := Yellow + Blue shl 4; clrscr;
  TextAttr := White + Red shl 4;
  writeln (' Rendezôalgoritmusok összehasonlító elemzése                                    ');
  TextAttr := White + Blue shl 4;
  writeln (' ', MaxExample, ' db természetes szám sorbarendezésének idôszükséglete a baloldali');
  writeln (' oszlopban megadott algoritmusok felhasználásával'); writeln;
  { Véletlen példaadatok generálása                                        }
  Randomize;
  for i := 1 to MaxExample do
    Original [i] := Random (30000);
  { Különbözô rendezôalgoritmusok hívása                                   }
  TextAttr := Yellow + Blue shl 4; write (' Buborék   ');
  Move (Original, Examples, sizeof (Original));
  Started := TimeStamp;
  BubbleSort;
  Duration := (TimeStamp - Started) * MS;
  LongestTime := Duration;                     { a leglassabb rendezéshez  }
  Ratio := (LongestTime * 1.2) / BarLength;    { mérjük a többieket        }
  Results (Duration);

  TextAttr := Yellow + Blue shl 4; write (' JumpUp    ');
  Move (Original, Examples, sizeof (Original));
  Started := TimeStamp;
  JumpUp;
  Results ((TimeStamp - Started) * MS);

  TextAttr := Yellow + Blue shl 4; write (' SORT I    ');
  Move (Original, Examples, sizeof (Original));
  Started := TimeStamp;
  SortI;
  Results ((TimeStamp - Started) * MS);

  TextAttr := Yellow + Blue shl 4; write (' Beszúr 1  ');
  Move (Original, Examples, sizeof (Original));
  Started := TimeStamp;
  InsertSort;
  Results ((TimeStamp - Started) * MS);

  TextAttr := Yellow + Blue shl 4; write (' BuborJav  ');
  Move (Original, Examples, sizeof (Original));
  Started := TimeStamp;
  ImpBubbleSort;
  Results ((TimeStamp - Started) * MS);

  TextAttr := Yellow + Blue shl 4; write (' Beszúr 2  ');
  Move (Original, Examples, sizeof (Original));
  Started := TimeStamp;
  InsertSortB;
  Results ((TimeStamp - Started) * MS);

  TextAttr := Yellow + Blue shl 4; write (' Heap      ');
  Move (Original, Examples, sizeof (Original));
  Started := TimeStamp;
  HeapSort;
  Results ((TimeStamp - Started) * MS);

  TextAttr := Yellow + Blue shl 4; write (' Shell     ');
  Move (Original, Examples, sizeof (Original));
  Started := TimeStamp;
  ShellSort;
  Results ((TimeStamp - Started) * MS);

  TextAttr := Yellow + Blue shl 4; write (' Fa        ');
  Move (Original, Examples, sizeof (Original));
  Started := TimeStamp;
  TreeSort;
  Results ((TimeStamp - Started) * MS);

  TextAttr := Yellow + Blue shl 4; write (' Bincsere  ');
  Move (Original, Examples, sizeof (Original));
  Started := TimeStamp;
  BinExch (1, MaxExample, 1);
  Results ((TimeStamp - Started) * MS);

  TextAttr := Yellow + Blue shl 4; write (' Quick     ');
  Move (Original, Examples, sizeof (Original));
  Started := TimeStamp;
  QuickSort (1, MaxExample);
  Results ((TimeStamp - Started) * MS);
end.