Windoware/WINDOWARE_1_6.iso/miscprog/wthrds/threads.pas

Pascal/Delphi Source File | 1992-05-30 | 8.7 KB | 305 lines

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}