MathgeomGLS

1
unit uNCube;
2

3
interface
4

5
uses
6
  Winapi.Windows,
7
  System.Types,
8
  System.Classes,
9
  System.SysUtils,
10
  System.Math,
11
  Vcl.Graphics,
12
  Vcl.Forms,
13
  Vcl.Controls,
14

15
  GLS.Scene,
16
  GLS.Coordinates,
17
  GLS.VectorTypes,
18
  GLS.PersistentClasses,
19
  GLS.Objects,
20
  GLS.HUDObjects,
21
  GLS.GeomObjects,
22
  GLS.Material,
23
  GLS.Texture,
24
  GLS.TextureFormat,
25
  GLS.VectorGeometry,
26
  GLS.Keyboard,
27
  GLS.Context,
28
  GLS.BaseClasses,
29
  GLS.SceneViewer,
30
  GLS.RenderContextInfo;
31

32
type
33
  TGLNCube = class(TGLBaseSceneObject)
34
  private
35
    FDelta, FFps, FTimer, FInactiveTime: single;
36
    FCube: TGLDummyCube;
37
    FSel: Integer;
38
    FSelPos: TGLVector;
39
    FCam, FNavCam: TGLCamera;
40
    FHud: TGLHUDSprite;
41
    FMem: TGLMemoryViewer;
42
    FViewer: TGLSceneViewer;
43
    FReady, FMouse: boolean;
44
    FMouseRotation: boolean;
45
    FMousePos: TPoint;
46
    FPosAnimationStart: TGLVector;
47
    FPosAnimationEnd: TGLVector;
48
  public
49
    constructor CreateAsChild(aParentOwner: TGLBaseSceneObject); reintroduce;
50
    procedure DoProgress(const pt: TGLProgressTimes); override;
51
    procedure DoRender(var ARci: TGLRenderContextInfo;
52
      ARenderSelf, ARenderChildren: boolean); override;
53
    property SceneViewer: TGLSceneViewer read FViewer write FViewer;
54
    property Camera: TGLCamera read FCam write FCam;
55
    property FPS: single read FFps write FFps;
56
    property ActiveMouse: boolean read FMouse write FMouse;
57
    property InactiveTime: single read FInactiveTime write FInactiveTime;
58
  end;
59

60
var
61
  sW2, sH2: Integer;
62

63
//---------------------------------------------
64
implementation
65
//---------------------------------------------
66

67
constructor TGLNCube.CreateAsChild(aParentOwner: TGLBaseSceneObject);
68

69
procedure genTex(s: string; mat: TGLMaterial);
70
var
71
  bmp: TBitmap;
72
begin
73
  bmp := TBitmap.Create;
74
  bmp.Width := 64;
75
  bmp.Height := 64;
76
  with bmp.Canvas do
77
  begin
78
    Font.Name := 'Verdana';
79
    Font.Size := 10;
80
    TextOut(32 - TextWidth(s) div 2, 24, s);
81
  end;
82
  mat.FrontProperties.Diffuse.SetColor(1, 1, 1);
83
  mat.Texture.Image.Assign(bmp);
84
  mat.Texture.Disabled := false;
85
  mat.Texture.FilteringQuality := tfAnisotropic;
86
  mat.Texture.TextureMode := tmModulate;
87
  bmp.Free;
88
end;
89

90
procedure SetColor(m: TGLMaterial; c: single);
91
begin
92
  m.FrontProperties.Diffuse.SetColor(c, c, 1);
93
end;
94

95
procedure addPlane(t: Integer; ttl: string; c, x, y, z, dx, dy, dz: single);
96
begin
97
  with TGLPlane.CreateAsChild(FCube) do
98
  begin
99
    tag := t;
100
    tagfloat := c;
101
    Position.SetPoint(x, y, z);
102
    Direction.SetVector(dx, dy, dz);
103
    genTex(ttl, Material);
104
  end;
105
end;
106

107
procedure addCube(t: Integer; c, x, y, z, sx, sy, sz: single);
108
begin
109
  with TGLCube.CreateAsChild(FCube) do
110
  begin
111
    tag := t;
112
    tagfloat := c;
113
    Position.SetPoint(x, y, z);
114
    Scale.SetVector(sx, sy, sz);
