Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
Delphi multi threading demo by Bob Ainsbury and Ray Konopka from BorCon95 shipping with Delphi 2
unit SortThds;
interface
uses
Classes, Graphics, ExtCtrls;
type
{ TSortThread }
PSortArray = ^TSortArray;
TSortArray = array[0..MaxInt div SizeOf(Integer) - 1] of Integer;
TSortThread = class(TThread)
private
FBox: TPaintBox;
FSortArray: PSortArray;
FSize: Integer;
FA, FB, FI, FJ: Integer;
procedure DoVisualSwap;
protected
procedure Execute; override;
procedure VisualSwap(A, B, I, J: Integer);
procedure Sort(var A: array of Integer); virtual; abstract;
public
constructor Create(Box: TPaintBox; var SortArray: array of Integer);
end;
{ TBubbleSort }
TBubbleSort = class(TSortThread)
protected
procedure Sort(var A: array of Integer); override;
end;
{ TSelectionSort }
TSelectionSort = class(TSortThread)
protected
procedure Sort(var A: array of Integer); override;
end;
{ TQuickSort }
TQuickSort = class(TSortThread)
protected
procedure Sort(var A: array of Integer); override;
end;
procedure PaintLine(Canvas: TCanvas; I, Len: Integer);
implementation
procedure PaintLine(Canvas: TCanvas; I, Len: Integer);
begin
Canvas.PolyLine([Point(0, I * 2 + 1), Point(Len, I * 2 + 1)]);
end;
{ TSortThread }
constructor TSortThread.Create(Box: TPaintBox; var SortArray: array of Integer);
begin
inherited Create(False);
FBox := Box;
FSortArray := @SortArray;
FSize := High(SortArray) - Low(SortArray) + 1;
FreeOnTerminate := True;
end;
{ Since DoVisualSwap uses a VCL component (i.e., the TPaintBox) it should never
be called directly by this thread. DoVisualSwap should be called by passing
it to the Synchronize method which causes DoVisualSwap to be executed by the
main VCL thread, avoiding multi-thread conflicts. See VisualSwap for an
example of calling Synchronize. }
procedure TSortThread.DoVisualSwap;
begin
with FBox do
begin
Canvas.Pen.Color := clBtnFace;
PaintLine(Canvas, FI, FA);
PaintLine(Canvas, FJ, FB);
Canvas.Pen.Color := clRed;
PaintLine(Canvas, FI, FB);
PaintLine(Canvas, FJ, FA);
end;
end;
{ VisusalSwap is a wrapper on DoVisualSwap making it easier to use. The
parameters are copied to instance variables so they are accessable
by the main VCL thread when it executes DoVisualSwap }
procedure TSortThread.VisualSwap(A, B, I, J: Integer);
begin
FA := A;
FB := B;
FI := I;
FJ := J;
Synchronize(DoVisualSwap);
end;
{ The Execute method is called when the thread starts }
procedure TSortThread.Execute;
begin
Sort(Slice(FSortArray^, FSize));
end;
{ TBubbleSort }
procedure TBubbleSort.Sort(var A: array of Integer);
var
I, J, T: Integer;
begin
for I := High(A) downto Low(A) do
for J := Low(A) to High(A) - 1 do
if A[J] > A[J + 1] then
begin
VisualSwap(A[J], A[J + 1], J, J + 1);
T := A[J];
A[J] := A[J + 1];
A[J + 1] := T;
if Terminated then Exit;
end;
end;
{ TSelectionSort }
procedure TSelectionSort.Sort(var A: array of Integer);
var
I, J, T: Integer;
begin
for I := Low(A) to High(A) - 1 do
for J := High(A) downto I + 1 do
if A[I] > A[J] then
begin
VisualSwap(A[I], A[J], I, J);
T := A[I];
A[I] := A[J];
A[J] := T;
if Terminated then Exit;
end;
end;
{ TQuickSort }
procedure TQuickSort.Sort(var A: array of Integer);
procedure QuickSort(var A: array of Integer; iLo, iHi: Integer);
var
Lo, Hi, Mid, T: Integer;
begin
Lo := iLo;
Hi := iHi;
Mid := A[(Lo + Hi) div 2];
repeat
while A[Lo] < Mid do Inc(Lo);
while A[Hi] > Mid do Dec(Hi);
if Lo <= Hi then
begin
VisualSwap(A[Lo], A[Hi], Lo, Hi);
T := A[Lo];
A[Lo] := A[Hi];
A[Hi] := T;
Inc(Lo);
Dec(Hi);
end;
until Lo > Hi;
if Hi > iLo then QuickSort(A, iLo, Hi);
if Lo < iHi then QuickSort(A, Lo, iHi);
if Terminated then Exit;
end;
begin
QuickSort(A, Low(A), High(A));
end;
end.
program ThrdDemo;
uses
Forms,
ThSort in 'ThSort.pas' {ThreadSortForm},
SortThds in 'SortThds.pas';
{$R *.RES}
begin
Application.CreateForm(TThreadSortForm, ThreadSortForm);
Application.Run;
end.
object ThreadSortForm: TThreadSortForm
Left = 212
Top = 110
BorderStyle = bsDialog
Caption = 'Thread Sorting Demo'
ClientHeight = 295
ClientWidth = 562
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
Position = poScreenCenter
OnCreate = FormCreate
PixelsPerInch = 96
TextHeight = 13
object Bevel1: TBevel
Left = 8
Top = 24
Width = 177
Height = 233
end
object Bevel3: TBevel
Left = 376
Top = 24
Width = 177
Height = 233
end
object Bevel2: TBevel
Left = 192
Top = 24
Width = 177
Height = 233
end
object BubbleSortBox: TPaintBox
Left = 8
Top = 24
Width = 177
Height = 233
OnPaint = BubbleSortBoxPaint
end
object SelectionSortBox: TPaintBox
Left = 192
Top = 24
Width = 177
Height = 233
OnPaint = SelectionSortBoxPaint
end
object QuickSortBox: TPaintBox
Left = 376
Top = 24
Width = 177
Height = 233
OnPaint = QuickSortBoxPaint
end
object Label1: TLabel
Left = 8
Top = 8
Width = 55
Height = 13
Caption = 'Bubble Sort'
end
object Label2: TLabel
Left = 192
Top = 8
Width = 66
Height = 13
Caption = 'Selection Sort'
end
object Label3: TLabel
Left = 376
Top = 8
Width = 50
Height = 13
Caption = 'Quick Sort'
end
object StartBtn: TButton
Left = 480
Top = 264
Width = 75
Height = 25
Caption = 'Start Sorting'
TabOrder = 0
OnClick = StartBtnClick
end
end
unit ThSort;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls, StdCtrls;
type
TThreadSortForm = class(TForm)
StartBtn: TButton;
BubbleSortBox: TPaintBox;
SelectionSortBox: TPaintBox;
QuickSortBox: TPaintBox;
Label1: TLabel;
Bevel1: TBevel;
Bevel2: TBevel;
Bevel3: TBevel;
Label2: TLabel;
Label3: TLabel;
procedure BubbleSortBoxPaint(Sender: TObject);
procedure SelectionSortBoxPaint(Sender: TObject);
procedure QuickSortBoxPaint(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure StartBtnClick(Sender: TObject);
private
ThreadsRunning: Integer;
procedure RandomizeArrays;
procedure ThreadDone(Sender: TObject);
public
procedure PaintArray(Box: TPaintBox; const A: array of Integer);
end;
var
ThreadSortForm: TThreadSortForm;
implementation
uses SortThds;
{$R *.DFM}
type
PSortArray = ^TSortArray;
TSortArray = array[0..114] of Integer;
var
ArraysRandom: Boolean;
BubbleSortArray, SelectionSortArray, QuickSortArray: TSortArray;
{ TThreadSortForm }
procedure TThreadSortForm.PaintArray(Box: TPaintBox; const A: array of Integer);
var
I: Integer;
begin
with Box do
begin
Canvas.Pen.Color := clRed;
for I := Low(A) to High(A) do PaintLine(Canvas, I, A[I]);
end;
end;
procedure TThreadSortForm.BubbleSortBoxPaint(Sender: TObject);
begin
PaintArray(BubbleSortBox, BubbleSortArray);
end;
procedure TThreadSortForm.SelectionSortBoxPaint(Sender: TObject);
begin
PaintArray(SelectionSortBox, SelectionSortArray);
end;
procedure TThreadSortForm.QuickSortBoxPaint(Sender: TObject);
begin
PaintArray(QuickSortBox, QuickSortArray);
end;
procedure TThreadSortForm.FormCreate(Sender: TObject);
begin
RandomizeArrays;
end;
procedure TThreadSortForm.StartBtnClick(Sender: TObject);
begin
RandomizeArrays;
ThreadsRunning := 3;
with TBubbleSort.Create(BubbleSortBox, BubbleSortArray) do
OnTerminate := ThreadDone;
with TSelectionSort.Create(SelectionSortBox, SelectionSortArray) do
OnTerminate := ThreadDone;
with TQuickSort.Create(QuickSortBox, QuickSortArray) do
OnTerminate := ThreadDone;
StartBtn.Enabled := False;
end;
procedure TThreadSortForm.RandomizeArrays;
var
I: Integer;
begin
if not ArraysRandom then
begin
Randomize;
for I := Low(BubbleSortArray) to High(BubbleSortArray) do
BubbleSortArray[I] := Random(170);
SelectionSortArray := BubbleSortArray;
QuickSortArray := BubbleSortArray;
ArraysRandom := True;
Repaint;
end;
end;
procedure TThreadSortForm.ThreadDone(Sender: TObject);
begin
Dec(ThreadsRunning);
if ThreadsRunning = 0 then
begin
StartBtn.Enabled := True;
ArraysRandom := False;
end;
end;
end.
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.