mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-11-04 03:39:48 +01:00
559 lines
14 KiB
ObjectPascal
559 lines
14 KiB
ObjectPascal
{
|
|
/***************************************************************************
|
|
synchronize - example
|
|
---------------------
|
|
|
|
Just a simple example to show & verify functionality
|
|
of the lazarus TThread.Synchronize / TProgressBar classes.
|
|
|
|
Initial Revision : Sun Aug 15 1999
|
|
|
|
by Stefan Hille <stoppok@osibisa.ms.sub.org>
|
|
and Micha Nelissen
|
|
|
|
***************************************************************************/
|
|
|
|
***************************************************************************
|
|
* *
|
|
* This source is free software; you can redistribute it and/or modify *
|
|
* it under the terms of the GNU General Public License as published by *
|
|
* the Free Software Foundation; either version 2 of the License, or *
|
|
* (at your option) any later version. *
|
|
* *
|
|
* This code is distributed in the hope that it will be useful, but *
|
|
* WITHOUT ANY WARRANTY; without even the implied warranty of *
|
|
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *
|
|
* General Public License for more details. *
|
|
* *
|
|
* A copy of the GNU General Public License is available on the World *
|
|
* Wide Web at <http://www.gnu.org/copyleft/gpl.html>. You can also *
|
|
* obtain it by writing to the Free Software Foundation, *
|
|
* Inc., 51 Franklin Street - Fifth Floor, Boston, MA 02110-1335, USA. *
|
|
* *
|
|
***************************************************************************
|
|
}
|
|
program Synchronize;
|
|
|
|
{$mode objfpc}{$H+}
|
|
|
|
{ threading directive not needed anymore for 1.9.8+ }
|
|
{ $threading on}
|
|
|
|
uses
|
|
{$ifdef UNIX}
|
|
CThreads,
|
|
{$endif}
|
|
Interfaces, Classes, StdCtrls, Forms, Buttons, Menus, ComCtrls,
|
|
SysUtils, Extctrls;
|
|
|
|
|
|
type
|
|
|
|
TAThread = class(TThread)
|
|
protected
|
|
FTargetListBox: TListBox;
|
|
FTargetProgress: TProgressBar;
|
|
FTestStrings: TStrings;
|
|
procedure ExecDone;
|
|
procedure ShowStrings;
|
|
public
|
|
constructor Create(CreateSuspended: boolean);
|
|
destructor Destroy; override;
|
|
end;
|
|
|
|
TThread1 = class(TAThread)
|
|
public
|
|
constructor Create;
|
|
procedure Execute; override;
|
|
end;
|
|
|
|
TThread2 = class(TAThread)
|
|
public
|
|
constructor Create;
|
|
procedure Execute; override;
|
|
end;
|
|
|
|
TForm1 = class(TForm)
|
|
public
|
|
Progre1: TProgressBar;
|
|
Progre2: TProgressBar;
|
|
Progre3: TProgressBar;
|
|
Listbox1: TListBox;
|
|
Listbox2: TListBox;
|
|
Thread1: TThread1;
|
|
Thread2: TThread2;
|
|
ThreadList: TList;
|
|
Button1: TButton;
|
|
Button2: TButton;
|
|
Button3: TButton;
|
|
Button4: TButton;
|
|
Button5: TButton;
|
|
Button6: TButton;
|
|
Button7: TButton;
|
|
Button8: TButton;
|
|
Button9: TButton;
|
|
Button10: TButton;
|
|
mnuFile: TMainMenu;
|
|
itmFileQuit: TMenuItem;
|
|
constructor Create(AOwner: TComponent); override;
|
|
destructor Destroy; override;
|
|
procedure LoadMainMenu;
|
|
procedure mnuQuitClicked(Sender : TObject);
|
|
protected
|
|
procedure Button1CLick(Sender : TObject);
|
|
procedure Button2CLick(Sender : TObject);
|
|
procedure Button3CLick(Sender : TObject);
|
|
procedure Button4CLick(Sender : TObject);
|
|
procedure Button5CLick(Sender : TObject);
|
|
procedure Button6CLick(Sender : TObject);
|
|
procedure Button7CLick(Sender : TObject);
|
|
procedure Button8CLick(Sender : TObject);
|
|
procedure Button9CLick(Sender : TObject);
|
|
procedure Button10CLick(Sender : TObject);
|
|
function CloseQuery: boolean; override;
|
|
end;
|
|
|
|
threadvar
|
|
threadvartest: integer;
|
|
|
|
var
|
|
Form1 : TForm1;
|
|
TotalCount: integer;
|
|
{ GlobalData is an example of what you should NOT do :)
|
|
Access from multiple threads to same variable unprotected }
|
|
GlobalData: integer;
|
|
|
|
constructor TAThread.Create(CreateSuspended: boolean);
|
|
begin
|
|
inherited;
|
|
|
|
FTestStrings := TStringList.Create;
|
|
end;
|
|
|
|
destructor TAThread.Destroy;
|
|
begin
|
|
inherited;
|
|
|
|
FTestStrings.Free;
|
|
end;
|
|
|
|
procedure TAThread.ExecDone;
|
|
var
|
|
lPos: integer;
|
|
begin
|
|
Form1.ThreadList.Remove(Self);
|
|
FTargetListBox.Items.Insert(0, 'Thread terminated');
|
|
if Form1.ThreadList.Count = 0 then
|
|
begin
|
|
lPos := Pos('[', Form1.Caption);
|
|
if lPos > 0 then
|
|
Form1.Caption := Copy(Form1.Caption, 1, lPos - 1) + '[done, ready to exit]';
|
|
end;
|
|
end;
|
|
|
|
procedure TAThread.ShowStrings;
|
|
var
|
|
i: integer;
|
|
begin
|
|
FTargetListBox.Items.BeginUpdate;
|
|
for i := 0 to FTestStrings.Count - 1 do
|
|
begin
|
|
FTargetListBox.Items.Insert(0, FTestStrings.Strings[i]);
|
|
while FTargetListBox.Items.Count > 30 do
|
|
FTargetListBox.Items.Delete(FTargetListBox.Items.Count-1);
|
|
end;
|
|
FTargetListBox.Items.EndUpdate;
|
|
FTestStrings.Clear;
|
|
if FTargetProgress.Position = FTargetProgress.Max then
|
|
FTargetProgress.Position := FTargetProgress.Min;
|
|
FTargetProgress.StepIt;
|
|
end;
|
|
|
|
constructor TThread1.Create;
|
|
begin
|
|
FTargetListBox := Form1.Listbox1;
|
|
FTargetProgress := Form1.Progre1;
|
|
FreeOnTerminate := true;
|
|
inherited Create(false);
|
|
end;
|
|
|
|
function DoCalculation: integer;
|
|
var
|
|
i, k: integer;
|
|
j: array[0..511] of integer;
|
|
begin
|
|
for i := 0 to 100000 do
|
|
begin
|
|
j[i mod $1ff] := i * i;
|
|
k := j[(i + 3) and $1ff] div (i+1);
|
|
j[(i + 5) and $1ff] := k - 3;
|
|
end;
|
|
result := j[5];
|
|
end;
|
|
|
|
procedure TThread1.Execute;
|
|
var
|
|
i: integer;
|
|
begin
|
|
threadvartest := 10;
|
|
FTestStrings.Add('Threadvar is @'+IntToStr(ptrint(@threadvartest)));
|
|
for i := 0 to TotalCount - 1 do
|
|
begin
|
|
GlobalData += 3;
|
|
DoCalculation;
|
|
FTestStrings.Add('Information: '+IntToStr(GlobalData-3)+' '+IntToStr(threadvartest));
|
|
GlobalData -= 3;
|
|
DoCalculation;
|
|
Synchronize(@ShowStrings);
|
|
threadvartest := 10;
|
|
if Terminated then break;
|
|
end;
|
|
Synchronize(@ExecDone);
|
|
end;
|
|
|
|
constructor TThread2.Create;
|
|
begin
|
|
FTargetListBox := Form1.Listbox2;
|
|
FTargetProgress := Form1.Progre2;
|
|
FreeOnTerminate := true;
|
|
inherited Create(false);
|
|
end;
|
|
|
|
procedure TThread2.Execute;
|
|
var
|
|
i: integer;
|
|
begin
|
|
threadvartest := 15;
|
|
FTestStrings.Add('Threadvar is @'+IntToStr(ptrint(@threadvartest)));
|
|
for i := 0 to TotalCount - 1 do
|
|
begin
|
|
GlobalData -= 3;
|
|
DoCalculation;
|
|
FTestStrings.Add('Information: '+IntToStr(GlobalData+3)+' '+IntToStr(threadvartest));
|
|
threadvartest := 15;
|
|
GlobalData += 3;
|
|
DoCalculation;
|
|
if (i and $3) = $3 then
|
|
Synchronize(@ShowStrings);
|
|
if Terminated then break;
|
|
end;
|
|
Synchronize(@ExecDone);
|
|
end;
|
|
|
|
|
|
constructor TForm1.Create(AOwner: TComponent);
|
|
begin
|
|
inherited CreateNew(AOwner, 1);
|
|
Caption := 'Thread Synchronize Demo v0.1';
|
|
ThreadList := TList.Create;
|
|
LoadMainMenu;
|
|
end;
|
|
|
|
destructor TForm1.Destroy;
|
|
begin
|
|
inherited;
|
|
|
|
FreeAndNil(ThreadList);
|
|
end;
|
|
|
|
function TForm1.CloseQuery: boolean;
|
|
var
|
|
I: integer;
|
|
begin
|
|
if ThreadList.Count > 0 then
|
|
begin
|
|
Caption := Caption + ' [wait for threads termination]';
|
|
for I := 0 to ThreadList.Count - 1 do
|
|
TThread(ThreadList.Items[I]).Terminate;
|
|
Result := false;
|
|
end else
|
|
inherited;
|
|
end;
|
|
|
|
procedure TForm1.Button1Click(Sender : TObject);
|
|
Begin
|
|
if assigned (progre3) then begin
|
|
progre3.Position := 0;
|
|
progre3.Min := progre3.Min - 1
|
|
end;
|
|
End;
|
|
|
|
procedure TForm1.Button2Click(Sender : TObject);
|
|
Begin
|
|
if assigned (progre3) then begin
|
|
progre3.Position := 0;
|
|
progre3.Min := progre3.Min + 1;
|
|
end;
|
|
End;
|
|
|
|
procedure TForm1.Button3Click(Sender : TObject);
|
|
Begin
|
|
if assigned (progre3) then begin
|
|
progre3.Position := 0;
|
|
progre3.Max := progre3.Max +1;
|
|
end;
|
|
End;
|
|
|
|
procedure TForm1.Button4Click(Sender : TObject);
|
|
Begin
|
|
if assigned (progre3) then begin
|
|
progre3.Position := 0;
|
|
progre3.Max := progre3.Max -1;
|
|
end;
|
|
End;
|
|
|
|
procedure TForm1.Button10Click(Sender : TObject);
|
|
Begin
|
|
if assigned (progre3) then begin
|
|
if progre3.position >= progre3.max then
|
|
progre3.position := progre3.min;
|
|
progre3.stepit;
|
|
end;
|
|
End;
|
|
|
|
procedure TForm1.Button5Click(Sender : TObject);
|
|
Begin
|
|
if assigned (progre1) then begin
|
|
Progre1.Smooth := not Progre1.Smooth;
|
|
if assigned (Button6)
|
|
then Button6.Visible := Progre1.Smooth;
|
|
end;
|
|
End;
|
|
|
|
procedure TForm1.Button6Click(Sender : TObject);
|
|
Begin
|
|
if assigned (progre1) then begin
|
|
Progre1.BarShowtext := not Progre1.BarShowtext;
|
|
end;
|
|
End;
|
|
|
|
procedure TForm1.Button7Click(Sender : TObject);
|
|
Begin
|
|
if assigned (progre1) then
|
|
begin
|
|
case Progre1.Orientation of
|
|
pbVertical : Progre1.Orientation := pbRightToLeft;
|
|
pbRightToLeft : Progre1.Orientation := pbTopDown;
|
|
pbTopDown : Progre1.Orientation := pbHorizontal;
|
|
pbHorizontal : Progre1.Orientation := pbVertical;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TForm1.Button8Click(Sender : TObject);
|
|
begin
|
|
{ Create the threads }
|
|
TotalCount := 1000;
|
|
GlobalData := 100;
|
|
threadvartest := 20;
|
|
Thread1 := TThread1.Create;
|
|
Thread2 := TThread2.Create;
|
|
ThreadList.Add(Thread1);
|
|
ThreadList.Add(Thread2);
|
|
|
|
End;
|
|
|
|
procedure TForm1.Button9Click(Sender : TObject);
|
|
begin
|
|
Listbox1.Items.Clear;
|
|
Listbox2.Items.Clear;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------}
|
|
procedure TForm1.LoadMainMenu;
|
|
|
|
begin
|
|
{ set the height and width }
|
|
Height := 350;
|
|
Width := 700;
|
|
|
|
{ Create a progressbar }
|
|
Progre1 := TProgressBar.Create (Self);
|
|
with Progre1 do
|
|
begin
|
|
Parent := Self;
|
|
SetBounds(300, 10, 250, 20);
|
|
Min := 0;
|
|
Max := 10;
|
|
Step := 1;
|
|
BarShowText := true;
|
|
Smooth := True;
|
|
Show;
|
|
end;
|
|
|
|
Progre2 := TProgressBar.Create (Self);
|
|
with Progre2 do
|
|
begin
|
|
Parent := Self;
|
|
SetBounds(300, 35, 250, 20);
|
|
Min := 0;
|
|
Max := 10;
|
|
Step := 1;
|
|
BarShowText := true;
|
|
Smooth := True;
|
|
Show;
|
|
end;
|
|
|
|
Progre3 := TProgressBar.Create (Self);
|
|
with Progre3 do
|
|
begin
|
|
Parent := Self;
|
|
SetBounds(300, 60, 250, 20);
|
|
Min := 0;
|
|
Max := 10;
|
|
Step := 1;
|
|
BarShowText := true;
|
|
Smooth := True;
|
|
Show;
|
|
end;
|
|
|
|
{ create listboxes to show thread results }
|
|
Listbox1 := TListBox.Create(self);
|
|
with Listbox1 do
|
|
begin
|
|
Parent := self;
|
|
SetBounds(10, 120, 200, 180);
|
|
end;
|
|
|
|
Listbox2 := TListBox.Create(self);
|
|
with Listbox2 do
|
|
begin
|
|
Parent := self;
|
|
SetBounds(250, 120, 200, 180);
|
|
end;
|
|
|
|
|
|
{ Create a few buttons }
|
|
Button2 := TButton.Create(Self);
|
|
Button2.Parent := Self;
|
|
Button2.Left := 200;
|
|
Button2.Top := 70;
|
|
Button2.Width := 80;
|
|
Button2.Height := 30;
|
|
Button2.Show;
|
|
Button2.Caption := 'PMin ++';
|
|
// Button2.ToolTip := 'Tool Tip';
|
|
// Button2.ShowToolTip := True;
|
|
Button2.OnClick := @Button2Click;
|
|
|
|
|
|
Button1 := TButton.Create(Self);
|
|
Button1.Parent := Self;
|
|
Button1.Left := 50;
|
|
Button1.Top := 70;
|
|
Button1.Width := 80;
|
|
Button1.Height := 30;
|
|
Button1.Show;
|
|
Button1.Caption := 'PMin--';
|
|
Button1.OnClick := @Button1Click;
|
|
|
|
{ Create 2 more buttons outside the groupbox }
|
|
Button3 := TButton.Create(Self);
|
|
Button3.Parent := Self;
|
|
Button3.Left := 50;
|
|
Button3.Top := 30;
|
|
Button3.Width := 80;
|
|
Button3.Height := 30;
|
|
Button3.Show;
|
|
Button3.Caption := 'PMax++';
|
|
// Button3.ToolTip := 'Tool Tip';
|
|
// Button3.ShowToolTip := True;
|
|
Button3.OnClick := @Button3Click;
|
|
|
|
Button4 := TButton.Create(Self);
|
|
Button4.Parent := Self;
|
|
Button4.Left := 200;
|
|
Button4.Top := 30;
|
|
Button4.Width := 80;
|
|
Button4.Height := 30;
|
|
Button4.Show;
|
|
Button4.Caption := 'PMax--';
|
|
Button4.OnClick := @Button4Click;
|
|
|
|
Button10 := TButton.Create(Self);
|
|
with Button10 do
|
|
begin
|
|
Parent := Self;
|
|
SetBounds(140, 30, 50, 30);
|
|
Show;
|
|
Caption := 'Step It';
|
|
OnClick := @Button10Click;
|
|
end;
|
|
|
|
Button5 := TButton.Create(Self);
|
|
Button5.Parent := Self;
|
|
Button5.Left := 500;
|
|
Button5.Top := 110;
|
|
Button5.Width := 130;
|
|
Button5.Height := 30;
|
|
Button5.Show;
|
|
Button5.Caption := 'Toggle Smooth';
|
|
Button5.OnClick := @Button5Click;
|
|
|
|
Button6 := TButton.Create(Self);
|
|
Button6.Parent := Self;
|
|
Button6.Left := 500;
|
|
Button6.Top := 150;
|
|
Button6.Width := 130;
|
|
Button6.Height := 30;
|
|
Button6.Show;
|
|
Button6.Caption := 'Toggle Text';
|
|
Button6.OnClick := @Button6Click;
|
|
Button6.Visible := Progre1.Smooth;
|
|
|
|
Button7 := TButton.Create(Self);
|
|
Button7.Parent := Self;
|
|
Button7.Left := 500;
|
|
Button7.Top := 190;
|
|
Button7.Width := 130;
|
|
Button7.Height := 30;
|
|
Button7.Show;
|
|
Button7.Caption := 'Orientation';
|
|
Button7.OnClick := @Button7Click;
|
|
|
|
Button8 := TButton.Create(Self);
|
|
with Button8 do
|
|
begin
|
|
Parent := Self;
|
|
SetBounds(500, 230, 130, 30);
|
|
Show;
|
|
Caption := 'Thread test';
|
|
OnClick := @Button8Click;
|
|
end;
|
|
|
|
Button9 := TButton.Create(Self);
|
|
with Button9 do
|
|
begin
|
|
Parent := Self;
|
|
SetBounds(500, 270, 130, 30);
|
|
Show;
|
|
Caption := 'Clear listboxes';
|
|
OnClick := @Button9Click;
|
|
end;
|
|
|
|
{ create a menubar }
|
|
mnuFile := TMainMenu.Create(Self);
|
|
mnuFile.Name:='mnuFile';
|
|
Menu := mnuFile;
|
|
|
|
itmFileQuit := TMenuItem.Create(Self);
|
|
itmFileQuit.Caption := 'Quit';
|
|
itmFileQuit.OnClick := @mnuQuitClicked;
|
|
mnuFile.Items.Add(itmFileQuit);
|
|
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------}
|
|
procedure TForm1.mnuQuitClicked(Sender : TObject);
|
|
begin
|
|
Close;
|
|
end;
|
|
{------------------------------------------------------------------------------}
|
|
|
|
begin
|
|
Application.Initialize; { calls InitProcedure which starts up GTK }
|
|
Application.CreateForm(TForm1, Form1);
|
|
Application.Run;
|
|
end.
|
|
|