115
    SetColor(Material, c);
116
  end;
117
end;
118

119
begin
120
  inherited CreateAsChild(aParentOwner);
121
  FDelta := 2;
122
  FFps := 30;
123
  FTimer := 10;
124
  FMouse := true;
125
  FInactiveTime := 0;
126

127
  FHud := TGLHUDSprite.CreateAsChild(self);
128
  FHud.Width := 128;
129
  FHud.Height := 128;
130
  FHud.Material.BlendingMode := bmTransparency;
131
  with FHud.Material.Texture do
132
  begin
133
    Disabled := false;
134
    ImageClassName := 'TGLBlankImage';
135
    MinFilter := miNearest;
136
    TGLBlankImage(Image).Width := 128;
137
    TGLBlankImage(Image).Height := 128;
138
    TextureMode := tmReplace;
139
  end;
140
  FHud.Position.SetPoint(-200, 50, 0);
141

142
  FNavCam := TGLCamera.CreateAsChild(self);
143
  FNavCam.FocalLength := 55;
144
  FNavCam.TargetObject := self;
145

146
  FMem := TGLMemoryViewer.Create(aParentOwner);
147
  FMem.Width := 128;
148
  FMem.Height := 128;
149
  FMem.Camera := FNavCam;
150
  with FMem.Buffer do
151
  begin
152
    BackgroundAlpha := 0;
153
    Antialiasing := aa6x;
154
    ContextOptions := [roDestinationAlpha];
155
    Lighting := false;
156
  end;
157

158
  FCube := TGLDummyCube.CreateAsChild(self);
159
  FCube.Visible := false;
160

161
  with TGLDisk.CreateAsChild(FCube) do
162
  begin
163
    Position.SetPoint(0, -0.805, 0);
164
    Direction.SetVector(0, 1, 0);
165
    InnerRadius := 0.9;
166
    OuterRadius := 1.3;
167
    Slices := 60;
168
    Loops := 1;
169
    SetColor(Material, 0.6);
170
  end;
171

172
  with TGLDisk.CreateAsChild(FCube) do
173
  begin
174
    Position.SetPoint(0, -0.8, 0);
175
    Direction.SetVector(0, 1, 0);
176
    InnerRadius := 0.95;
177
    OuterRadius := 1.25;
178
    Slices := 60;
179
    Loops := 1;
180
    SetColor(Material, 1);
181
  end;
182

183
  addPlane(0, 'FRONT', 1, 0, 0, 0.7, 0, 0, 1);
184
  addPlane(1, 'RIGHT', 1, 0.7, 0, 0, 1, 0, 0);
185
  addPlane(2, 'LEFT', 1, -0.7, 0, 0, -1, 0, 0);
186
  addPlane(3, 'BACK', 1, 0, 0, -0.7, 0, 0, -1);
187
  addPlane(4, 'TOP', 1, 0, 0.7, 0, 0, 1, 0);
188
  addPlane(5, 'BOTTOM', 1, 0, -0.7, 0, 0, -1, 0);
189

190
  addCube(6, 0.9, 0, 0.6, 0.6, 1, 0.2, 0.2);
191
  addCube(7, 0.9, 0, 0.6, -0.6, 1, 0.2, 0.2);
192
  addCube(8, 0.9, 0, -0.6, 0.6, 1, 0.2, 0.2);
193
  addCube(9, 0.9, 0, -0.6, -0.6, 1, 0.2, 0.2);
194

195
  addCube(10, 0.9, 0.6, 0.6, 0, 0.2, 0.2, 1);
196
  addCube(11, 0.9, 0.6, -0.6, 0, 0.2, 0.2, 1);
197
  addCube(12, 0.9, -0.6, 0.6, 0, 0.2, 0.2, 1);
198
  addCube(13, 0.9, -0.6, -0.6, 0, 0.2, 0.2, 1);
199

200
  addCube(14, 0.9, 0.6, 0, 0.6, 0.2, 1, 0.2);
201
  addCube(15, 0.9, 0.6, 0, -0.6, 0.2, 1, 0.2);
202
  addCube(16, 0.9, -0.6, 0, 0.6, 0.2, 1, 0.2);
203
  addCube(17, 0.9, -0.6, 0, -0.6, 0.2, 1, 0.2);
