home *** CD-ROM | disk | FTP | other *** search
/ Software of the Month Club 1995 March / SOFM_Mar1995.bin / pc / sri / windows / edi / threads.pas < prev    next >
Pascal/Delphi Source File  |  1995-01-27  |  9KB  |  305 lines
  1. Program ThreadsTest;
  2.  
  3. {$DEFINE FASTDEMO}
  4. {^Insert a space to undefine}
  5.  
  6. {$R THREADS.RES}
  7. {$C Moveable DemandLoad Discardable}
  8. {
  9. ********************************************************************
  10. *                     Threads test application                     *
  11. *                                                                  *
  12. ********************************************************************
  13. *       Copyright 1992 Robert Salesas, All Rights Reserved         *
  14. ********************************************************************
  15. *      Version: 1.00             Author:  Robert Salesas           *
  16. *      Date:    22-May-1992      Changes: Original                 *
  17. *                                                                  *
  18. ********************************************************************
  19. }
  20.  
  21.  
  22. Uses ThrdAPI,
  23.      WinDOS, WinTypes, WinProcs, Strings;
  24.  
  25.  
  26. Const
  27.   AppName = 'TPW Threads';
  28.   AppFile = 'THREADS.EXE';
  29.   ClassName = 'Threads';
  30.  
  31.  
  32. Var
  33.   Wnd : HWnd;
  34.   Msg : TMsg;
  35.  
  36.   AllDone : Boolean;
  37.  
  38.   BallProc,
  39.   LinePRoc  : TFarProc;
  40.  
  41.  
  42.  
  43. { ***** Utility functions ***** }
  44.  
  45.   Function Min(X, Y: Integer): Integer;
  46.   Begin
  47.     If (X < Y) Then
  48.       Min := X
  49.     Else
  50.       Min := Y;
  51.   End; {Min}
  52.  
  53.  
  54.   Function Max(X, Y: Integer): Integer;
  55.   Begin
  56.     If (X > Y) Then
  57.       Max := X
  58.     Else
  59.       Max := Y;
  60.   End; {Max}
  61.  
  62.  
  63.  
  64. { ***** Thread functions *****}
  65.  
  66.   Procedure LineThread(Thread : PThreadRec;  Wnd : HWnd;  wParam : Word;  lParam : LongInt);  Export;
  67.   Const
  68.     Colors : Array [0..6] Of TColorRef = ($00FF0000,
  69.                                           $0000FF00,
  70.                                           $000000FF,
  71.                                           $00FFFF00,
  72.                                           $0000FFFF,
  73.                                           $00FF00FF,
  74.                                           $00C000C0);
  75.   Var
  76.     DC   : HDC;
  77.     Rect : TRect;
  78.     Pen,
  79.     OPen : HPen;
  80.     X, Y : Integer;
  81.     Col  : TColorRef;
  82.   Begin
  83.     GetClientRect(Wnd, Rect);
  84.     X := Random(Rect.Right);
  85.     Y := Random(Rect.Bottom);
  86.     Col := Colors[Random(7)];
  87.  
  88.     Pen := CreatePen(ps_Solid, 1, Col);
  89.  
  90.     Repeat
  91.       DC := GetDC(Wnd);
  92.       If (DC = 0) Then
  93.         Begin
  94.           DeleteObject(Pen);
  95.           ExitThread;
  96.         End;
  97.  
  98.       OPen := SelectObject(DC, Pen);
  99.  
  100.       GetClientRect(Wnd, Rect);
  101.       MoveTo(DC, X, Y);
  102.       X := Max(0, Min(Rect.Right, X + Random(91) - 45));
  103.       Y := Max(0, Min(Rect.Bottom, Y + Random(91) - 45));
  104.       LineTo(DC, X, Y);
  105.  
  106.       SelectObject(DC, OPen);
  107.       ReleaseDC(Wnd, DC);
  108.     Until (YieldThread = tm_Quit);
  109.  
  110.     DeleteObject(Pen);
  111.     ExitThread;
  112.   End;
  113.  
  114.  
  115.   Procedure BallThread(Thread : PThreadRec;  Wnd : HWnd;  wParam : Word;  lParam : LongInt);  Export;
  116.   Var
  117.     DC     : HDC;
  118.     Rect   : TRect;
  119.     XDir,
  120.     YDir,
  121.     X, OX,
  122.     Y, OY  : Integer;
  123.     Ball,
  124.     Erase  : HIcon;
  125.   Begin
  126.     X := 0;
  127.     Y := 0;
  128.     XDir := 10 + (Random(11) - 5);
  129.     YDir := 10 + (Random(11) - 5);
  130.  
  131.     Ball := LoadIcon(HInstance, PChar(Random(4) + 100));
  132.     Erase := LoadIcon(HInstance, 'EraseBall');
  133.  
  134.     Repeat
  135.       DC := GetDC(Wnd);
  136.       If (DC = 0) Then
  137.         ExitThread;
  138.  
  139.       GetClientRect(Wnd, Rect);
  140.       OX := X;
  141.       OY := Y;
  142.       X := X + XDir;
  143.       Y := Y + YDir;
  144.  
  145.       If (X < 0) Then
  146.         Begin
  147.           X := 0;
  148.           XDir := -(XDir - (Random(11) - 5));
  149.           YDir := YDir + (Random(11) - 5);
  150.         End;
  151.       If (X + 32 > Rect.Right) Then
  152.         Begin
  153.           X := Rect.Right - 32;
  154.           XDir := -(XDir - (Random(11) - 5));
  155.           YDir := YDir + (Random(11) - 5);
  156.         End;
  157.  
  158.       If (Y < 0) Then
  159.         Begin
  160.           Y := 0;
  161.           XDir := XDir - (Random(11) - 5);
  162.           YDir := -(YDir + (Random(11) - 5));
  163.         End;
  164.       If (Y + 32 > Rect.Bottom) Then
  165.         Begin
  166.           Y := Rect.Bottom - 32;
  167.           XDir := XDir + (Random(11) - 5);
  168.           YDir := -(YDir + (Random(11) - 5));
  169.         End;
  170.  
  171.       If (XDir <= 0) And (XDir > -6) Then
  172.         XDir := -6;
  173.       If (XDir > 0) And (XDir < 6) Then
  174.         XDir := 6;
  175.       If (YDir <= 0) And (YDir > -6) Then
  176.         YDir := -6;
  177.       If (YDir > 0) And (YDir < 6) Then
  178.         YDir := 5;
  179.       XDir := Max(-20, Min(20, XDir));
  180.       YDir := Max(-20, Min(20, YDir));
  181.  
  182.       DrawIcon(DC, OX, OY, Erase);
  183.       DrawIcon(DC, X, Y, Ball);
  184.       ReleaseDC(Wnd, DC);
  185.     Until (YieldThread = tm_Quit);
  186.  
  187.     ExitThread;
  188.   End;
  189.  
  190.  
  191.  
  192. { ***** Window function ***** }
  193.  
  194.   Function MainWndProc(Window : HWnd;  Msg, wParam : Word;  lParam : LongInt) : LongInt;  Export;
  195.   Var
  196.     Title      : Array [0..255] Of Char;
  197.     NumThreads : LongInt;
  198.   Begin
  199.     Case Msg Of
  200.       wm_Create    : Begin
  201.                        LineProc := MakeProcInstance(@LineThread, HInstance);
  202.                        BallProc := MakeProcInstance(@BallThread, HInstance);
  203.                      End;
  204.       wm_Command   : Case wParam Of
  205.                        100 : Begin
  206.                                StartThread(BallProc, 2000, Window, 30, 10);
  207.                                NumThreads := GetNumThreads;
  208.                                WVSPrintf(Title, AppName + ' - %d Threads', Pointer(NumThreads));
  209.                                SetWindowText(Window, Title);
  210.                              End;
  211.                        110 : Begin
  212.                                SetThreadPriority(StartThread(LineProc, 2000, Window, 0, 0), ts_DefPriority Div 2);
  213.                                NumThreads := GetNumThreads;
  214.                                WVSPrintf(Title, AppName + ' - %d Threads', Pointer(NumThreads));
  215.                                SetWindowText(Window, Title);
  216.                              End;
  217.  
  218.                        500 : InvalidateRect(Window, Nil,TRUE);                             
  219.                        510 : Begin
  220.                                EndTaskThreads(GetCurrentTask);
  221.                                InvalidateRect(Window, Nil,TRUE);
  222.                                NumThreads := GetNumThreads;
  223.                                WVSPrintf(Title, AppName + ' - %d Threads', Pointer(NumThreads));
  224.                                SetWindowText(Window, Title);
  225.                              End;
  226.                      End;
  227.       wm_Destroy   : Begin
  228.                        EndTaskThreads(GetCurrentTask);
  229.                        FreeProcInstance(BallProc);
  230.                        FreeProcInstance(LineProc);
  231.  
  232.                        PostQuitMessage(0);
  233.                      End;
  234.     Else
  235.       MainWndProc := DefWindowProc(Window, Msg, wParam, lParam);
  236.     End;
  237.   End; {MainWndProc}
  238.  
  239.  
  240.  
  241. Const
  242.   WindowClass : TWndClass = (Style         : cs_HRedraw + cs_VRedraw;
  243.                              lpfnWndProc   : Nil;
  244.                              cbClsExtra    : 0;
  245.                              cbWndExtra    : 0;
  246.                              hInstance     : 0;
  247.                              hIcon         : 0;
  248.                              hCursor       : 0;
  249.                              hbrBackground : 0;
  250.                              lpszMenuName  : 'APPMENU';
  251.                              lpszClassName : ClassName);
  252.  
  253.  
  254. Begin
  255.   RandSeed := MakeLong(((GetCurrentTime SHR 16) SHL 16), ((GetCurrentTime SHR 16) SHL 16));
  256.   If (HPrevInst = 0) Then
  257.     Begin
  258.       WindowClass.lpfnWndProc   := @MainWndProc;
  259.       WindowClass.hInstance     := HInstance;
  260.       WindowClass.hIcon         := LoadIcon(0, idi_Application);
  261.       WindowClass.hCursor       := LoadCursor(0, idc_Arrow);
  262.       WindowClass.hbrBackground := GetStockObject(white_Brush);
  263.  
  264.       If Not RegisterClass(WindowClass) Then
  265.         Begin
  266.           MessageBox(0, 'Unable to register window class.', Nil, mb_Ok Or mb_IconStop);
  267.           Halt;
  268.         End;
  269.     End;
  270.  
  271.   Wnd := CreateWindow(ClassName, AppName + ' - 0 Threads', ws_OverlappedWindow,
  272.                       cw_UseDefault, 0, cw_UseDefault, 0, 0, 0, HInstance, Nil);
  273.   If (Wnd <> 0) Then
  274.     Begin
  275.       ShowWindow(Wnd, sw_ShowNormal);
  276.       UpdateWindow(Wnd);
  277.  
  278. {$IFNDEF FASTDEMO}
  279.       While GetMessage(Msg, 0, 0, 0) Do
  280.         Begin
  281.           TranslateMessage(Msg);
  282.           DispatchMessage(Msg);
  283.         End;
  284. {$ELSE}
  285.       AllDone := False;
  286.       Repeat
  287.         If PeekMessage(Msg, 0, 0, 0, pm_NoRemove) Then
  288.           Begin
  289.             If GetMessage(Msg, 0, 0, 0) Then
  290.               Begin
  291.                 TranslateMessage(Msg);
  292.                 DispatchMessage(Msg);
  293.               End
  294.             Else
  295.               AllDone := True;
  296.           End
  297.         Else
  298.           ExecTaskThreads(GetCurrentTask);
  299.       Until AllDone;
  300. {$ENDIF}
  301.     End
  302.   Else
  303.     MessageBox(0, 'Unable to open window.', Nil, mb_Ok or mb_IconStop);
  304. End. {ThreadsTest}
  305.