Category : Miscellaneous Language Source Code
Archive   : WTHRDS.ZIP
Filename : THREADS.PAS

Program ThreadsTest;

{$DEFINE FASTDEMO}
{^Insert a space to undefine}

{$R THREADS.RES}
{$C Moveable DemandLoad Discardable}
{
********************************************************************
* Threads test application *
* *
********************************************************************
* Copyright 1992 Robert Salesas, All Rights Reserved *
********************************************************************
* Version: 1.00 Author: Robert Salesas *
* Date: 22-May-1992 Changes: Original *
* *
********************************************************************
}


Uses ThrdAPI,
WinDOS, WinTypes, WinProcs, Strings;


Const
AppName = 'TPW Threads';
AppFile = 'THREADS.EXE';
ClassName = 'Threads';


Var
Wnd : HWnd;
Msg : TMsg;

AllDone : Boolean;

BallProc,
LinePRoc : TFarProc;



{ ***** Utility functions ***** }

Function Min(X, Y: Integer): Integer;
Begin
If (X < Y) Then
Min := X
Else
Min := Y;
End; {Min}


Function Max(X, Y: Integer): Integer;
Begin
If (X > Y) Then
Max := X
Else
Max := Y;
End; {Max}



{ ***** Thread functions *****}

Procedure LineThread(Thread : PThreadRec; Wnd : HWnd; wParam : Word; lParam : LongInt); Export;
Const
Colors : Array [0..6] Of TColorRef = ($00FF0000,
$0000FF00,
$000000FF,
$00FFFF00,
$0000FFFF,
$00FF00FF,
$00C000C0);
Var
DC : HDC;
Rect : TRect;
Pen,
OPen : HPen;
X, Y : Integer;
Col : TColorRef;
Begin
GetClientRect(Wnd, Rect);
X := Random(Rect.Right);
Y := Random(Rect.Bottom);
Col := Colors[Random(7)];

Pen := CreatePen(ps_Solid, 1, Col);

Repeat
DC := GetDC(Wnd);
If (DC = 0) Then
Begin
DeleteObject(Pen);
ExitThread;
End;

OPen := SelectObject(DC, Pen);

GetClientRect(Wnd, Rect);
MoveTo(DC, X, Y);
X := Max(0, Min(Rect.Right, X + Random(91) - 45));
Y := Max(0, Min(Rect.Bottom, Y + Random(91) - 45));
LineTo(DC, X, Y);

SelectObject(DC, OPen);
ReleaseDC(Wnd, DC);
Until (YieldThread = tm_Quit);

DeleteObject(Pen);
ExitThread;
End;


Procedure BallThread(Thread : PThreadRec; Wnd : HWnd; wParam : Word; lParam : LongInt); Export;
Var
DC : HDC;
Rect : TRect;
XDir,
YDir,
X, OX,
Y, OY : Integer;
Ball,
Erase : HIcon;
Begin
X := 0;
Y := 0;
XDir := 10 + (Random(11) - 5);
YDir := 10 + (Random(11) - 5);

Ball := LoadIcon(HInstance, PChar(Random(4) + 100));
Erase := LoadIcon(HInstance, 'EraseBall');

Repeat
DC := GetDC(Wnd);
If (DC = 0) Then
ExitThread;

GetClientRect(Wnd, Rect);
OX := X;
OY := Y;
X := X + XDir;
Y := Y + YDir;

If (X < 0) Then
Begin
X := 0;
XDir := -(XDir - (Random(11) - 5));
YDir := YDir + (Random(11) - 5);
End;
If (X + 32 > Rect.Right) Then
Begin
X := Rect.Right - 32;
XDir := -(XDir - (Random(11) - 5));
YDir := YDir + (Random(11) - 5);
End;

If (Y < 0) Then
Begin
Y := 0;
XDir := XDir - (Random(11) - 5);
YDir := -(YDir + (Random(11) - 5));
End;
If (Y + 32 > Rect.Bottom) Then
Begin
Y := Rect.Bottom - 32;
XDir := XDir + (Random(11) - 5);
YDir := -(YDir + (Random(11) - 5));
End;