204

205
  addCube(18, 0.8, 0.6, 0.6, 0.6, 0.2, 0.2, 0.2);
206
  addCube(19, 0.8, 0.6, 0.6, -0.6, 0.2, 0.2, 0.2);
207
  addCube(20, 0.8, 0.6, -0.6, 0.6, 0.2, 0.2, 0.2);
208
  addCube(21, 0.8, -0.6, 0.6, 0.6, 0.2, 0.2, 0.2);
209
  addCube(22, 0.8, 0.6, -0.6, -0.6, 0.2, 0.2, 0.2);
210
  addCube(23, 0.8, -0.6, -0.6, 0.6, 0.2, 0.2, 0.2);
211
  addCube(24, 0.8, -0.6, 0.6, -0.6, 0.2, 0.2, 0.2);
212
  addCube(25, 0.8, -0.6, -0.6, -0.6, 0.2, 0.2, 0.2);
213

214
end;
215

216
procedure TGLNCube.DoProgress(const pt: TGLProgressTimes);
217
const
218
  tb: array [0 .. 1] of array [0 .. 3] of TGLVector = (((x: 0; y: 20; z: 1;
219
    W: 0), (x: 1; y: 20; z: 0; W: 0), (x: 0; y: 20; z: - 1; W: 0), (x: - 1;
220
    y: 20; z: 0; W: 0)), ((x: 0; y: - 20; z: 1; W: 0), (x: 1; y: - 20; z: 0;
221
    W: 0), (x: 0; y: - 20; z: - 1; W: 0), (x: - 1; y: - 20; z: 0; W: 0)));
222
var
223
  mp: TPoint;
224
  mover: boolean;
225
  i: Integer;
226
  v0, v1, v2, v: TGLVector;
227
  obj: TGLBaseSceneObject;
228

229
procedure moveTo(trgv: TGLVector);
230
begin
231
  FPosAnimationStart := FCam.Position.AsVector;
232
  FPosAnimationEnd := FCam.TargetObject.AbsoluteToLocal
233
    (VectorScale(VectorNormalize(trgv), FCam.DistanceToTarget));
234
  FDelta := 0;
235
end;
236

237
begin
238
  mp := FViewer.ScreenToClient(mouse.CursorPos);
239
  mover := (mp.x > FHud.Position.x - 64) and (mp.x < FHud.Position.x + 64) and
240
    (mp.y > FHud.Position.y - 64) and (mp.y < FHud.Position.y + 64);
241
  // mouse Down/Up
242
  if FDelta > 1 then
243
  begin
244
    if iskeydown(VK_LBUTTON) and (not FMouseRotation) then
245
    begin
246
      // selection > start auto rotation
247
      if mover and (FSel >= 0) then
248
      begin
249

250
        v := FCam.AbsoluteVectorToTarget;
251
        v.y := 0;
252
        if v.x < 0 then
253
          i := -1
254
        else
255
          i := 1;
256
        i := round((ArcCosine(VectorAngleCosine(v, ZHmgPoint)) * i + PI) / PI
257
          * 2) mod 4;
258
        if (FSel = 4) or (FSel = 5) then
259
          moveTo(tb[FSel - 4][i])
260
        else
261
          moveTo(FSelPos);
262
        FInactiveTime := 0;
263
      end // start manual rotation
264
      else if FMouse then
265
      begin
266
        FMouseRotation := true;
267
        FMousePos := mouse.CursorPos;
268
        showCursor(false);
269
        mouse.CursorPos := point(sW2, sH2);
270
        FInactiveTime := 0;
271
      end;
272
    end;
273
    // stop rotation, restore cursor
274
    if (not iskeydown(VK_LBUTTON)) and FMouseRotation and FMouse then
275
    begin
276
      showCursor(true);
277
      FMouseRotation := false;
278
      mouse.CursorPos := FMousePos;
279
      FInactiveTime := 0;
280
    end;
281
  end
282
  // auto rotation progress
283
  else
284
  begin
285
    FDelta := FDelta + pt.deltaTime * 2;
286
    v := VectorLerp(FPosAnimationStart, FPosAnimationEnd,
287
      FDelta * FDelta * (3 - 2 * FDelta));
