Luxophia

LUX.GPU.OpenGL.Viewer.pas
404 строки · 8.8 Кб
Перенос по словам
1
unit LUX.GPU.OpenGL.Viewer;
2

3
interface
4

5
uses
6
  System.SysUtils,
7
  System.Types,
8
  System.UITypes,
9
  System.Classes,
10
  System.Variants,
11
  FMX.Types, FMX.Graphics,
12
  FMX.Controls, FMX.Forms,
13
  FMX.Dialogs, FMX.StdCtrls,
14
  System.Messaging,
15
  LUX,
16
  LUX.D3,
17
  LUX.D4,
18
  LUX.M4,
19
  LUX.GPU.OpenGL,
20
  LUX.GPU.OpenGL.Window,
21
  LUX.GPU.OpenGL.Atom.Buffer.UniBuf,
22
  LUX.GPU.OpenGL.Scener,
23
  LUX.GPU.OpenGL.Camera;
24

25
type
26
  TGLViewer = class(TFrame)
27
  private
28
    procedure GoMouseClick(Sender_: TObject; Button_: TMouseButton;
29
      Shift_: TShiftState; X_, Y_: Single);
30
    procedure GoMouseDown(Sender_: TObject; Button_: TMouseButton;
31
      Shift_: TShiftState; X_, Y_: Single); inline;
32
    procedure GoMouseMove(Sender_: TObject; Shift_: TShiftState;
33
      X_, Y_: Single); inline;
34
    procedure GoMouseUp(Sender_: TObject; Button_: TMouseButton;
35
      Shift_: TShiftState; X_, Y_: Single); inline;
36
    procedure GoMouseWheel(Sender_: TObject; Shift_: TShiftState;
37
      WheelDelta_: Integer; var Handled_: Boolean); inline;
38
    procedure OnCreateAnyWND(const Sender_: TObject; const Message_: TMessage);
39
    procedure OnDestroAnyWND(const Sender_: TObject; const Message_: TMessage);
40
  protected
41
    _RootForm: FMX.Forms.TCommonCustomForm;
42
    _Form: TGLViewerForm;
43
    _Viewer: TGLUniBuf<TSingleM4>;
44
    _Camera: TGLCamera;
45
    _BackColor: TAlphaColorF;
46
    _OnPaint: TProc;
47
    class function GetScreenScale: Single;
48
    function GetRootForm: TForm;
49
    function GetPxSize: System.Types.TSize;
50
    procedure DoAbsoluteChanged; override;
51
    procedure ParentChanged; override;
52
    procedure Paint; override;
53
    procedure Resize; override;
54
    procedure AncestorVisibleChanged(const Visible_: Boolean); override;
55
    procedure AncestorParentChanged; override;
56
    procedure CreateWindow;
57
    procedure DestroWindow;
58
    procedure FitWindow;
59
  public
60
    constructor Create(AOwner_: TComponent); override;
61
    destructor Destroy; override;
62
    property PxSize: System.Types.TSize read GetPxSize;
63
    property Camera: TGLCamera read _Camera write _Camera;
64
    property BackColor: TAlphaColorF read _BackColor write _BackColor;
65
    property OnPaint: TProc read _OnPaint write _OnPaint;
66
    procedure Repaint;
67
    procedure BeginRender;
68
    procedure EndRender;
69
    function MakeScreenShot: FMX.Graphics.TBitmap;
70
    function ShootRay(const X_, Y_: Single): TSingleRay3D;
71
    function PickObject(const X_, Y_: Single): TGLObject;
72
  end;
73

74
implementation //------------------------------------------------------------
75

76
{$R *.fmx}
77

78
uses
79
  FMX.Platform,
80
  Winapi.OpenGL, Winapi.OpenGLext;
81

82
procedure TGLViewer.GoMouseClick(Sender_: TObject; Button_: TMouseButton;
83
  Shift_: TShiftState; X_, Y_: Single);
84
begin
85
  MouseClick(Button_, Shift_, X_, Y_);
86
end;
87

88
procedure TGLViewer.GoMouseDown(Sender_: TObject; Button_: TMouseButton;
89
  Shift_: TShiftState; X_, Y_: Single);
90
begin
91
  _Form.MouseCapture;
92

93
  MouseDown(Button_, Shift_, X_, Y_);
94
end;
95

96
procedure TGLViewer.GoMouseMove(Sender_: TObject; Shift_: TShiftState;
97
  X_, Y_: Single);
98
begin
99
  MouseMove(Shift_, X_, Y_);
100
end;
101

