PageRenderTime 61ms CodeModel.GetById 2ms app.highlight 54ms RepoModel.GetById 1ms app.codeStats 0ms

/examples/synchronize.pp

http://github.com/graemeg/lazarus
Pascal | 558 lines | 440 code | 63 blank | 55 comment | 23 complexity | ccdb47acbe0aa1fbeed51ae72f00c64d MD5 | raw file
  1{
  2 /***************************************************************************
  3                          synchronize - example
  4                          ---------------------
  5
  6                   Just a simple example to show & verify functionality
  7                   of the lazarus TThread.Synchronize / TProgressBar classes.
  8
  9                   Initial Revision  : Sun Aug 15 1999
 10
 11                   by Stefan Hille <stoppok@osibisa.ms.sub.org>
 12                   and Micha Nelissen
 13
 14 ***************************************************************************/
 15
 16 ***************************************************************************
 17 *                                                                         *
 18 *   This source is free software; you can redistribute it and/or modify   *
 19 *   it under the terms of the GNU General Public License as published by  *
 20 *   the Free Software Foundation; either version 2 of the License, or     *
 21 *   (at your option) any later version.                                   *
 22 *                                                                         *
 23 *   This code is distributed in the hope that it will be useful, but      *
 24 *   WITHOUT ANY WARRANTY; without even the implied warranty of            *
 25 *   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU     *
 26 *   General Public License for more details.                              *
 27 *                                                                         *
 28 *   A copy of the GNU General Public License is available on the World    *
 29 *   Wide Web at <http://www.gnu.org/copyleft/gpl.html>. You can also      *
 30 *   obtain it by writing to the Free Software Foundation,                 *
 31 *   Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.        *
 32 *                                                                         *
 33 ***************************************************************************
 34}
 35program Synchronize;
 36
 37{$mode objfpc}{$H+}
 38
 39{ threading directive not needed anymore for 1.9.8+ }
 40{ $threading on}
 41
 42uses
 43{$ifdef UNIX}
 44  CThreads,
 45{$endif}
 46  Interfaces, Classes, StdCtrls, Forms, Buttons, Menus, ComCtrls,
 47  SysUtils, Extctrls;
 48
 49
 50type
 51
 52  TAThread = class(TThread)
 53  protected
 54    FTargetListBox: TListBox;
 55    FTargetProgress: TProgressBar;
 56    FTestStrings: TStrings;
 57    procedure ExecDone;
 58    procedure ShowStrings;
 59  public
 60    constructor Create(CreateSuspended: boolean);
 61    destructor Destroy; override;
 62  end;
 63
 64  TThread1 = class(TAThread)
 65  public
 66    constructor Create;
 67    procedure Execute; override;
 68  end;
 69
 70  TThread2 = class(TAThread)
 71  public
 72    constructor Create;
 73    procedure Execute; override;
 74  end;
 75
 76  TForm1 = class(TForm)
 77  public
 78    Progre1: TProgressBar;
 79    Progre2: TProgressBar;
 80    Progre3: TProgressBar;
 81    Listbox1: TListBox;
 82    Listbox2: TListBox;
 83    Thread1: TThread1;
 84    Thread2: TThread2;
 85    ThreadList: TList;
 86    Button1: TButton;
 87    Button2: TButton;
 88    Button3: TButton;
 89    Button4: TButton;
 90    Button5: TButton;
 91    Button6: TButton;
 92    Button7: TButton;
 93    Button8: TButton;
 94    Button9: TButton;
 95    Button10: TButton;
 96    mnuFile: TMainMenu;
 97    itmFileQuit: TMenuItem;
 98    constructor Create(AOwner: TComponent); override;
 99    destructor Destroy; override;
