home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / sibdemo3.zip / SAMPLES.DAT / SAMPLES / THREADS / SORTFORM.PAS next >
Pascal/Delphi Source File  |  1997-07-06  |  7KB  |  286 lines
  1. Unit SortForm;
  2.  
  3. Interface
  4.  
  5. Uses
  6.   Dos, Classes, Forms, ExtCtrls, Buttons, StdCtrls;
  7.  
  8. Type
  9.   TThreadSortForm = Class (TForm)
  10.     Panel1: TPanel;
  11.     Panel2: TPanel;
  12.     Panel3: TPanel;
  13.     BubbleSortBox: TPaintBox;
  14.     SelectionSortBox: TPaintBox;
  15.     QuickSortBox: TPaintBox;
  16.     Label4: TLabel;
  17.     Label5: TLabel;
  18.     Label6: TLabel;
  19.     StartBtn: TBitBtn;
  20.     Procedure SelectionSortBoxOnPaint (Sender: TObject; Const rec: TRect);
  21.     Procedure StartBtnOnClick(Sender:TObject);
  22.     Procedure ThreadSortFormOnCreate (Sender: TComponent);
  23.     Procedure QuickSortBoxOnPaint (Sender: TComponent; Const rec: TRect);
  24.     Procedure BubbleSortBoxOnPaint (Sender: TComponent; Const rec: TRect);
  25.   Private
  26.     {Insert private declarations here}
  27.     ThreadsRunning:LongInt;
  28.     procedure RandomizeArrays;
  29.     procedure PaintArray(Box: TPaintBox; const A: array of LongInt);
  30.     procedure ThreadDone(Sender: TObject);
  31.   Public
  32.     {Insert public declarations here}
  33.   End;
  34.  
  35. Var
  36.   ThreadSortForm: TThreadSortForm;
  37.  
  38. Type
  39.   PSortArray = ^TSortArray;
  40.   TSortArray = array[0..114] of LongInt;
  41.  
  42. var
  43.   ArraysRandom: Boolean;
  44.   BubbleSortArray, SelectionSortArray, QuickSortArray: TSortArray;
  45.  
  46. type
  47.   TSortThread = class(TThread)
  48.   private
  49.     FBox: TPaintBox;
  50.     FSortArray: PSortArray;
  51.     FSize: LongInt;
  52.     FA, FB, FI, FJ: LongInt;
  53.     procedure DoVisualSwap;
  54.   protected
  55.     procedure Execute; override;
  56.     procedure VisualSwap(A, B, I, J: LongInt);
  57.     procedure Sort(var A: array of LongInt); virtual; abstract;
  58.   public
  59.     constructor Create(Box: TPaintBox; var SortArray: array of LongInt);
  60.   end;
  61.  
  62.   TBubbleSort = class(TSortThread)
  63.   protected
  64.     procedure Sort(var A: array of LongInt); override;
  65.   end;
  66.  
  67.   TSelectionSort = class(TSortThread)
  68.   protected
  69.     procedure Sort(var A: array of LongInt); override;
  70.   end;
  71.  
  72.   TQuickSort = class(TSortThread)
  73.   protected
  74.     procedure Sort(var A: array of LongInt); override;
  75.   end;
  76.  
  77. procedure PaintLine(Box:TPaintBox; Canvas: TCanvas; I, Len: LongInt);
  78.  
  79. Implementation
  80.  
  81. procedure PaintLine(Box:TPaintBox; Canvas: TCanvas; I, Len: LongInt);
  82. var SaveColor:TColor;
  83. begin
  84.   Canvas.PolyLine([Point(0, Box.ClientHeight-I * 2 + 1), Point(Len, Box.ClientHeight-I * 2 + 1)]);
  85.   SaveColor:=Canvas.Pen.Color;
  86.   Canvas.Pen.Color:=Box.Color;
  87.   Canvas.PolyLine([Point(Len, Box.ClientHeight-I * 2 + 1), Point(Box.ClientWidth, Box.ClientHeight-I * 2 + 1)]);
  88.   Canvas.PolyLine([Point(0, Box.ClientHeight-I * 2), Point(Box.ClientWidth, Box.ClientHeight-I * 2)]);
  89.   Canvas.Pen.Color:=SaveColor;
  90. end;
  91.  
  92. //TSortThread
  93.  
  94. constructor TSortThread.Create(Box: TPaintBox; var SortArray: array of LongInt);
  95. begin
  96.   FBox := Box;
  97.   FSortArray := @SortArray;
  98.   FSize := High(SortArray) - Low(SortArray) + 1;
  99.   FreeOnTerminate := True;
  100.   inherited Create(False);
  101. end;
  102.  
  103. procedure TSortThread.DoVisualSwap;
  104. begin
  105.   with FBox do
  106.   begin
  107.     Canvas.Pen.Color := clBtnFace;
  108.     PaintLine(FBox,Canvas, FI, FA);
  109.     PaintLine(FBox,Canvas, FJ, FB);
  110.     Canvas.Pen.Color := clRed;
  111.     PaintLine(FBox,Canvas, FI, FB);
  112.     PaintLine(FBox,Canvas, FJ, FA);
  113.   end;
  114. end;
  115.  
  116. procedure TSortThread.VisualSwap(A, B, I, J: LongInt);
  117. begin
  118.   FA := A;
  119.   FB := B;
  120.   FI := I;
  121.   FJ := J;
  122.   Synchronize(DoVisualSwap);
  123. end;
  124.  
  125. procedure TSortThread.Execute;
  126. begin
  127.   Sort(Slice(FSortArray^,FSize));
  128. end;
  129.  
  130. //TBubbleSort
  131.  
  132. procedure TBubbleSort.Sort(var A: array of LongInt);
  133. var
  134.   I, J, T: Integer;
  135. begin
  136.   for I := High(A) downto Low(A) do
  137.   Begin
  138.     for J := Low(A) to High(A) - 1 do
  139.       if A[J] > A[J + 1] then
  140.       begin
  141.         VisualSwap(A[J], A[J + 1], J, J + 1);
  142.         T := A[J];
  143.         A[J] := A[J + 1];
  144.         A[J + 1] := T;
  145.         if Terminated then Exit;
  146.       end;
  147.   End;
  148. end;
  149.  
  150. //TSelectionSort
  151.  
  152. procedure TSelectionSort.Sort(var A: array of LongInt);
  153. var
  154.   I, J, T: Integer;
  155. begin
  156.   for I := Low(A) to High(A) - 1 do
  157.   begin
  158.     for J := High(A) downto I + 1 do
  159.       if A[I] > A[J] then
  160.       begin
  161.         VisualSwap(A[I], A[J], I, J);
  162.         T := A[I];
  163.         A[I] := A[J];
  164.         A[J] := T;
  165.         if Terminated then Exit;
  166.       end;
  167.   end;
  168. end;
  169.  
  170. //TQuickSort
  171.  
  172. procedure TQuickSort.Sort(var A: array of LongInt);
  173.  
  174.   procedure QuickSort(var A: array of LongInt; iLo, iHi: LongInt);
  175.   var
  176.     Lo, Hi, Mid, T: Integer;
  177.   begin
  178.     Lo := iLo;
  179.     Hi := iHi;
  180.     Mid := A[(Lo + Hi) div 2];
  181.     repeat
  182.       while A[Lo] < Mid do Inc(Lo);
  183.       while A[Hi] > Mid do Dec(Hi);
  184.       if Lo <= Hi then
  185.       begin
  186.         VisualSwap(A[Lo], A[Hi], Lo, Hi);
  187.         T := A[Lo];
  188.         A[Lo] := A[Hi];
  189.         A[Hi] := T;
  190.         Inc(Lo);
  191.         Dec(Hi);
  192.       end;
  193.     until Lo > Hi;
  194.     if Hi > iLo then QuickSort(A, iLo, Hi);
  195.     if Lo < iHi then QuickSort(A, Lo, iHi);
  196.     if Terminated then Exit;
  197.   end;
  198.  
  199. begin
  200.   QuickSort(A, Low(A), High(A));
  201. end;
  202.  
  203. //TThreadSortForm
  204.  
  205. Procedure TThreadSortForm.SelectionSortBoxOnPaint (Sender: TObject;
  206.                                                    Const rec: TRect);
  207. Begin
  208.    PaintArray(SelectionSortBox, SelectionSortArray);
  209. End;
  210.  
  211. Procedure TThreadSortForm.StartBtnOnClick (Sender: TObject);
  212. var bs:TBubbleSort;
  213.     qs:TQuickSort;
  214.     ss:TSelectionSort;
  215. Begin
  216.   RandomizeArrays;
  217.   ThreadsRunning := 3;
  218.   bs.Create(BubbleSortBox, BubbleSortArray);
  219.   bs.OnTerminate := ThreadDone;
  220.   Delay(10);
  221.   ss.Create(SelectionSortBox, SelectionSortArray);
  222.   ss.OnTerminate := ThreadDone;
  223.   Delay(10);
  224.   qs.Create(QuickSortBox, QuickSortArray);
  225.   qs.OnTerminate := ThreadDone;
  226.   Delay(10);
  227.   StartBtn.Enabled := False;
  228. End;
  229.  
  230. procedure TThreadSortForm.RandomizeArrays;
  231. var
  232.   I: LongInt;
  233. begin
  234.   if not ArraysRandom then
  235.   begin
  236.     Randomize;
  237.     for I := Low(BubbleSortArray) to High(BubbleSortArray) do
  238.       BubbleSortArray[I] := Random(170);
  239.     SelectionSortArray := BubbleSortArray;
  240.     QuickSortArray := BubbleSortArray;
  241.     ArraysRandom := True;
  242.     Repaint;         
  243.   end;
  244. end;
  245.  
  246. procedure TThreadSortForm.PaintArray(Box: TPaintBox; const A: array of LongInt);
  247. var
  248.   I: LongInt;
  249. begin
  250.   with Box do
  251.   begin
  252.     Canvas.Pen.Color := clRed;
  253.     for I := Low(A) to High(A) do PaintLine(Box, Canvas, I, A[I]);
  254.     for I := High(A) to Box.ClientHeight do PaintLine(Box, Canvas, I, 0);
  255.   end;
  256. end;
  257.  
  258. Procedure TThreadSortForm.ThreadSortFormOnCreate (Sender: TComponent);
  259. Begin
  260.   RandomizeArrays;
  261. End;
  262.  
  263. Procedure TThreadSortForm.QuickSortBoxOnPaint (Sender: TObject; Const rec: TRect);
  264. Begin
  265.    PaintArray(QuickSortBox, BubbleSortArray);
  266. End;
  267.  
  268. Procedure TThreadSortForm.BubbleSortBoxOnPaint (Sender: TObject; Const rec: TRect);
  269. Begin
  270.    PaintArray(BubbleSortBox, BubbleSortArray);
  271. End;
  272.  
  273. procedure TThreadSortForm.ThreadDone(Sender: TObject);
  274. begin
  275.   Dec(ThreadsRunning);
  276.   if ThreadsRunning = 0 then
  277.   begin
  278.     StartBtn.Enabled := True;
  279.     ArraysRandom := False;
  280.   end;
  281. end;
  282.  
  283. Begin
  284.   RegisterClasses ([TThreadSortForm, TPanel, TBitBtn, TPaintBox, TLabel]);
  285. End.
  286.