102
procedure TGLViewer.GoMouseUp(Sender_: TObject; Button_: TMouseButton;
103
  Shift_: TShiftState; X_, Y_: Single);
104
begin
105
  MouseUp(Button_, Shift_, X_, Y_);
106

107
  _Form.ReleaseCapture;
108
end;
109

110
procedure TGLViewer.GoMouseWheel(Sender_: TObject; Shift_: TShiftState;
111
  WheelDelta_: Integer; var Handled_: Boolean);
112
begin
113
  MouseWheel(Shift_, WheelDelta_, Handled_);
114
end;
115

116
procedure TGLViewer.OnCreateAnyWND(const Sender_: TObject;
117
  const Message_: TMessage);
118
begin
119
  if Sender_ = _RootForm then
120
  begin
121
    Assert(not Assigned(_Form),
122
      'Failed! _Form is not nil. @ TGLViewer.OnCreateAnyWND');
123

124
    CreateWindow;
125

126
    _Form.Parent := Self;
127

128
    FitWindow;
129
  end;
130
end;
131

132
procedure TGLViewer.OnDestroAnyWND(const Sender_: TObject;
133
  const Message_: TMessage);
134
begin
135
  if Sender_ = _RootForm then
136
  begin
137
    DestroWindow;
138
  end;
139
end;
140

141
class function TGLViewer.GetScreenScale: Single;
142
var
143
  S: IFMXScreenService;
144
begin
145
  if TPlatformServices.Current.SupportsPlatformService(IFMXScreenService,
146
    IInterface(S)) then
147
    Result := S.GetScreenScale
148
  else
149
    Result := 1;
150
end;
151

152
// ------------------------------------------------------------------------------
153

154
function TGLViewer.GetRootForm: TForm;
155
begin
156
  if Assigned(Root) and (Root.GetObject is TForm) then
157
  begin
158
    Result := Root.GetObject as TForm;
159
  end
160
  else
161
    Result := nil;
162
end;
163

164
// ------------------------------------------------------------------------------
165

166
function TGLViewer.GetPxSize: System.Types.TSize;
167
begin
168
  with Result do
169
  begin
170
    Width := Round(_Form.Width * GetScreenScale);
171
    Height := Round(_Form.Height * GetScreenScale);
172
  end;
173
end;
174

175
procedure TGLViewer.DoAbsoluteChanged;
176
begin
177
  inherited;
178
  FitWindow;
179
end;
180

181
procedure TGLViewer.ParentChanged;
182
begin
183
  inherited;
184
  _RootForm := GetRootForm;
185
  _Form.Parent := Self;
186
end;
187

188
procedure TGLViewer.Paint;
189
begin
190
  BeginRender;
191
  with GetPxSize do
192
    glViewport(0, 0, Width, Height);
193
  if Assigned(_Camera) then
194
    _Camera.Render;
195
  _OnPaint;
196
  EndRender;
197
end;
198

199
procedure TGLViewer.Resize;
200
begin
201
  inherited;
202

203
  if Assigned(Parent) then
204
    FitWindow;
205
end;
206

207
procedure TGLViewer.AncestorVisibleChanged(const Visible_: Boolean);
208
begin
209
  inherited;
210
  _Form.Visible := ParentedVisible;
211
end;
212

213
procedure TGLViewer.AncestorParentChanged;
214
begin
215
  inherited;
216
  _RootForm := GetRootForm;
217
  _Form.Parent := Self;
218
end;
219

220
// ------------------------------------------------------------------------------
221

222
procedure TGLViewer.CreateWindow;
223
begin
224
  _Form := TGLViewerForm.CreateNew(Self);
225

226
  with _Form do
227
  begin
228
    OnMouseClick := GoMouseClick;
229
    OnMouseDown := GoMouseDown;
230
    OnMouseMove := GoMouseMove;
231
    OnMouseUp := GoMouseUp;
232
    OnMouseWheel := GoMouseWheel;
233
  end;
234
end;
235

236
procedure TGLViewer.DestroWindow;
237
begin
238
  FreeAndNil(_Form);
239
end;
240

241
// ------------------------------------------------------------------------------
242

243
procedure TGLViewer.FitWindow;
244
var
245
  R: TRectF;
246
begin
247
  R := TRectF.Create(LocalToAbsolute(TPointF.Zero) * GetScreenScale,
248
    Width, Height);
249

250
  _Form.Bounds := R.Round;
251

252
  if Height < Width then
253
    _Viewer[0] := TSingleM4.Scale(Height / Width, 1, 1)
254
  else if Width < Height then
255
    _Viewer[0] := TSingleM4.Scale(1, Width / Height, 1)