100    procedure LoadMainMenu;
101    procedure mnuQuitClicked(Sender : TObject);
102  protected
103    procedure Button1CLick(Sender : TObject);
104    procedure Button2CLick(Sender : TObject);
105    procedure Button3CLick(Sender : TObject);
106    procedure Button4CLick(Sender : TObject);
107    procedure Button5CLick(Sender : TObject);
108    procedure Button6CLick(Sender : TObject);
109    procedure Button7CLick(Sender : TObject);
110    procedure Button8CLick(Sender : TObject);
111    procedure Button9CLick(Sender : TObject);
112    procedure Button10CLick(Sender : TObject);
113    function CloseQuery: boolean; override;
114  end;
115
116threadvar
117  threadvartest: integer;
118
119var
120  Form1 : TForm1;
121  TotalCount: integer;
122  { GlobalData is an example of what you should NOT do :)
123    Access from multiple threads to same variable unprotected }
124  GlobalData: integer;
125
126constructor TAThread.Create(CreateSuspended: boolean);
127begin
128  inherited;
129
130  FTestStrings := TStringList.Create;
131end;
132
133destructor TAThread.Destroy;
134begin
135  inherited;
136
137  FTestStrings.Free;
138end;
139
140procedure TAThread.ExecDone;
141var
142  lPos: integer;
143begin
144  Form1.ThreadList.Remove(Self);
145  FTargetListBox.Items.Insert(0, 'Thread terminated');
146  if Form1.ThreadList.Count = 0 then
147  begin
148    lPos := Pos('[', Form1.Caption);
149    if lPos > 0 then
150      Form1.Caption := Copy(Form1.Caption, 1, lPos - 1) + '[done, ready to exit]';
151  end;
152end;
153
154procedure TAThread.ShowStrings;
155var
156  i: integer;
157begin
158  FTargetListBox.Items.BeginUpdate;
159  for i := 0 to FTestStrings.Count - 1 do
160  begin
161    FTargetListBox.Items.Insert(0, FTestStrings.Strings[i]);
162    while FTargetListBox.Items.Count > 30 do
163      FTargetListBox.Items.Delete(FTargetListBox.Items.Count-1);
164  end;
165  FTargetListBox.Items.EndUpdate;
166  FTestStrings.Clear;
167  if FTargetProgress.Position = FTargetProgress.Max then
168    FTargetProgress.Position := FTargetProgress.Min;
169  FTargetProgress.StepIt;
170end;
171
172constructor TThread1.Create;
173begin
174  FTargetListBox := Form1.Listbox1;
175  FTargetProgress := Form1.Progre1;
176  FreeOnTerminate := true;
177  inherited Create(false);
178end;
179
180function DoCalculation: integer;
181var
182  i, k: integer;
183  j: array[0..511] of integer;
184begin
185  for i := 0 to 100000 do
186  begin
187    j[i mod $1ff] := i * i;
188    k := j[(i + 3) and $1ff] div (i+1);
189    j[(i + 5) and $1ff] := k - 3;
190  end;
191  result := j[5];
192end;
193
194procedure TThread1.Execute;
195var
196  i: integer;
197begin
198  threadvartest := 10;
199  FTestStrings.Add('Threadvar is @'+IntToStr(ptrint(@threadvartest)));
200  for i := 0 to TotalCount - 1 do
201  begin
202    GlobalData += 3;
203    DoCalculation;
204    FTestStrings.Add('Information: '+IntToStr(GlobalData-3)+' '+IntToStr(threadvartest));
205    GlobalData -= 3;
206    DoCalculation;
207    Synchronize(@ShowStrings);
208    threadvartest := 10;
209    if Terminated then break;
210  end;
211  Synchronize(@ExecDone);
212end;
213
214constructor TThread2.Create;
215begin
216  FTargetListBox := Form1.Listbox2;
217  FTargetProgress := Form1.Progre2;
218  FreeOnTerminate := true;
219  inherited Create(false);
220end;
221
222procedure TThread2.Execute;
223var
224  i: integer;
225begin
226  threadvartest := 15;
227  FTestStrings.Add('Threadvar is @'+IntToStr(ptrint(@threadvartest)));
228  for i := 0 to TotalCount - 1 do
229  begin
230    GlobalData -= 3;
231    DoCalculation;
232    FTestStrings.Add('Information: '+IntToStr(GlobalData+3)+' '+IntToStr(threadvartest));
233    threadvartest := 15;
234    GlobalData += 3;
235    DoCalculation;
236    if (i and $3) = $3 then
237      Synchronize(@ShowStrings);
238    if Terminated then break;
239  end;
240  Synchronize(@ExecDone);
241end;
242
243
244constructor TForm1.Create(AOwner: TComponent);
245begin
246   inherited CreateNew(AOwner, 1);
247   Caption := 'Thread Synchronize Demo v0.1';
248   ThreadList := TList.Create;
249   LoadMainMenu;
250end;
251
252destructor TForm1.Destroy;
253begin
254  inherited;
255
256  FreeAndNil(ThreadList);
257end;
258
259function TForm1.CloseQuery: boolean;
260var
261  I: integer;
262begin
263  if ThreadList.Count > 0 then
264  begin
265    Caption := Caption + ' [wait for threads termination]';
266    for I := 0 to ThreadList.Count - 1 do
267      TThread(ThreadList.Items[I]).Terminate;
268    Result := false;
269  end else
270    inherited;
271end;
272
273procedure TForm1.Button1Click(Sender : TObject);
274Begin
275   if assigned (progre3) then begin
276        progre3.Position := 0;
277        progre3.Min := progre3.Min - 1
278   end;
279End;
280
281procedure TForm1.Button2Click(Sender : TObject);
282Begin
283   if assigned (progre3) then begin
284        progre3.Position := 0;
285        progre3.Min := progre3.Min + 1;
286   end;
287End;
288
289procedure TForm1.Button3Click(Sender : TObject);
290Begin
291   if assigned (progre3) then begin
292        progre3.Position := 0;
293        progre3.Max := progre3.Max +1;
294   end;
295End;
296
297procedure TForm1.Button4Click(Sender : TObject);
298Begin
299   if assigned (progre3) then begin
300        progre3.Position := 0;
301        progre3.Max := progre3.Max -1;
302   end;
303End;
304
305procedure TForm1.Button10Click(Sender : TObject);
306Begin
307  if assigned (progre3) then begin
308    if progre3.position >= progre3.max then
309      progre3.position := progre3.min;
310    progre3.stepit;
311  end;
312End;
313
314procedure TForm1.Button5Click(Sender : TObject);
315Begin
316   if assigned (progre1) then begin
317        Progre1.Smooth := not Progre1.Smooth;
318        if assigned (Button6)
319          then Button6.Visible := Progre1.Smooth;
320   end;
321End;
322
323procedure TForm1.Button6Click(Sender : TObject);
324Begin
325   if assigned (progre1) then begin
326        Progre1.BarShowtext := not Progre1.BarShowtext;
327   end;
328End;
329
330procedure TForm1.Button7Click(Sender : TObject);
331Begin
332   if assigned (progre1) then
333   begin
334     case Progre1.Orientation of
335        pbVertical      : Progre1.Orientation := pbRightToLeft;
336        pbRightToLeft   : Progre1.Orientation := pbTopDown;
337        pbTopDown       : Progre1.Orientation := pbHorizontal;
338        pbHorizontal    : Progre1.Orientation := pbVertical;
339     end;
340   end;
341end;
342
343procedure TForm1.Button8Click(Sender : TObject);
344begin
345        { Create the threads }
346        TotalCount := 1000;
347        GlobalData := 100;
348        threadvartest := 20;
349        Thread1 := TThread1.Create;
350        Thread2 := TThread2.Create;
351        ThreadList.Add(Thread1);
352        ThreadList.Add(Thread2);
353
354End;
355
356procedure TForm1.Button9Click(Sender : TObject);
357begin
358  Listbox1.Items.Clear;
359  Listbox2.Items.Clear;
360end;
361
362{------------------------------------------------------------------------------}
363procedure TForm1.LoadMainMenu;
364
365begin
366        { set the height and width }
367        Height := 350;
368        Width := 700;
369
370        { Create a progressbar }
371        Progre1 := TProgressBar.Create (Self);
372        with Progre1 do
373        begin
374          Parent := Self;
375          SetBounds(300, 10, 250, 20);
376          Min := 0;
377          Max := 10;
378          Step := 1;
379          BarShowText := true;
380          Smooth := True;
381          Show;
382        end;
383
384        Progre2 := TProgressBar.Create (Self);
385        with Progre2 do
386        begin
387          Parent := Self;
388          SetBounds(300, 35, 250, 20);
389          Min := 0;
390          Max := 10;
391          Step := 1;
392          BarShowText := true;
393          Smooth := True;
394          Show;
395        end;
396
397        Progre3 := TProgressBar.Create (Self);
398        with Progre3 do
399        begin
400          Parent := Self;
401          SetBounds(300, 60, 250, 20);
402          Min := 0;
403          Max := 10;
404          Step := 1;
405          BarShowText := true;
406          Smooth := True;
407          Show;
408        end;
409
410        { create listboxes to show thread results }
411        Listbox1 := TListBox.Create(self);
412        with Listbox1 do
413        begin
414          Parent := self;
415          SetBounds(10, 120, 200, 180);
416        end;
417
418        Listbox2 := TListBox.Create(self);
419        with Listbox2 do
420        begin
421          Parent := self;
422          SetBounds(250, 120, 200, 180);
423        end;
424
425
426        { Create a few buttons }
427        Button2 := TButton.Create(Self);
428        Button2.Parent := Self;
429        Button2.Left := 200;
430        Button2.Top := 70;
431        Button2.Width := 80;
432        Button2.Height := 30;
433        Button2.Show;
434        Button2.Caption := 'PMin ++';
435//      Button2.ToolTip := 'Tool Tip';
436//      Button2.ShowToolTip := True;
437        Button2.OnClick := @Button2Click;
438
439
440        Button1 := TButton.Create(Self);
441        Button1.Parent := Self;
442        Button1.Left := 50;
443        Button1.Top := 70;
444        Button1.Width := 80;
445        Button1.Height := 30;
446        Button1.Show;
447        Button1.Caption := 'PMin--';
448        Button1.OnClick := @Button1Click;
449
450        { Create 2 more buttons outside the groupbox }
451        Button3 := TButton.Create(Self);
452        Button3.Parent := Self;
453        Button3.Left := 50;
454        Button3.Top := 30;
455        Button3.Width := 80;
456        Button3.Height := 30;
457        Button3.Show;
458        Button3.Caption := 'PMax++';
459//      Button3.ToolTip := 'Tool Tip';
460//      Button3.ShowToolTip := True;
461        Button3.OnClick := @Button3Click;
462
463        Button4 := TButton.Create(Self);
464        Button4.Parent := Self;
465        Button4.Left := 200;
466        Button4.Top := 30;
467        Button4.Width := 80;
468        Button4.Height := 30;
469        Button4.Show;
470        Button4.Caption := 'PMax--';
471        Button4.OnClick := @Button4Click;
472
473        Button10 := TButton.Create(Self);
474        with Button10 do
475        begin
476          Parent := Self;
477          SetBounds(140, 30, 50, 30);
478          Show;
479          Caption := 'Step It';
480          OnClick := @Button10Click;
481        end;
482
483        Button5 := TButton.Create(Self);
484        Button5.Parent := Self;
485        Button5.Left := 500;
486        Button5.Top := 110;
487        Button5.Width := 130;
488        Button5.Height := 30;
489        Button5.Show;
490        Button5.Caption := 'Toggle Smooth';
491        Button5.OnClick := @Button5Click;
492
493        Button6 := TButton.Create(Self);
494        Button6.Parent := Self;
495        Button6.Left := 500;
496        Button6.Top := 150;
497        Button6.Width := 130;
498        Button6.Height := 30;
499        Button6.Show;
500        Button6.Caption := 'Toggle Text';
501        Button6.OnClick := @Button6Click;
502        Button6.Visible := Progre1.Smooth;
503
504        Button7 := TButton.Create(Self);
505        Button7.Parent := Self;
506        Button7.Left := 500;
507        Button7.Top := 190;
508        Button7.Width := 130;
509        Button7.Height := 30;
510        Button7.Show;
511        Button7.Caption := 'Orientation';
512        Button7.OnClick := @Button7Click;
513
514        Button8 := TButton.Create(Self);
515        with Button8 do
516        begin
517          Parent := Self;
518          SetBounds(500, 230, 130, 30);
519          Show;
520          Caption := 'Thread test';
521          OnClick := @Button8Click;
522        end;
523
524        Button9 := TButton.Create(Self);
525        with Button9 do
526        begin
527          Parent := Self;
528          SetBounds(500, 270, 130, 30);
529          Show;
530          Caption := 'Clear listboxes';
531          OnClick := @Button9Click;
532        end;
533
534        { create a menubar }
535        mnuFile := TMainMenu.Create(Self);
536        mnuFile.Name:='mnuFile';
537        Menu := mnuFile;
538
539        itmFileQuit := TMenuItem.Create(Self);
540        itmFileQuit.Caption := 'Quit';
541        itmFileQuit.OnClick := @mnuQuitClicked;
542        mnuFile.Items.Add(itmFileQuit);
543
544end;
545
546{------------------------------------------------------------------------------}
547procedure TForm1.mnuQuitClicked(Sender : TObject);
548begin
549  Close;
550end;
551{------------------------------------------------------------------------------}
552
553begin
554   Application.Initialize; { calls InitProcedure which starts up GTK }
555   Application.CreateForm(TForm1, Form1);
556   Application.Run;
557end.
558