home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / pascal / tpw / owldemos / gdidemo.pas < prev    next >
Pascal/Delphi Source File  |  1991-05-20  |  29KB  |  980 lines
  1. {************************************************}
  2. {                                                }
  3. {   Turbo Pascal for Windows                     }
  4. {   Demo program                                 }
  5. {   Copyright (c) 1991 by Borland International  }
  6. {                                                }
  7. {************************************************}
  8.  
  9. program GDIDemo;
  10.  
  11. uses WinProcs, WinTypes, WObjects, Strings;
  12.  
  13. {$R GDIDEMO.RES}
  14.  
  15. { Menu bar constants }
  16. const
  17.   MenuID              = 100; { Resource ID of the menu }
  18.   QuitID              = 100; { File->Quit ID }
  19.   MoveToLineToDemoID  = 200; { Demo->MoveToDemo ID }
  20.   FontDemoID          = 202; { Demo->Font Demo ID }
  21.   BitBltDemoID        = 203; { Demo->BitBlt Demo ID }
  22.   ArtyDemoID          = 204; { Demo->Arty Demo ID }
  23.  
  24. { BitBlt demo constants }
  25. const
  26.   BackgroundID        = 100; { Bitmap ID of background bitmap }
  27.   ShipID              = 101; { Bitmap ID of Ship Bitmap }
  28.   MonoShipID          = 102; { Bitmap ID of Monochrome mask of ship }
  29.   BitmapSize          = 72;  { Size of Ship bitmap }
  30.  
  31. { Font demo constants }
  32. const
  33.   MaxNumFonts =  20; { Maximum number of fonts to be displayed in FontDemo }
  34.  
  35. { MoveToLineTo demo constants }
  36. const
  37.   MaxPoints   =  15; { Number of points to be drawn in MoveToLineToDemo }
  38.  
  39. { Arty demo constants }
  40. const
  41.    MaxLineCount  = 100;
  42.    MaxIconicLineCount = 5;
  43.    MaxColorDuration = 10;
  44.  
  45. function Min(X, Y: Integer): Integer;
  46. begin
  47.   if X > Y then Min := Y else Min := X;
  48. end;
  49.  
  50. { TBaseDemoWindow -------------------------------------------------- }
  51.  
  52. type
  53.   PBaseDemoWindow = ^TBaseDemoWindow;
  54.   TBaseDemoWindow = object(TWindow)
  55.     procedure TimerTick; virtual;
  56.   end;
  57.  
  58. { Trivial method that gets called whenever application receives a
  59.   WM_Timer.  Descendants will override this procedure if they need
  60.   timer messages.}
  61. procedure TBaseDemoWindow.TimerTick;
  62. begin
  63. end;
  64.  
  65. { TNoIconWindow --------------------------------------------------- }
  66.  
  67. type
  68.   PNoIconWindow = ^TNoIconWindow;
  69.   TNoIconWindow = object(TBaseDemoWindow)
  70.     procedure GetWindowClass(var AWndClass: TWndClass);  virtual;
  71.     function GetClassName: PChar;  virtual;
  72.   end;
  73.  
  74. { Alter the default window class record to make this window have
  75.   a black background and no "white box" icon.  }
  76. procedure TNoIconWindow.GetWindowClass(var AWndClass: TWndClass);
  77. begin
  78.   TBaseDemoWindow.GetWindowClass(AWndClass);
  79.   AWndClass.hbrBackground := GetStockObject(Black_Brush);
  80.   AWndClass.hIcon := 0;
  81. end;
  82.  
  83. { No need to call the ancestor's method here, since we want to
  84.   provide an entirely new window class name. }
  85. function TNoIconWindow.GetClassName: PChar;
  86. begin
  87.   GetClassName := 'NoIconWindow';
  88. end;
  89.  
  90. { TMoveToLineToWindow --------------------------------------------- }
  91.  
  92. type
  93.   TRPoint = record
  94.     X, Y: Real;
  95.   end;
  96.  
  97. type
  98.   PMoveToLineToWindow = ^TMoveToLineToWindow;
  99.   TMoveToLineToWindow = object(TBaseDemoWindow)
  100.     Points: array[0..MaxPoints] of TRPoint;
  101.     constructor Init(AParent: PWindowsObject; ATitle: PChar);
  102.     procedure Paint(PaintDC: HDC; var PaintInfo: TPaintStruct); virtual;
  103.   end;
  104.  
  105. constructor TMoveToLineToWindow.Init(AParent: PWindowsObject; ATitle: PChar);
  106. var
  107.   I: Integer;
  108.   StepAngle: Integer;
  109.   Radians: Real;
  110. begin
  111.   TBaseDemoWindow.Init(AParent, ATitle);
  112.   StepAngle := 360 div MaxPoints;
  113.   for I := 0 to MaxPoints - 1 do
  114.   begin
  115.     Radians := (StepAngle * I) * PI / 180;
  116.     Points[I].x := Cos(Radians);
  117.     Points[I].y := Sin(Radians);
  118.   end;
  119. end;
  120.  
  121. procedure TMoveToLinetoWindow.Paint(PaintDC: HDC;
  122.   var PaintInfo: TPaintStruct);
  123. var
  124.   TheRect: TRect;
  125.   I, J: Integer;
  126.   CenterX,
  127.   CenterY: Integer;
  128.   Radius,
  129.   StepAngle: Word;
  130.   Radians: real;
  131. begin
  132.   GetClientRect(HWindow,TheRect);
  133.   CenterX := TheRect.Right div 2;
  134.   CenterY := TheRect.Bottom div 2;
  135.   Radius := Min(CenterY, CenterX);
  136.   Ellipse(PaintDC,CenterX - Radius, CenterY - Radius, CenterX + Radius,
  137.     CenterY + Radius);
  138.   for I := 0 to MaxPoints - 1 do
  139.   begin
  140.     for J := I + 1 to MaxPoints - 1 do
  141.     begin
  142.       MoveTo(PaintDC, CenterX + Round(Points[I].X * Radius),
  143.     CenterY + Round(Points[I].Y * Radius));
  144.       LineTo(PaintDC, CenterX + Round(Points[J].X * Radius),
  145.     CenterY + Round(Points[J].Y * Radius));
  146.     end;
  147.   end;
  148. end;
  149.  
  150. { TFontWindow ------------------------------------------------------ }
  151.  
  152. type
  153.   FontInfoRec = record
  154.     Handle: HFont;  { Handle to logical font }
  155.     Height: Byte;   { Height of logical font in pixels }
  156.     Width: LongInt; { Width of name of the font in pixels }
  157.     Name: array[0..lf_FaceSize-1] of char; { Name of this font }
  158.   end;
  159.  
  160. const
  161.   FontUsers: Integer = 0;
  162. var
  163.   FontInfo: array[0..MaxNumFonts] of FontInfoRec;
  164.   NumFonts: Integer; { Number of system fonts available }
  165.   TheDC: HDC;
  166.  
  167. type
  168.   PFontWindow = ^TFontWindow;
  169.   TFontWindow = object(TBaseDemoWindow)
  170.     FontsHeight: LongInt;
  171.     FontsWidth: LongInt;
  172.     constructor Init(AParent: PWindowsObject; ATitle: PChar);
  173.     procedure Paint(PaintDC: HDC; var PaintInfo: TPaintStruct); virtual;
  174.     procedure Destroy; virtual;
  175.     procedure WMSize(var Msg: TMessage);
  176.       virtual wm_First + wm_Size;
  177.   end;
  178.  
  179. { EnumerateFont is a call back function.  It receives information
  180.   about system fonts.  It creates an example of each font by calling
  181.   CreateFont when MaxNumFonts have been processed, 0 is returned
  182.   notifying windows to stop sending information, otherwise 1 is
  183.   returned telling windows to send more information if available }
  184. function EnumerateFont(var LogFont: TLogFont; TextMetric: PTextMetric;
  185.   FontType: Integer; Data: PChar): Integer; export;
  186. var
  187.   OldFont: HFont;
  188. begin
  189.   { Create the font described by LogFont }
  190.   FontInfo[NumFonts].Handle := CreateFontIndirect(LogFont);
  191.   with LogFont do
  192.   begin
  193.     { Save the height of the font for positioning when drawing in
  194.       the window }
  195.     FontInfo[NumFonts].Height := lfHeight;
  196.     { Save the name of the font for drawing in the window }
  197.     StrCopy(FontInfo[NumFonts].Name, lfFaceName);
  198.     OldFont := SelectObject(TheDC, FontInfo[NumFonts].Handle);
  199.     FontInfo[NumFonts].Width := Word(GetTextExtent(TheDC, lfFaceName,
  200.       StrLen(lfFaceName)));
  201.     SelectObject(TheDC, OldFont);
  202.   end;
  203.   Inc(NumFonts);
  204.   if NumFonts > MaxNumFonts then
  205.     EnumerateFont := 0 { Don't send any more information }
  206.   else
  207.     EnumerateFont := 1; { Send more information if available }
  208. end;
  209.  
  210. { Collect all of the system fonts }
  211. procedure GetFontInfo;
  212. var
  213.   EnumProc: TFarProc;
  214. begin
  215.   if FontUsers = 0 then
  216.   begin
  217.     TheDC := GetDC(GetFocus);
  218.     NumFonts := 0;
  219.     { Create an instance of the call back function.  This allows
  220.       our program to refer to an exported function.  Otherwise the
  221.       Data segment will not be correct. }
  222.     EnumProc := MakeProcInstance(@EnumerateFont, HInstance);
  223.     { Gather information about all fonts that are allowable in our window (DC) }
  224.     EnumFonts(TheDC, nil, EnumProc, nil);
  225.     { Free the instance of our call back function }
  226.     FreeProcInstance(EnumProc);
  227.     ReleaseDC(GetFocus, TheDC);
  228.   end;
  229.   Inc(FontUsers);
  230. end;
  231.  
  232. { Release font information }
  233. procedure ReleaseFontInfo;
  234. var
  235.   I: Integer;
  236. begin
  237.   Dec(FontUsers);
  238.   if FontUsers = 0 then
  239.     for I := 0 to NumFonts - 1 do
  240.       DeleteObject(FontInfo[I].Handle);
  241. end;
  242.  
  243. { Initialize object and collect font information }
  244. constructor TFontWindow.Init(AParent: PWindowsObject; ATitle: PChar);
  245. var
  246.   I: Integer;
  247.  
  248. function Max(I, J: LongInt): LongInt;
  249. begin
  250.   if I > J then Max := I else Max := J;
  251. end;
  252.  
  253. begin
  254.   TBaseDemoWindow.Init(AParent, ATitle);
  255.   GetFontInfo;
  256.   Attr.Style := Attr.Style or ws_VScroll or ws_HScroll;
  257.   FontsHeight := 0;
  258.   FontsWidth := 0;
  259.   for I := 0 to NumFonts - 1 do
  260.   begin
  261.     Inc(FontsHeight, FontInfo[I].Height);
  262.     FontsWidth := Max(FontsWidth, FontInfo[I].Width);
  263.   end;
  264.   Scroller := New(PScroller, Init(@Self, 1, 1, 0, 0));
  265. end;
  266.  
  267. { Draw each font name in it's font in the Display context.  Each
  268.   line is incremented by the height of the font }
  269. procedure TFontWindow.Paint(PaintDC: HDC; var PaintInfo: TPaintStruct);
  270. var
  271.   I: Integer;
  272.   Position: Integer;
  273. begin
  274.   Position := 0;
  275.   for I := 0 to NumFonts - 1 do
  276.   begin
  277.     SelectObject(PaintDC, FontInfo[I].Handle);
  278.     TextOut(PaintDC, 10, Position, FontInfo[I].Name,
  279.       StrLen(FontInfo[I].Name));
  280.     Inc(Position, FontInfo[I].Height);
  281.   end;
  282. end;
  283.  
  284. procedure TFontWindow.Destroy;
  285. var
  286.   I: Integer;
  287. begin
  288.   TBaseDemoWindow.Destroy;
  289.   ReleaseFontInfo;
  290. end;
  291.  
  292. procedure TFontWindow.WMSize(var Msg: TMessage);
  293. begin
  294.   TWindow.WMSize(Msg);
  295.   if Scroller <> nil then
  296.     Scroller^.SetRange(FontsWidth - Msg.lParamLo + 10,
  297.       FontsHeight - Msg.lParamHi);
  298. end;
  299.  
  300. { TBitBltWindow ---------------------------------------------------- }
  301.  
  302. type
  303.   PBitBltWindow = ^TBitBltWindow;
  304.   TBitBltWindow = object(TNoIconWindow)
  305.     WindowSize: TPoint;
  306.     ScratchBitmap,
  307.     StretchedBkgnd,
  308.     Background,
  309.     MonoShip,
  310.     Ship: HBitmap;
  311.     OldX, OldY,
  312.     Delta,
  313.     X, Y: Integer;
  314.     CurClick: Integer;
  315.     constructor Init(AParent: PWindowsObject; ATitle: PChar);
  316.     destructor Done; virtual;
  317.     procedure WMSize(var Message: TMessage); virtual WM_Size;
  318.     procedure WMPaint(var Message: TMessage); virtual WM_Paint;
  319.     procedure Paint(PaintDC: HDC; var PaintInfo: TPaintStruct); virtual;
  320.     procedure SetupWindow; virtual;
  321.     procedure TimerTick; virtual;
  322.     procedure CalculateNewXY;
  323.   end;
  324.  
  325. { Initialize the bitblt demo window and allocate bitmaps }
  326. constructor TBitBltWindow.Init(AParent: PWindowsObject; ATitle: PChar);
  327. begin
  328.   TNoIconWindow.Init(AParent, ATitle);
  329.   Background := LoadBitmap(HInstance, MakeIntResource(BackgroundID));
  330.   Ship := LoadBitmap(HInstance, MakeIntResource(ShipID));
  331.   MonoShip := LoadBitmap(HInstance, MakeIntResource(MonoShipID));
  332.   ScratchBitmap := 0;
  333.   StretchedBkgnd := 0;
  334.   OldX := 0;
  335.   OldY := 0;
  336.   X := 0;
  337.   Y := 0;
  338.   Delta := 5;
  339.   CurClick := 1;
  340. end;
  341.  
  342. { Dispose of all used resources }
  343. destructor TBitBltWindow.Done;
  344. begin
  345.   DeleteObject(Background);
  346.   DeleteObject(Ship);
  347.   DeleteObject(MonoShip);
  348.   if ScratchBitmap <> 0 then DeleteObject(ScratchBitmap);
  349.   if StretchedBkgnd <> 0 then DeleteObject(StretchedBkgnd);
  350.   TNoIconWindow.Done;
  351. end;
  352.  
  353. { Allocate scratch bitmaps }
  354. procedure TBitBltWindow.SetupWindow;
  355. var
  356.   HandleDC: HDC;
  357. begin
  358.   TNoIconWindow.SetupWindow;
  359.   HandleDC := GetDC(HWindow);
  360.   ScratchBitmap := CreateCompatibleBitmap(HandleDC, 80, 80);
  361.   StretchedBkgnd := CreateCompatibleBitmap(HandleDC, 1000, 1000);
  362.   ReleaseDC(HWindow, HandleDC);
  363. end;
  364.  
  365. { Record the new size and stretch the background to it }
  366. procedure TBitBltWindow.WMSize(var Message: TMessage);
  367. var
  368.   HandleDC, MemDC, StretchedDC: HDC;
  369.   StretchObject, MemObject: THandle;
  370.   PS: TPaintStruct;
  371.   OldCur: HCursor;
  372. begin
  373.   TNoIconWindow.WMSize(Message);
  374.   WindowSize.X := Message.LParamLo;
  375.   WindowSize.Y := Message.LParamHi;
  376.  
  377.   HandleDC := GetDC(HWindow);
  378.  
  379.   { Create a stretched to fit background }
  380.   StretchedDC := CreateCompatibleDC(HandleDC);
  381.   MemDC := CreateCompatibleDC(HandleDC);
  382.   StretchObject := SelectObject(StretchedDC, StretchedBkgnd);
  383.   MemObject := SelectObject(MemDC, Background);
  384.   OldCur := SetCursor(LoadCursor(0, idc_Wait));
  385.   with WindowSize do
  386.     StretchBlt(StretchedDC, 0, 0, X, Y, MemDC, 0, 0, 100, 100, SrcCopy);
  387.   SetCursor(OldCur);
  388.   SelectObject(StretchedDC, StretchObject);
  389.   SelectObject(MemDC, MemObject);
  390.   DeleteDC(MemDC);
  391.   DeleteDC(StretchedDC);
  392.   ReleaseDC(HWindow, HandleDC);
  393. end;
  394.  
  395. { Need to ensure that the Old copy of the ship gets redrawn with
  396.   any paint messages. }
  397. procedure TBitBltWindow.WMPaint(var Message: TMessage);
  398. var
  399.   Rect: TRect;
  400. begin
  401.   Rect.Top := OldY;
  402.   Rect.Left := OldX;
  403.   Rect.Bottom := OldY+BitmapSize;
  404.   Rect.Right := OldX+BitmapSize;
  405.   InvalidateRect(HWindow, @Rect, False);
  406.   TNoIconWindow.WMPaint(Message);
  407. end;
  408.  
  409. procedure TBitBltWindow.Paint(PaintDC: HDC; var PaintInfo: TPaintStruct);
  410. var
  411.   MemDC: HDC;
  412.   MemObject: THandle;
  413. begin
  414.   MemDC := CreateCompatibleDC(PaintDC);
  415.   MemObject := SelectObject(MemDC, StretchedBkgnd);
  416.   with WindowSize do
  417.     BitBlt(PaintDC, 0, 0, X, Y, MemDC, 0, 0, SrcCopy);
  418.   SelectObject(MemDC, MemObject);
  419.   DeleteDC(MemDC);
  420. end;
  421.  
  422. { TimerTick deletes the old position of the saucer and blt's a new one }
  423. procedure TBitBltWindow.TimerTick;
  424. const
  425.   ClicksToSkip = 4;
  426. var
  427.   Bits, BackingStore, WindowDC: HDC;
  428.   SavedBitsObject, SavedStoreObject: THandle;
  429.   BX, BY, OX, OY, BH, BW: Integer;
  430. begin
  431.   { Make the saucer go slower then everyone else }
  432.   if CurClick < ClicksToSkip then
  433.   begin
  434.     Inc(CurClick);
  435.     Exit;
  436.   end
  437.   else CurClick := 1;
  438.  
  439.   TNoIconWindow.TimerTick;
  440.  
  441.   { Setup the DC's }
  442.   WindowDC := GetDC(HWindow);
  443.   Bits := CreateCompatibleDC(WindowDC);
  444.   BackingStore := CreateCompatibleDC(WindowDC);
  445.  
  446.   CalculateNewXY;
  447.  
  448.   { Calulate the offsets into and dimentions of the backing store }
  449.   BX := Min(X, OldX);
  450.   BY := Min(Y, OldY);
  451.   OX := Abs(X - BX);
  452.   OY := Abs(Y - BY);
  453.   BW := 72 + Abs(OldX - X);
  454.   BH := 72 + Abs(OldY - Y);
  455.  
  456.   { Create an image into the backing store the will that, when blt into
  457.     the window will both erase the old image and draw the new one. }
  458.   SavedStoreObject := SelectObject(BackingStore, ScratchBitmap);
  459.   SavedBitsObject := SelectObject(Bits, StretchedBkgnd);
  460.   BitBlt(BackingStore, 0, 0, BW, BH, Bits, BX, BY, srcCopy);
  461.   SelectObject(Bits, MonoShip);
  462.   BitBlt(BackingStore, OX, OY, 72, 72, Bits, 0, 0, SrcAnd);
  463.   SelectObject(Bits, Ship);
  464.   BitBlt(BackingStore, OX, OY, 72, 72, Bits, 0, 0, SrcPaint);
  465.  
  466.   { Blt the backing store to the window }
  467.   BitBlt(WindowDC, BX, BY, BW, BH, BackingStore, 0, 0, SrcCopy);
  468.  
  469.   { Clean up the DC's }
  470.   SelectObject(Bits, SavedBitsObject);
  471.   SelectObject(BackingStore, SavedStoreObject);
  472.   DeleteDC(Bits);
  473.   DeleteDC(BackingStore);
  474.   ReleaseDC(HWindow, WindowDC);
  475.  
  476.   OldX := X;
  477.   OldY := Y;
  478. end;
  479.  
  480. procedure TBitBltWindow.CalculateNewXY;
  481. begin
  482.   if WindowSize.X < BitmapSize then Exit;  { Don't move if too small }
  483.   if (X > WindowSize.X - BitmapSize) or (X < 0) then
  484.   begin
  485.     Delta := -Delta;
  486.     if X > WindowSize.X - BitmapSize then
  487.       X := WindowSize.X - BitmapSize - 5;
  488.   end;
  489.   X := X + Delta;
  490.   Y := Y + Integer(Random(10)) - 5;
  491.   if Y > WindowSize.Y - BitmapSize then Y := WindowSize.Y - BitmapSize
  492.   else if Y < 0 then Y := 0;
  493. end;
  494.  
  495. { TArtyWindow ------------------------------------------------------ }
  496.  
  497. type
  498.   TLineRec = record
  499.     LX1,LY1: Integer;
  500.     LX2,LY2: Integer;
  501.     Color: Longint;
  502.   end;
  503.  
  504.   PLineList = ^TLineList;
  505.   TLineList = array[1..MaxLineCount] of TLineRec;
  506.  
  507.   PList = ^TList;
  508.   TList = object(TObject)
  509.     Line: PLineList;
  510.     MaxLines,
  511.     Xmax, Ymax,
  512.     X1, Y1, X2, Y2,
  513.     MaxDelta,
  514.     ColorDuration,
  515.     IncrementCount,
  516.     DeltaX1, DeltaY1, DeltaX2, DeltaY2,
  517.     CurrentLine: Integer;
  518.     PenColor: Longint;
  519.     Paused: Boolean;
  520.     constructor Init(Max: Integer);
  521.     destructor Done;  virtual;
  522.     procedure AdjustX(var X, DeltaX: Integer);
  523.     procedure AdjustY(var Y, DeltaY: Integer);
  524.     procedure Draw(DC: HDC; a1, b1, a2, b2: Integer; lPenColor: Longint);
  525.     procedure DrawLine(DC: HDC; Index: Integer);  virtual;
  526.     procedure EraseLine(DC: HDC; Index: Integer); virtual;
  527.     procedure Redraw(DC: HDC);
  528.     procedure ResetLines;
  529.     procedure ScaleTo(NewXmax, NewYmax: Integer);
  530.     procedure SelectNewColor;
  531.     procedure SelectNewDeltaValues;
  532.     procedure LineTick(DC: HDC);
  533.   end;
  534.  
  535.   PQuadList = ^TQuadList;
  536.   TQuadList = object(TList)   { Quads draw 4 reflections of each line }
  537.     procedure DrawLine(DC: HDC; Index: Integer);  virtual;
  538.     procedure EraseLine(DC: HDC; Index: Integer);  virtual;
  539.   end;
  540.  
  541.   PArtyWindow = ^TArtyWindow;
  542.   TArtyWindow = object(TNoIconWindow)
  543.     List,
  544.     BigLineList,
  545.     IconicLineList : PList;
  546.     TextHeight: Integer;
  547.     Iconized : Boolean;
  548.     StaticControl: PStatic;
  549.     constructor Init(aParent: PWindowsObject; aTitle: PChar);
  550.     destructor Done;  virtual;
  551.     procedure Paint(PaintDC: HDC; var PaintInfo: TPaintStruct); virtual;
  552.     procedure WMLButtonDown(var Message: TMessage);
  553.       virtual wm_First + wm_LButtonDown;
  554.     procedure WMRButtonDown(var Message: TMessage);
  555.       virtual wm_First + wm_RButtonDown;
  556.     procedure WMSize(var Msg: TMessage);
  557.       virtual wm_First + wm_Size;
  558.     procedure TimerTick; virtual;
  559.   end;
  560.  
  561. { Initialize the list-of-lines object }
  562. constructor TList.Init(Max: Integer);
  563. begin
  564.   TObject.Init;
  565.   If Max > MaxLineCount then
  566.     Max := MaxLineCount;
  567.  
  568.   { Don't change MaxLines!  It will be used to free memory in Done}
  569.   MaxLines := Max;
  570.   GetMem(Line, SizeOf(TLineRec) * MaxLines);
  571.   CurrentLine := 1;
  572.   Xmax := 0;
  573.   Ymax := 0;
  574.   ColorDuration := MaxColorDuration;
  575.   IncrementCount := 0;
  576.   MaxDelta := 10;
  577.   PenColor := RGB(Random(256), Random(256), Random(256));
  578.   Paused := False;
  579. end;
  580.  
  581. destructor TList.Done;
  582. begin
  583.   FreeMem(Line, SizeOf(TLineRec) * MaxLines);
  584.   TObject.Done;
  585. end;
  586.  
  587. { Keep X within range, and reverse Delta if necessary to do so }
  588. procedure TList.AdjustX(var X, DeltaX: Integer);
  589. var
  590.   TestX: Integer;
  591. begin
  592.   TestX := X + DeltaX;
  593.   if (TestX < 1) or (TestX > Xmax) then
  594.   begin
  595.     TestX := X;
  596.     DeltaX := -DeltaX;
  597.   end;
  598.   X := TestX;
  599. end;
  600.  
  601. { Keep Y within range, and reverse Delta if necessary to do so }
  602. procedure TList.AdjustY(var Y,DeltaY: Integer);
  603. var
  604.   TestY: Integer;
  605. begin
  606.   TestY := Y + DeltaY;
  607.   if (TestY < 1) or (TestY > Ymax) then
  608.   begin
  609.     TestY := Y;
  610.     DeltaY := -DeltaY;
  611.   end;
  612.   Y := TestY;
  613. end;
  614.  
  615. { Clear the array of lines }
  616. procedure TList.ResetLines;
  617. var
  618.   StartX, StartY, I: Integer;
  619. begin
  620.   StartX := Xmax div 2;
  621.   StartY := Ymax div 2;
  622.   for I := 1 to MaxLines do
  623.     with Line^[I] do
  624.     begin
  625.       LX1 := StartX; LX2 := StartX;
  626.       LY1 := StartY; LY2 := StartY;
  627.       Color := 0;
  628.     end;
  629.   X1 := StartX;
  630.   X2 := StartX;
  631.   Y1 := StartY;
  632.   Y2 := StartY;
  633. end;
  634.  
  635. { Scale the old line coordinates to the new Xmax and Ymax coordinates.
  636.   The new Xmax and new Ymax are passed in as parameters so we can
  637.   calculate the scaling ratios. }
  638. procedure TList.ScaleTo(NewXmax, NewYMax: Integer);
  639. var
  640.   I: Integer;
  641.   RatioX, RatioY: Real;
  642. begin
  643.   if (Xmax = 0) or (Ymax = 0) then { at startup, Xmax and Ymax are zero }
  644.   begin
  645.     Xmax := NewXmax;
  646.     Ymax := NewYmax;
  647.     ResetLines;
  648.   end
  649.   else
  650.   begin
  651.     RatioX := NewXMax / Xmax;
  652.     RatioY := NewYmax / Ymax;
  653.     X1 := Trunc(X1 * RatioX);
  654.     X2 := Trunc(X2 * RatioX);
  655.     Y1 := Trunc(Y1 * RatioY);
  656.     Y2 := Trunc(Y2 * RatioY);
  657.     for I := 1 to MaxLines do
  658.       with Line^[I] do
  659.       begin
  660.     LX1 := Trunc(LX1 * RatioX);
  661.     LX2 := Trunc(LX2 * RatioX);
  662.     LY1 := Trunc(LY1 * RatioY);
  663.     LY2 := Trunc(LY2 * RatioY);
  664.       end;
  665.   end;
  666.   Xmax := NewXmax;
  667.   Ymax := NewYmax;
  668. end;
  669.  
  670. { The low-level Draw method of the object. }
  671. procedure TList.Draw(DC: HDC; a1, b1, a2, b2: Integer; lPenColor: Longint);
  672. var
  673.   OldPen: HPen;
  674. begin
  675.   OldPen := SelectObject(DC, CreatePen(PS_SOLID, 1, lPenColor));
  676.   MoveTo(DC, a1, b1);
  677.   LineTo(DC, a2, b2);
  678.   DeleteObject(SelectObject(DC, OldPen));
  679. end;
  680.  
  681. { The high-level Draw method of the object. }
  682. procedure TList.DrawLine(DC: HDC; Index: Integer);
  683. begin
  684.   with Line^[Index] do
  685.     Draw(DC, LX1, LY1, LX2, LY2, Color);
  686. end;
  687.  
  688. { The high-level draw which erases a line. }
  689. procedure TList.EraseLine(DC: HDC; Index: Integer);
  690. begin
  691.   with Line^[Index] do
  692.     Draw(DC, LX1, LY1, LX2, LY2, RGB(0, 0, 0));
  693. end;
  694.  
  695. { Redraw all the lines in the array. }
  696. procedure TList.Redraw(DC: HDC);
  697. var I: Integer;
  698. begin
  699.   for I := 1 to MaxLines do
  700.     DrawLine(DC, I);
  701. end;
  702.  
  703. { Reset the color counter and pick a random color. }
  704. procedure TList.SelectNewColor;
  705. begin
  706.   ColorDuration := MaxColorDuration;
  707.   PenColor := RGB(Random(256), Random(256), Random(256));
  708. end;
  709.  
  710. { Pick random directional deltas and reset the delta counter. }
  711. procedure TList.SelectNewDeltaValues;
  712. begin
  713.   DeltaX1 := Random(MaxDelta)-(MaxDelta Div 2);
  714.   DeltaX2 := Random(MaxDelta)-(MaxDelta Div 2);
  715.   DeltaY1 := Random(MaxDelta)-(MaxDelta Div 2);
  716.   DeltaY2 := Random(MaxDelta)-(MaxDelta Div 2);
  717.   IncrementCount := 2*(1+Random(10));
  718. end;
  719.  
  720. { Process the movement of one line. }
  721. procedure TList.LineTick(DC: HDC);
  722. begin
  723.     EraseLine(DC, CurrentLine);
  724.     if ColorDuration < 0 then SelectNewColor;
  725.     if IncrementCount=0 then SelectNewDeltaValues;
  726.     AdjustX(X1,DeltaX1); AdjustX(X2,DeltaX2);
  727.     AdjustY(Y1,DeltaY1); AdjustY(Y2,DeltaY2);
  728.     with Line^[CurrentLine] do
  729.     begin
  730.       LX1 := X1;  LX2 := X2;
  731.       LY1 := Y1;  LY2 := Y2;
  732.       Color := PenColor;
  733.     end;
  734.     DrawLine(DC, CurrentLine);
  735.     Inc(CurrentLine);
  736.     if CurrentLine > MaxLines then CurrentLine := 1;
  737.     Dec(ColorDuration);
  738.     Dec(IncrementCount);
  739. end;
  740.  
  741. { Draw the line and 3 reflections of it. }
  742. procedure TQuadList.DrawLine(DC: HDC; Index: Integer);
  743. begin
  744.   with Line^[Index] do
  745.   begin
  746.     Draw(DC,LX1,LY1,LX2,LY2,Color);
  747.     Draw(DC,Xmax-LX1,LY1,Xmax-LX2,LY2,Color);
  748.     Draw(DC,LX1,Ymax-LY1,LX2,Ymax-LY2,Color);
  749.     Draw(DC,Xmax-LX1,Ymax-LY1,Xmax-LX2,Ymax-LY2,Color);
  750.   end;
  751. end;
  752.  
  753. { Erase the line and 3 reflections of it. }
  754. procedure TQuadList.EraseLine(DC: HDC; Index: Integer);
  755. begin
  756.   with Line^[Index] do
  757.   begin
  758.     Draw(DC, LX1, LY1, LX2, LY2, RGB(0,0,0));
  759.     Draw(DC, Xmax-LX1, LY1,Xmax-LX2, LY2, RGB(0,0,0));
  760.     Draw(DC, LX1,Ymax-LY1, LX2, Ymax-LY2, RGB(0,0,0));
  761.     Draw(DC, Xmax-LX1, Ymax-LY1, Xmax-LX2, Ymax-LY2, RGB(0,0,0));
  762.   end;
  763. end;
  764.  
  765. constructor TArtyWindow.Init(AParent: PWindowsObject; ATitle: PChar);
  766. begin
  767.   TNoIconWindow.Init(AParent, ATitle);
  768.   StaticControl := New(PStatic,Init(@Self,100,
  769.     'Press Left Button to pause, Right Button to Clear',10,10,10,10,0));
  770.   Iconized := False;
  771.   TextHeight := 20;
  772.  
  773.   { Initialize two line list objects:
  774.       BigLineList is the 4-reflection artwork that is displayed in
  775.     a full sized window.  Mouse clicks will pause or clear
  776.     the display, and the line list will be scaled to the
  777.     new window coordinates when the window is resized.
  778.       IconicLineList is a smaller list implementing a single-line
  779.     quark to display in the iconized window region.  Since
  780.     mouse clicks are not sent to iconized windows, the icon
  781.     cannout be paused or cleared, and since there is only one
  782.     icon window size, scaling the lines to new coordinates
  783.     has no visual effect.
  784.     The List pointer will be toggled between the two line list
  785.     objects: when the window is iconized, List will point to the
  786.     IconicLineList object.  When the window is restored to full
  787.     size, List will be made to point to the BigLineList object.
  788.     This is so the window routines don't have to know which kind
  789.     of list they're dealing with.  Keyword: polymorphism.   }
  790.  
  791.   BigLineList := New(PQuadList, Init(MaxLineCount));
  792.   IconicLineList := New(PList, Init(MaxIconicLineCount));
  793.   List := BigLineList;
  794. end;
  795.  
  796. { Dispose of the objects that this window object created.  There's
  797.   no need to dispose the List pointer, since it will only point to
  798.   one of these two objects which are being disposed by their
  799.   primary pointers }
  800. destructor TArtyWindow.Done;
  801. begin
  802.   Dispose(BigLineList, Done);
  803.   Dispose(IconicLineList, Done);
  804.   TNoIconWindow.Done;
  805. end;
  806.  
  807. { When the window is resized, scale the line list to fit the new
  808.   window extent, or switch between full size and iconized window
  809.   states.  }
  810. procedure TArtyWindow.WMSize(var Msg: TMessage);
  811. var
  812.   NewXmax, NewYmax: Integer;
  813. begin
  814.   TNoIconWindow.WMSize(Msg);
  815.   { Force Windows to repaint the entire window region }
  816.   InvalidateRect(HWindow, nil, True);
  817.   NewXmax := Msg.LParamLo;
  818.   NewYmax := Msg.LParamHi;
  819.   if IsIconic(HWindow) then
  820.     if not Iconized then
  821.     begin
  822.       Iconized := True;
  823.       List := IconicLineList;
  824.     end
  825.     else
  826.   else
  827.   begin
  828.     if Iconized then
  829.     begin
  830.       Iconized := False;
  831.       List := BigLineList;
  832.     end;
  833.     Dec(NewYmax, TextHeight);  { allow room for the text at the bottom }
  834.   end;
  835.   List^.ScaleTo(NewXmax, NewYmax);  { scale the lines in the list }
  836.   MoveWindow(StaticControl^.HWindow, 0, NewYmax, NewXmax, TextHeight, True);
  837. end;
  838.  
  839. { Toggle the list object's Paused status.  Since the window will
  840.   not receive mouse clicks when iconized, this will not pause the
  841.   iconized lines display.  }
  842. procedure TArtyWindow.WMLButtonDown(var Message: TMessage);
  843. begin
  844.   List^.Paused := not List^.Paused;
  845. end;
  846.  
  847. { Clear the line list when the user presses the right mouse
  848.   button.  Same comments as above on iconized windows.  }
  849. procedure TArtyWindow.WMRButtonDown(var Message: TMessage);
  850. begin
  851.   InvalidateRect(HWindow,nil,True);
  852.   List^.ResetLines;
  853. end;
  854.  
  855. { When the window is resized, or some other window blots out part
  856.   of our client area, redraw the entire line list.  The PaintDC
  857.   is fetched before Paint is called and is released for us after
  858.   Paint is finished. }
  859. procedure TArtyWindow.Paint(PaintDC: HDC; var PaintInfo: TPaintStruct);
  860. begin
  861.   TNoIconWindow.Paint(PaintDC, PaintInfo);
  862.   List^.Redraw(PaintDC);
  863. end;
  864.  
  865. { Fetch a device context, pass it to the line list object, then
  866.   release the device context back to Windows.  }
  867. procedure TArtyWindow.TimerTick;
  868. var
  869.   DC: HDC;
  870. begin
  871.   if not List^.Paused then
  872.   begin
  873.     DC := GetDC(HWindow);
  874.     List^.LineTick(DC);
  875.     ReleaseDC(HWindow, DC);
  876.   end;
  877. end;
  878.  
  879. { TGDIDemoWindow --------------------------------------------------- }
  880.  
  881. type
  882.   PGDIDemoWindow = ^TGDIDemoWindow;
  883.   TGDIDemoWindow = object(TMDIWindow)
  884.     procedure SetupWindow; virtual;
  885.     procedure MoveToLineToDemo(var Msg: TMessage);
  886.       virtual cm_First + MoveToLineToDemoID;
  887.     procedure FontDemo(var Msg: TMessage);
  888.       virtual cm_First + FontDemoID;
  889.     procedure BitBltDemo(var Msg: TMessage);
  890.       virtual cm_First + BitBltDemoID;
  891.     procedure ArtyDemo(var Msg: TMessage);
  892.       virtual cm_First + ArtyDemoID;
  893.     procedure Quit(var Msg: TMessage);
  894.       virtual cm_First + QuitID;
  895.     procedure WMTimer(var Msg: TMessage);
  896.       virtual wm_First + wm_Timer;
  897.     procedure WMDestroy(var Msg: TMessage);
  898.       virtual wm_First + wm_Destroy;
  899.   end;
  900.  
  901. procedure TGDIDemoWindow.SetupWindow;
  902. var
  903.   Result: Integer;
  904. begin
  905.   TMDIWindow.SetupWindow;
  906.   Result := IDRetry;
  907.   while (SetTimer(hWIndow, 0, 50, nil) = 0) and (Result = IDRetry) do
  908.     Result := MessageBox(GetFocus,'Could not Create Timer', 'GDIDemo',
  909.       mb_RetryCancel);
  910.   if Result = IDCancel then PostQuitMessage(0);
  911. end;
  912.  
  913. procedure TGDIDemoWindow.MoveToLineToDemo(var Msg: TMessage);
  914. begin
  915.   Application^.MakeWindow(New(PMoveToLineToWindow, Init(@Self,
  916.     'MoveTo/LineTo Window')));
  917. end;
  918.  
  919. procedure TGDIDemoWindow.FontDemo(var Msg: TMessage);
  920. begin
  921.   Application^.MakeWindow(New(PFontWindow, Init(@Self, 'Font Window')));
  922. end;
  923.  
  924. procedure TGDIDemoWindow.BitBltDemo(var Msg: TMessage);
  925. begin
  926.   Application^.MakeWindow(New(PBitBltWindow, Init(@Self, 'BitBlt Window')));
  927. end;
  928.  
  929. procedure TGDIDemoWindow.ArtyDemo(var Msg: TMessage);
  930. begin
  931.   Application^.MakeWindow(New(PArtyWindow, Init(@Self, 'Arty Window')));
  932. end;
  933.  
  934. procedure TGDIDemoWindow.Quit(var Msg: TMessage);
  935. begin
  936.   CloseWindow;
  937. end;
  938.  
  939. { In response to WMTimer messages, each MDI child window's TimerTick
  940.   Method is called. }
  941. procedure TGDIDemoWindow.WMTimer(var Msg: TMessage);
  942.  
  943.   procedure ChildTimers(PChildWindow: PBaseDemoWindow); far;
  944.   begin
  945.     PChildWindow^.TimerTick;
  946.   end;
  947.  
  948. begin
  949.   ForEach(@ChildTimers);
  950. end;
  951.  
  952. procedure TGDIDemoWindow.WMDestroy(var Msg: TMessage);
  953. begin
  954.   KillTimer(HWindow, 0);
  955.   TMDIWindow.WMDestroy(Msg);
  956. end;
  957.  
  958. { TGDIDemoApp ------------------------------------------------------ }
  959.  
  960. type
  961.   TGDIDemoApp = object(TApplication)
  962.     procedure InitMainWindow; virtual;
  963.   end;
  964.  
  965. procedure TGDIDemoApp.InitMainWindow;
  966. begin
  967.   { Create a main window of type TGDIWindow. }
  968.   MainWindow := New(PGDIDemoWindow,
  969.     Init('GDI Demo', LoadMenu(HInstance,MakeIntResource(MenuID))));
  970. end;
  971.  
  972. var
  973.   GDIDemoApp: TGDIDemoApp;
  974.  
  975. begin
  976.   GDIDemoApp.Init('GDIDEMO');
  977.   GDIDemoApp.Run;
  978.   GDIDemoApp.Done;
  979. end.
  980.