If (XDir <= 0) And (XDir > -6) Then
XDir := -6;
If (XDir > 0) And (XDir < 6) Then
XDir := 6;
If (YDir <= 0) And (YDir > -6) Then
YDir := -6;
If (YDir > 0) And (YDir < 6) Then
YDir := 5;
XDir := Max(-20, Min(20, XDir));
YDir := Max(-20, Min(20, YDir));

DrawIcon(DC, OX, OY, Erase);
DrawIcon(DC, X, Y, Ball);
ReleaseDC(Wnd, DC);
Until (YieldThread = tm_Quit);

ExitThread;
End;



{ ***** Window function ***** }

Function MainWndProc(Window : HWnd; Msg, wParam : Word; lParam : LongInt) : LongInt; Export;
Var
Title : Array [0..255] Of Char;
NumThreads : LongInt;
Begin
Case Msg Of
wm_Create : Begin
LineProc := MakeProcInstance(@LineThread, HInstance);
BallProc := MakeProcInstance(@BallThread, HInstance);
End;
wm_Command : Case wParam Of
100 : Begin
StartThread(BallProc, 2000, Window, 30, 10);
NumThreads := GetNumThreads;
WVSPrintf(Title, AppName + ' - %d Threads', Pointer(NumThreads));
SetWindowText(Window, Title);
End;
110 : Begin
SetThreadPriority(StartThread(LineProc, 2000, Window, 0, 0), ts_DefPriority Div 2);
NumThreads := GetNumThreads;
WVSPrintf(Title, AppName + ' - %d Threads', Pointer(NumThreads));
SetWindowText(Window, Title);
End;

500 : InvalidateRect(Window, Nil,TRUE);
510 : Begin
EndTaskThreads(GetCurrentTask);
InvalidateRect(Window, Nil,TRUE);
NumThreads := GetNumThreads;
WVSPrintf(Title, AppName + ' - %d Threads', Pointer(NumThreads));
SetWindowText(Window, Title);
End;
End;
wm_Destroy : Begin
EndTaskThreads(GetCurrentTask);
FreeProcInstance(BallProc);
FreeProcInstance(LineProc);

PostQuitMessage(0);
End;
Else
MainWndProc := DefWindowProc(Window, Msg, wParam, lParam);
End;
End; {MainWndProc}



Const
WindowClass : TWndClass = (Style : cs_HRedraw + cs_VRedraw;
lpfnWndProc : Nil;
cbClsExtra : 0;
cbWndExtra : 0;
hInstance : 0;
hIcon : 0;
hCursor : 0;
hbrBackground : 0;
lpszMenuName : 'APPMENU';
lpszClassName : ClassName);


Begin
RandSeed := MakeLong(((GetCurrentTime SHR 16) SHL 16), ((GetCurrentTime SHR 16) SHL 16));
If (HPrevInst = 0) Then
Begin
WindowClass.lpfnWndProc := @MainWndProc;
WindowClass.hInstance := HInstance;
WindowClass.hIcon := LoadIcon(0, idi_Application);
WindowClass.hCursor := LoadCursor(0, idc_Arrow);
WindowClass.hbrBackground := GetStockObject(white_Brush);

If Not RegisterClass(WindowClass) Then
Begin
MessageBox(0, 'Unable to register window class.', Nil, mb_Ok Or mb_IconStop);
Halt;
End;
End;

Wnd := CreateWindow(ClassName, AppName + ' - 0 Threads', ws_OverlappedWindow,
cw_UseDefault, 0, cw_UseDefault, 0, 0, 0, HInstance, Nil);
If (Wnd <> 0) Then
Begin
ShowWindow(Wnd, sw_ShowNormal);
UpdateWindow(Wnd);

{$IFNDEF FASTDEMO}
While GetMessage(Msg, 0, 0, 0) Do
Begin
TranslateMessage(Msg);
DispatchMessage(Msg);
End;
{$ELSE}
AllDone := False;
Repeat
If PeekMessage(Msg, 0, 0, 0, pm_NoRemove) Then
Begin
If GetMessage(Msg, 0, 0, 0) Then
Begin
TranslateMessage(Msg);
DispatchMessage(Msg);
End
Else
AllDone := True;
End
Else
ExecTaskThreads(GetCurrentTask);
Until AllDone;
{$ENDIF}
End
Else
MessageBox(0, 'Unable to open window.', Nil, mb_Ok or mb_IconStop);
End. {ThreadsTest}