256
  else
257
    _Viewer[0] := TSingleM4.Identity;
258
end;
259

260
constructor TGLViewer.Create(AOwner_: TComponent);
261
begin
262
  inherited;
263

264
  HitTest := False;
265

266
  _RootForm := nil;
267

268
  _OnPaint := procedure
269
    begin
270
    end;
271
  CreateWindow;
272
  if not(csDesigning in ComponentState) then
273
  begin
274
    TMessageManager.DefaultManager.SubscribeToMessage(TAfterCreateFormHandle,
275
      OnCreateAnyWND);
276
    TMessageManager.DefaultManager.SubscribeToMessage(TBeforeDestroyFormHandle,
277
      OnDestroAnyWND);
278
  end;
279
  _Viewer := TGLUniBuf<TSingleM4>.Create(GL_DYNAMIC_DRAW);
280
  _BackColor := TAlphaColorF.Create(0, 0, 0, 1);
281
end;
282

283
destructor TGLViewer.Destroy;
284
begin
285
  _Viewer.Free;
286

287
  if not(csDesigning in ComponentState) then
288
  begin
289
    TMessageManager.DefaultManager.Unsubscribe(TBeforeDestroyFormHandle,
290
      OnDestroAnyWND);
291
    TMessageManager.DefaultManager.Unsubscribe(TAfterCreateFormHandle,
292
      OnCreateAnyWND);
293
  end;
294

295
  inherited;
296
end;
297

298
procedure TGLViewer.Repaint;
299
begin
300
  Paint;
301
end;
302

303
// ------------------------------------------------------------------------------
304

305
procedure TGLViewer.BeginRender;
306
begin
307
  _Form.BeginGL;
308

309
  with _BackColor do
310
    glClearColor(R, G, B, A);
311

312
  glClear(GL_COLOR_BUFFER_BIT or GL_DEPTH_BUFFER_BIT);
313

314
  _Viewer.Use(0 { BinP } );
315
end;
316

317
procedure TGLViewer.EndRender;
318
begin
319
  _Viewer.Unuse(0 { BinP } );
320

321
  glFlush;
322

323
  _Form.EndGL;
324

325
  _Form.SwapBuffers;
326
end;
327

328
// ------------------------------------------------------------------------------
329

330
function TGLViewer.MakeScreenShot: FMX.Graphics.TBitmap;
331
var
332
  Cs: TArray<TAlphaColor>;
333
  C, B: PAlphaColor;
334
  Bs: TBitmapData;
335
  S, Y: Integer;
336
begin
337
  Result := FMX.Graphics.TBitmap.Create;
338

339
  with Result do
340
  begin
341
    SetSize(GetPxSize);
342

343
    SetLength(Cs, Height * Width);
344

345
    C := @Cs[0];
346

347
    _Form.BeginGL;
348

349
    glReadBuffer(GL_FRONT);
350
    glReadPixels(0, 0, Width, Height, GL_BGRA, GL_UNSIGNED_BYTE, C);
351

352
    _Form.EndGL;
353

354
    Map(TMapAccess.Write, Bs);
355

356
    S := SizeOf(TAlphaColor) * Width;
357

358
    for Y := Height - 1 downto 0 do
359
    begin
360
      B := Bs.GetScanline(Y);
361

362
      System.Move(C^, B^, S);
363

364
      Inc(C, Width);
365
    end;
366

367
    Unmap(Bs);
368
  end;
369
end;
370

371
// ------------------------------------------------------------------------------
372

373
function TGLViewer.ShootRay(const X_, Y_: Single): TSingleRay3D;
374
var
375
  M: TSingleM4;
376
  S, P0, P1: TSingle4D;
377
begin
378
  M := _Camera.AbsoPose * _Camera.Proj.Inverse * _Viewer[0].Inverse;
379

380
  with GetPxSize do
381
  begin
382
    S.X := X_ / Width * 2 - 1;
383
    S.Y := 1 - Y_ / Height * 2;
384
    S.W := 1;
385
  end;
386

387
  S.Z := -1;
388
  P0 := M * S;
389
  S.Z := +1;
390
  P1 := M * S;
391

392
  with Result do
393
  begin
394
    Pos := P0.ToCart;
395
    Vec := Pos.UnitorTo(P1.ToCart);
396
  end;
397
end;
398

399
function TGLViewer.PickObject(const X_, Y_: Single): TGLObject;
400
begin
401
  Result := _Camera.Scener.HitRay(ShootRay(X_, Y_));
402
end;
403

404
end.
405
Luxophia

Использование cookies
