home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / pascal / library / windows / animat / animate.pas < prev    next >
Pascal/Delphi Source File  |  1994-06-05  |  7KB  |  222 lines
  1. program Animate;
  2.  
  3. {$R Animate}
  4.  
  5. {This is an example to create a fast, smooth and flickerfree
  6.  animation. It uses 2 bitmaps for the sprite (the ball). One bitmap
  7.  is black in the transparent part, the other is white in the transparent
  8.  part. To keep it simple all parameters are hardcoded.
  9.  
  10.  Requires BP 7.0.
  11.  
  12.  Uploaded by the Autor: Hans Steinegger 100024,2730, June 4, 1994}
  13.  
  14. uses
  15.   WinTypes, WinProcs, Objects, OMemory, OWindows, ODialogs, Strings;
  16.  
  17. const
  18.   rBall = 14;
  19.   Speed = 150;  {number of moves in 550 ms}
  20.   Dist = 1;     {distance for 1 move}
  21. type
  22.   tApp = object (TApplication)
  23.     procedure InitMainWindow; virtual;
  24.     function IdleAction: boolean; virtual;
  25.   end;
  26.  
  27.   PMainWindow = ^TMainWindow;
  28.   TMainWindow = object (TWindow)
  29.     nUpdate, UpdateCount, MulDivVar: integer;
  30.     BallPos: tPoint;
  31.     HorDir, VerDir: boolean;
  32.     Background1, Background2, BallOr, BallAnd: hBitMap;
  33.     Old1, Old2, Old3, Old4: hBitMap;
  34.     BG1DC, BG2DC, BallAndDC, BallOrDC: hDC;
  35.     constructor Init(AParent: PWindowsObject; Title: PChar);
  36.     procedure GetWindowClass (var WndClass: TWndClass); virtual;
  37.     procedure SetUpWindow; virtual;
  38.     destructor Done; virtual;
  39.     procedure Paint (PaintDC: HDC; var PaintInfo: TPaintStruct); virtual;
  40.     procedure WMTimer (var Message: tMessage); virtual wm_First + wm_Timer;
  41.     procedure UpdateBall;
  42.   end;
  43.  
  44. constructor TMainWindow.Init(AParent: PWindowsObject; Title: PChar);
  45. begin
  46.   TWindow.Init (AParent, Title);
  47.   Attr.W := 300;
  48.   Attr.H := 400;
  49.   Attr.Style := WS_Caption or WS_SysMenu or WS_MinimizeBox;
  50. end;
  51.  
  52. procedure TMainWindow.GetWindowClass (var WndClass: TWndClass);
  53. begin
  54.   TWindow.GetWindowClass(WndClass);
  55.   WndClass.hIcon := LoadIcon (hInstance, 'Animate');
  56. end;
  57.  
  58. procedure TMainWindow.SetupWindow;
  59. var
  60.   DC: hDC;
  61. begin
  62.   inherited SetupWindow;
  63.   BallPos.x := 100;
  64.   BallPos.y := 100;
  65.   DC := GetDC (hWindow);
  66.   {the number of memory DC's is not as critical so
  67.    we created 4 of them here and delete them in the
  68.    Done method. This improves the speed}
  69.   {we need 2 Background images}
  70.   Background1 := LoadBitMap (hInstance, 'Background');
  71.   BG1DC := CreateCompatibleDC (DC);
  72.   Old1 := SelectObject (BG1DC, Background1);
  73.   Background2 := LoadBitMap (hInstance, 'Background');
  74.   BG2DC := CreateCompatibleDC (DC);
  75.   Old2 := SelectObject (BG2DC, Background2);
  76.   {BallOr is the bitmap of the ball with black around the ball}
  77.   BallOr := LoadBitMap (hInstance, 'BallOr');
  78.   BallOrDC := CreateCompatibleDC (DC);
  79.   Old3 := SelectObject (BallOrDC, BallOr);
  80.   {BallAnd is the bitmap of the ball with white around the ball}
  81.   BallAnd := LoadBitMap (hInstance, 'BallAnd');
  82.   BallAndDC := CreateCompatibleDC (DC);
  83.   Old4 := SelectObject (BallAndDC, BallAnd);
  84.   ReleaseDC (hWindow, DC);
  85.   if SetTimer(HWindow, 1, 550, nil) = 0 then
  86.   begin
  87.     MessageBox(HWindow, 'No Timers Left', 'Error', mb_Ok);
  88.     Halt(1);
  89.   end;
  90.   nUpdate := 0;
  91.   UpdateCount := 0;
  92.   MulDivVar := 0;
  93. end;
  94.  
  95. destructor TMainWindow.Done;
  96. begin
  97.   KillTimer (hWindow, 1);
  98.   SelectObject (BG1DC, Old1);
  99.   DeleteDC (BG1DC);
  100.   SelectObject (BG2DC, Old2);
  101.   DeleteDC (BG2DC);
  102.   SelectObject (BallOrDC, Old3);
  103.   DeleteDC (BallOrDC);
  104.   SelectObject (BallAndDC, Old4);
  105.   DeleteDC (BallAndDC);
  106.   DeleteObject (Background1);
  107.   DeleteObject (Background2);
  108.   DeleteObject (BallOr);
  109.   DeleteObject (BallAnd);
  110.   inherited Done;
  111. end;
  112.  
  113. procedure TMainWindow.Paint(PaintDC: HDC;var PaintInfo: TPaintStruct);
  114. var
  115.   MemDC: hDC;
  116. begin
  117.   BitBlt (PaintDC, 0, 0, 300, 400, BG1DC, 0, 0, SrcCopy);
  118.   DeleteDC (MemDC);
  119. end;
  120.  
  121. procedure TMainWindow.WMTimer (var Message: TMessage);
  122. begin
  123.   {The minimum timer interval (55 ms) is too slow for a smooth
  124.    movement. Therefore IdleAction is used to initiate the
  125.    movement of the ball. But this 550 ms timer is used for
  126.    speed control}
  127.   nUpdate := UpdateCount;
  128.   UpdateCount := 0;
  129. end;
  130.  
  131. procedure TMainWindow.UpdateBall;
  132. var
  133.   x1, y1, x2, y2: integer;
  134.   Move: boolean;
  135.   DC: hDC;
  136.   OldPos: tPoint;
  137.   ClientRect: tRect;
  138. begin
  139.   OldPos := BallPos;
  140.   inc (UpdateCount);
  141.   {First thing is to check if we have to move the ball.
  142.    A Multiply/Divide algorithm is realized with Add/Subtract}
  143.   Move := false;
  144.   if Speed >= nUpdate then Move := true
  145.   else
  146.   begin
  147.     dec (MulDivVar, Speed div Dist);
  148.     if MulDivVar < 0 then
  149.     begin
  150.       inc (MulDivVar, nUpdate);
  151.       Move := true;
  152.     end;
  153.   end;
  154.   if Move then
  155.   begin
  156.     {Check if we reached a border and invert direction
  157.      if necessary}
  158.     GetClientRect (hWindow, ClientRect);
  159.     if not HorDir and (BallPos.x - rBall <= 0) then HorDir := true;
  160.     if HorDir and (BallPos.x + rBall >= ClientRect.right) then HorDir := false;
  161.     if not VerDir and (BallPos.y - rBall <= 0) then VerDir := true;
  162.     if VerDir and (BallPos.y + rBall >= ClientRect.bottom) then VerDir := false;
  163.     {Calculate new ball position}
  164.     if HorDir then inc (BallPos.x, Dist) else dec (BallPos.x, Dist);
  165.     if VerDir then inc (BallPos.y, Dist) else dec (BallPos.y, Dist);
  166.   end;
  167.   DC := GetDC(HWindow);
  168.   {Now we prepare all in BG2DC}
  169.   {We erase the ball in the old position}
  170.   BitBlt (BG2DC, OldPos.x - rBall, OldPos.y - rBall, 2 * rBall, 2 * rBall,
  171.           BG1DC, OldPos.x - rBall, OldPos.y - rBall, SrcCopy);
  172.   {We or with the BallOrDC}
  173.   BitBlt (BG2DC, BallPos.x - rBall, BallPos.y - rBall, 2 * rBall, 2 * rBall,
  174.           BallOrDC, 0, 0, SrcPaint);
  175.   {We and with the BallAndDC}
  176.   BitBlt (BG2DC, BallPos.x - rBall, BallPos.y - rBall, 2 * rBall, 2 * rBall,
  177.           BallAndDC, 0, 0, SrcAnd);
  178.   {For optimized speed we calculate the rectangle to be updated on screen}
  179.   if BallPos.x > OldPos.x then
  180.   begin
  181.     x1 := OldPos.x - rBall;
  182.     x2 := BallPos.x + rBall;
  183.   end
  184.   else
  185.   begin
  186.     x1 := BallPos.x - rBall;
  187.     x2 := OldPos.x + rBall;
  188.   end;
  189.   if BallPos.y > OldPos.y then
  190.   begin
  191.     y1 := OldPos.y - rBall;
  192.     y2 := BallPos.y + rBall;
  193.   end
  194.   else
  195.   begin
  196.     y1 := BallPos.y - rBall;
  197.     y2 := OldPos.y + rBall;
  198.   end;
  199.   {And update the region including the old and the new ball position}
  200.   BitBlt (DC, x1, y1, x2 - x1, y2 - y1, BG2DC, x1, y1, SrcCopy);
  201.   ReleaseDC (hWindow, DC);
  202. end;
  203.  
  204. procedure TApp.InitMainWindow;
  205. begin
  206.   MainWindow := New (PMainWindow, Init (nil, 'Animate'));
  207. end;
  208.  
  209. function tApp.IdleAction: boolean;
  210. begin
  211.   pMainWindow (MainWindow)^.UpdateBall;
  212.   IdleAction := true;
  213. end;
  214.  
  215. var
  216.   App: TApp;
  217. begin
  218.   App.Init ('Animate');
  219.   App.Run;
  220.   App.Done;
  221. end.
  222.