Многопотоковая обработка delphi

[AnGel]

Пример: выполнить имитатор гонок (в просторечии эта задача известна как «тараканьи бега» ) при помощи создания нескольких потоков. Каждый поток обслуживает свою «беговую дорожку». На исполнение все потоки запускаются одновременно, после чего потоки произвольным образом приостанавливаются и запускаются вновь функциями SuspendThread() и ResumeThread().

На исполнение каждому потоку выделяется квант времени (например, 500 мс или 1 с). За этот период поток производит выполнение задачи, например, увеличивает позицию гонщика на некоторую величину. После истечения кванта времени поток приостанавливается на производный период времени, определяемый при помощи генератора случайных чисел.
После завершения гонки производиться выдача результатов(очередность завершения).
Завершение потока после завершения исполнения можно произвести при помощи функций ExitThread() и TerminateThread().

​

Использование класса TThread, включенного в поставку interise Delphi или C++ Builder, допускается в ознакомительных целях.


Сделал вот так, на счет 100% правильности конечно говорить не приходиться, но думаю, что правильно. Кто ни чего не делает то не ошибается))

unit unitMain;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ComCtrls;

const
  PROGRESS_POS = WM_USER+1;//установка значения
  EXITTHREAD_MESSAGE=WM_USER+2;//выход из потока
type
  TfrmMain = class(TForm)
    ProgressBar1: TProgressBar;
    ProgressBar2: TProgressBar;
    ProgressBar3: TProgressBar;
    ProgressBar4: TProgressBar;
    ProgressBar5: TProgressBar;
    btnStart: TButton;
    btnStop: TButton;
    btnClear: TButton;
    btnExit: TButton;
    Memo1: TMemo;
    Label1: TLabel;
    procedure btnStartClick(Sender: TObject);
    procedure btnStopClick(Sender: TObject);
    procedure btnClearClick(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure FormCreate(Sender: TObject);
    procedure btnExitClick(Sender: TObject);
  private
    { Private declarations }
    procedure SetProgressPos(var Msg: TMessage); message PROGRESS_POS;
    procedure MSExitThread(var Msg: TMessage); message EXITTHREAD_MESSAGE;
  public
    { Public declarations }
  end;

  //процедура выполняемая в отдельном потоке
  procedure procedurePotoc1(aValue:PInteger);stdcall;
const
  countThread=5;//кол-во потоков

var
  frmMain: TfrmMain;
  thread:array[1..countThread] of THandle;//массив для хранения
  threadID:array[1..countThread] of DWORD;
  bStop,vse:Boolean;
  Poriadok:TStringList;
implementation

{$R *.dfm}
//процедура выполняемая в отдельном потоке
procedure procedurePotoc1(aValue:PInteger);stdcall;
var
  i:Integer;
begin
  for I := 0 to 100 do
  begin
    Randomize;
    Sleep(Random(100)+50);
    SendMessage(frmMain.Handle,PROGRESS_POS, aValue^, i);
  end;
  SendMessage(frmMain.Handle,EXITTHREAD_MESSAGE, aValue^, 0);
end;

procedure TfrmMain.btnClearClick(Sender: TObject);
var
  i:Integer;
begin
  for i := 1 to countThread do
  begin
    if thread[i]>0 then //проверка того, что он вообще запускался))
      if TerminateThread(thread[i],0) then
        thread[i]:=0;
  end;
  ProgressBar1.Position:=0;
  ProgressBar2.Position:=0;
  ProgressBar3.Position:=0;
  ProgressBar4.Position:=0;
  ProgressBar5.Position:=0;
  Poriadok.Clear;
  Memo1.Lines.Clear;
end;

procedure TfrmMain.btnExitClick(Sender: TObject);
begin
  frmMain.Close;
end;

procedure TfrmMain.btnStartClick(Sender: TObject);
var
  i:Integer;
  n:Integer;
begin
  for i := 1 to countThread do
  begin
    if thread[i]=0 then
    begin
      thread[i]:=CreateThread(nil,0, @procedurePotoc1, @thread[i], 0, threadID[i]);
    end;
    if (thread[i] = 0) then
      ShowMessage('Поток не создан '+IntToStr(i));
  end;
  Poriadok.Clear;
end;

procedure TfrmMain.btnStopClick(Sender: TObject);
var
  i:Integer;
begin
  for i := 1 to countThread do
  begin
    if bStop then
    begin
      ResumeThread(thread[i]);
    end
    else
    begin
      SuspendThread(thread[i]);
    end;
  end;
  if bStop then
    bStop:=False
  else
    bStop:=True;
end;

procedure TfrmMain.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  btnClearClick(Self);
  Poriadok.Free;
end;


procedure TfrmMain.FormCreate(Sender: TObject);
begin
  Poriadok:=TStringList.Create;
end;

procedure TfrmMain.MSExitThread(var Msg: TMessage);
var
  i:Integer;
  temp:cardinal;
begin
  temp:=0;
  for I := 1 to countThread do
  begin
    if thread[i]=Msg.WParam then
    begin
      thread[i]:=0;
      Poriadok.Add('"Таракан" №'+IntToStr(i));
    end;
    temp:=temp+thread[i];
    if temp=0 then//все потоки завершились или нет
      vse:=True
    else
      vse:=False;
  end;
  if vse then//все потоки завершились или нет
    Memo1.Lines:=Poriadok;
end;

procedure TfrmMain.SetProgressPos(var Msg: TMessage);
var
  i:Integer;
  n:Integer;
  hN:THandle;
begin
  for i:= 1 to countThread  do
  begin
    if thread[i]=Msg.WParam then
      TProgressBar(Self.FindComponent('ProgressBar'+IntToStr(i))).Position:=Msg.LParam;
  end;
end;
end.

Синхронизацию с VCL реализовал путем обмена сообщениями.

Скачать:

Пожалуйста, Вход или Регистрация для просмотра содержимого URL-адресов!