1: 2: 3: 4: 5: 6: 7: 8: 9: 10: 11: 12: 13: 14: 15: 16: 17: 18: 19: 20: 21: 22: 23: 24: 25: 26: 27: 28: 29: 30: 31: 32: 33: 34: 35: 36: 37: 38: 39: 40: 41: 42: 43: 44: 45: 46: 47: 48: 49: 50: 51: 52: 53: 54: 55: 56: 57: 58: 59: 60: 61: 62: 63: 64: 65: 66: 67: 68: 69: 70: 71: 72: 73: 74: 75: 76: 77: 78: 79: 80: 81: 82: 83: 84: 85: 86: 87: 88: 89: 90: 91: 92: 93: 94: 95: 96: 97: 98: 99: 100: 101: 102: 103: 104: 105: 106: 107: 108: 109: 110: 111: 112: 113: 114: 115: 116: 117: 118: 119: 120: 121: 122: 123: 124: 125: 126: 127: 128: 129: 130: 131: 132: 133: 134: 135: 136: 137: 138: 139: 140: 141: 142: 143: 144: 145: 146: 147: 148: 149: 150: 151: 152: 153: 154: 155: 156: 157: 158: 159: 160: 161: 162: 163: 164: 165: 166: 167: 168: 169: 170: 171: 172: 173: 174: 175: 176: 177: 178: 179: 180: 181: 182: 183: 184: 185: 186: 187: 188: 189: 190: 191: 192: 193: 194: 195: 196: 197: 198: 199: 200: 201: 202: 203: 204: 205: 206: 207: 208: 209: 210: 211: 212: 213: 214: 215: 216: 217: 218: 219: 220: 221: 222: 223: 224: 225: 226: 227: 228: 229: 230: 231: 232: 233: 234: 235: 236: 237: 238: 239: 240: 241: 242: 243: 244: 245: 246: 247: 248: 249: 250:
| unit Unit1;
interface
uses Winapi.Windows, Winapi.Messages, Vcl.Forms, Direct2D, D2D1, Vcl.Controls, SysUtils, System.Classes;
type TBall = record x, y, dx, dy, r: integer; end;
TGameThread = class(TThread) strict private FTThreadProcedure: TThreadProcedure; protected procedure Execute; override; public constructor Create(const AMethod: TThreadProcedure); end;
TForm1 = class(TForm) procedure FormDestroy(Sender: TObject); private FRectColor: D3DCOLORVALUE; FBkgColor: D3DCOLORVALUE; FTextFormat: IDWriteTextFormat; FCounter: integer; FFPSDisplay: string; procedure ResetValues; procedure DrawTextOut(x, y: integer; const AText: string); procedure GenerateFPSDisplay(WatchElapsedTicks: Int64); public FGameThread: TGameThread; FCanvas: TDirect2DCanvas; FBalls: array of TBall; FMaxNumber: integer; FMaxFPS: Double; FMinFPS: Double;
property Canvas: TDirect2DCanvas read FCanvas;
procedure CreateWnd; override; procedure WMSize(var Message: TWMSize); message WM_SIZE; procedure StartRender; procedure Render; end;
var Form1: TForm1;
implementation
uses Diagnostics;
{$R *.dfm}
constructor TGameThread.Create(const AMethod: TThreadProcedure); begin inherited Create(False); FTThreadProcedure := AMethod; end;
procedure TGameThread.Execute; begin if Assigned(FTThreadProcedure) then begin while not Terminated do Synchronize(FTThreadProcedure); end; end;
procedure TForm1.DrawTextOut(x, y: integer; const AText: string); var LayoutRect: D2D1_RECT_F; TextLen: integer; begin TextLen := Length(AText); LayoutRect := D2D1RectF( x + 0.5, y + 0.5, (x + TextLen * 5) - 0.5, (y + TextLen) - 0.5);
if not Assigned(FTextFormat) then begin FTextFormat := FCanvas.Font.Handle; end;
FCanvas.RenderTarget.DrawText(PWideChar(AText), TextLen, FTextFormat, LayoutRect, FCanvas.Brush.Handle); end;
procedure TForm1.StartRender; var PaintStruct: TPaintStruct; Watch: TStopWatch; WatchElapsedTicks: Int64; begin BeginPaint(Handle, PaintStruct); try Watch := TStopWatch.StartNew; FCanvas.BeginDraw; try Render;
DrawTextOut(0, 40, FFPSDisplay); finally FCanvas.EndDraw; Watch.Stop; WatchElapsedTicks := Watch.ElapsedTicks; GenerateFPSDisplay(WatchElapsedTicks);
Application.ProcessMessages; end; finally EndPaint(Handle, PaintStruct); end; end;
procedure TForm1.CreateWnd; var I: integer; LClientRect: TRect; LClientWidth, LClientHeight: integer; begin inherited; FCanvas := TDirect2DCanvas.Create(Handle); ResetValues;
randomize; FMaxNumber := 1000; SetLength(FBalls, FMaxNumber);
Winapi.Windows.GetClientRect(Self.Handle, LClientRect); LClientWidth := LClientRect.Width; LClientHeight := LClientRect.Height;
for I := 1 to FMaxNumber - 1 do begin with FBalls[I] do begin r := random(10) + 1; x := random(LClientWidth - r - r) + r; y := random(LClientHeight - r - r) + r; dx := random(10) + 1; dy := random(10) + 1; end; end;
FRectColor := D2D1ColorF(1, 1, 1, 1); FBkgColor := D2D1ColorF(0, 0, 0, 0); FGameThread := TGameThread.Create(Self.StartRender); end;
procedure TForm1.FormDestroy(Sender: TObject); begin FGameThread.Free; end;
procedure TForm1.Render; var I: integer; BallRect: TD2D1RectF; CanvasRenderTarget: ID2D1RenderTarget; tmpX, tmpY: integer; LClientRect: TRect; LClientWidth, LClientHeight: integer; begin CanvasRenderTarget := FCanvas.RenderTarget; CanvasRenderTarget.Clear(FBkgColor);
ID2D1SolidColorBrush(FCanvas.Brush.Handle).SetColor(FRectColor);
Winapi.Windows.GetClientRect(Self.Handle, LClientRect); LClientWidth := LClientRect.Width; LClientHeight := LClientRect.Height;
for I := 0 to Length(FBalls) - 1 do begin with FBalls[I] do begin tmpX := x + dx; if ((tmpX + r) >= LClientWidth) or ((tmpX - r) <= 0) then dx := random(4) - 2 - dx;
tmpY := y + dy; if ((tmpY + r) >= LClientHeight) or ((tmpY - r) <= 0) then dy := random(4) - 2 - dy;
x := x + dx; y := y + dy;
BallRect := D2D1RectF(x - r + 0.5, y - r + 0.5, x + r - 0.5, y + r - 0.5); CanvasRenderTarget.FillRectangle(BallRect, FCanvas.Brush.Handle); CanvasRenderTarget.DrawRectangle(BallRect, FCanvas.Pen.Brush.Handle, FCanvas.Pen.Width, FCanvas.Pen.StrokeStyle); end; end; end;
procedure TForm1.GenerateFPSDisplay(WatchElapsedTicks: Int64); var TickFreq: Double; RealElapsedMilliseconds: Double; fps: Double; begin TickFreq := 10000000.0 / TStopWatch.Frequency; RealElapsedMilliseconds := (WatchElapsedTicks * TickFreq) / 10000; fps := (1000 / RealElapsedMilliseconds);
if FCounter = 100 then begin ResetValues; end;
Inc(FCounter);
if fps > FMaxFPS then FMaxFPS := fps;
if fps < FMinFPS then FMinFPS := fps;
FFPSDisplay := Format('Current FPS: %4.3f' + sLineBreak + 'Max: %4.3f ' + sLineBreak + 'Min: %4.3f', [fps, FMaxFPS, FMinFPS]); end;
procedure TForm1.ResetValues; begin FMaxFPS := 0; FMinFPS := 10000; FCounter := 0; end;
procedure TForm1.WMSize(var Message: TWMSize); var NewSize: TD2D1SizeU; begin NewSize := D2D1SizeU(ClientWidth, ClientHeight); if Assigned(FCanvas) then ID2D1HwndRenderTarget(FCanvas.RenderTarget).Resize(NewSize); inherited; end;
end. |