288
    v := VectorScale(VectorNormalize(v), VectorLength(FPosAnimationStart));
289
    if FDelta < 1 then
290
      FCam.Position.SetPoint(v)
291
    else
292
      FCam.Position.SetPoint(FPosAnimationEnd);
293
    v := VectorScale(VectorNormalize(v), 10);
294
    if FDelta < 1 then
295
      v := VectorScale(VectorNormalize(v), 10)
296
    else
297
      v := VectorScale(VectorNormalize(FPosAnimationEnd), 10);
298
    FNavCam.Position.SetPoint(v);
299
    for i := 2 to FCube.Count - 1 do
300
      with TGLSceneObject(FCube.Children[i]) do
301
        Material.FrontProperties.Diffuse.SetColor(tagfloat, tagfloat, 1);
302
    FInactiveTime := 0;
303
  end;
304
  FSel := -1;
305
  // manual rotation progress
306
  if FMouseRotation and FMouse then
307
  begin
308
    mp := mouse.CursorPos;
309
    if FCam <> nil then
310
      FCam.MoveAroundTarget((sH2 - mp.y) * 0.2, (sW2 - mp.x) * 0.2);
311
    FNavCam.MoveAroundTarget((sH2 - mp.y) * 0.2, (sW2 - mp.x) * 0.2);
312
    mouse.CursorPos := point(sW2, sH2);
313
    FInactiveTime := 0;
314
  end
315
  else if FReady then
316
  begin
317
    // selection
318
    if mover and (FDelta > 1) then
319
    begin
320
      v0 := FNavCam.AbsolutePosition;
321
      v1 := FMem.Buffer.ScreenToVector(mp.x - round(FHud.Position.x) + 64,
322
        round(FHud.Position.y) - mp.y + 64);
323
      SetVector(v2, 99999, 99999, 99999);
324

325
      obj := nil;
326
      for i := 2 to FCube.Count - 1 do
327
        with TGLSceneObject(FCube.Children[i]) do
328
        begin
329
          Material.FrontProperties.Diffuse.SetColor(tagfloat, tagfloat, 1);
330
          if RayCastIntersect(v0, v1, @v) then
331
            if VectorDistance2(v2, v0) > VectorDistance2(v, v0) then
332
            begin
333
              SetVector(v2, v);
334
              FSel := FCube.Children[i].tag;
335
              FSelPos := FCube.Children[i].Position.AsVector;
336
              obj := FCube.Children[i];
337
            end;
338
        end;
339
      if FSel >= 0 then
340
      begin
341
        FViewer.cursor := -21;
342
        TGLSceneObject(obj).Material.FrontProperties.Diffuse.SetColor
343
          (1, 0.6, 0);
344
      end
345
      else
346
        FViewer.cursor := 0;
347
    end;
348
    v := VectorScale(VectorNormalize(FCam.AbsoluteVectorToTarget), 10);
349
    FNavCam.Position.SetPoint(VectorNegate(v));
350
    FInactiveTime := FInactiveTime + pt.deltaTime;
351
  end;
352
  // rendering
353
  FTimer := FTimer + pt.deltaTime;
354
  if FTimer > 1 / FFps then
355
  begin
356
    FTimer := FTimer - Floor(FTimer * FFps) / FFps;
357
    FMem.Render(FCube);
358
    FMem.CopyToTexture(FHud.Material.Texture);
359
    FReady := true;
360
  end;
361
end;
362

363
procedure TGLNCube.DoRender(var ARci: TGLRenderContextInfo;
364
  ARenderSelf, ARenderChildren: boolean);
365
begin
366
  inherited;
367
  if (FCam = nil) and (scene.CurrentGLCamera <> nil) then
368
  begin
369
    FCam := scene.CurrentGLCamera;
370
    FNavCam.Position.SetPoint
371
      (VectorScale(VectorNormalize(FCam.Position.AsVector), 10));
372
  end;
373
  if FViewer <> nil then
374
    FHud.Position.SetPoint(FViewer.Width - 80, 50, 0);
375
end;
376

377
//----------------------------------------------
378
initialization
379
//----------------------------------------------
380

381
  sW2 := screen.Width div 2;
382
  sH2 := screen.Height div 2;
383

384
end.
385