ArenaZ

1
unit uNavCube;
2

3
//{$IFDEF FPC}
4
//  {$MODE Delphi}
5
//{$ENDIF}
6
{$mode objfpc}{$H+}
7

8
interface
9

10
uses
11
  lcltype,Classes, SysUtils,
12
  Graphics, Forms, Controls,
13
  // GLS
14
  GLScene, GLObjects, GLHUDObjects, GLGeomObjects, GLMaterial, GLTexture,
15
  GLTextureFormat, GLVectorGeometry, GLKeyboard, GLContext, GLBaseClasses,
16
  GLLCLViewer, GLRenderContextInfo, keyboard;
17

18
type
19
  TGLNavCube = class(TGLBaseSceneObject)
20
  private
21
    FDelta, FFps, FTimer, FInactiveTime: single;
22
    FCube: TGLDummyCube;
23
    FSel: Integer;
24
    FSelPos: TVector;
25
    FCam, FNavCam: TGLCamera;
26
    FHud: TGLHUDSprite;
27
    FMem: TGLMemoryViewer;
28
    FViewer: TGLSceneViewer;
29
    FReady, FMouse: boolean;
30
    FMouseRotation: boolean;
31
    FAutoRotate : Boolean;
32
    FMousePos: TPoint;
33

34
    FPosAnimationStart: TVector;
35
    FPosAnimationEnd: TVector;
36

37
  public
38
    constructor CreateAsChild(aParentOwner: TGLBaseSceneObject); reintroduce;
39
    procedure DoProgress(const pt: TProgressTimes); override;
40
    procedure DoRender(var ARci: TGLRenderContextInfo;
41
      ARenderSelf, ARenderChildren: boolean); override;
42

43
    property SceneViewer: TGLSceneViewer read FViewer write FViewer;
44
    property Camera: TGLCamera read FCam write FCam;
45
    property FPS: single read FFps write FFps;
46

47
    property ActiveMouse: boolean read FMouse write FMouse;
48
    property AutoRotate: boolean read FAutoRotate write FAutoRotate;
49
    property InactiveTime: single read FInactiveTime write FInactiveTime;
50
  end;
51

52
var
53
  sW2, sH2: Integer;
54

55
implementation
56

57
// constructor
58
//
59
constructor TGLNavCube.CreateAsChild(aParentOwner: TGLBaseSceneObject);
60

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

82
procedure SetColor(m: TGLMaterial; c: single);
83
begin
84
  m.FrontProperties.Diffuse.SetColor(c, c, 1);
85
end;
86

87
procedure addPlane(t: Integer; ttl: string; c, x, y, z, dx, dy, dz: single);
88
begin
89
  with TGLPlane.CreateAsChild(FCube) do
90
  begin
91
    tag := t;
92
    tagfloat := c;
93
    Position.SetPoint(x, y, z);
94
    Direction.SetVector(dx, dy, dz);
95
    genTex(ttl, Material);
96
  end;
97
end;
98

99
procedure addCube(t: Integer; c, x, y, z, sx, sy, sz: single);
100
begin
101
  with TGLCube.CreateAsChild(FCube) do
102
  begin
103
    tag := t;
104
    tagfloat := c;
105
    Position.SetPoint(x, y, z);
106
    Scale.SetVector(sx, sy, sz);
107
    SetColor(Material, c);
108
  end;
109
end;
110

111
begin
112
  inherited CreateAsChild(aParentOwner);
113
  FDelta := 2;
114
  FFps := 30;
115
  FTimer := 10;
116
  FMouse := True;
117
  FAutoRotate := False;
118
  FInactiveTime := 0;
119

120
  FHud := TGLHUDSprite.CreateAsChild(self);
121
  FHud.Width := 128;
122
  FHud.Height := 128;
123
  FHud.Material.BlendingMode := bmTransparency;
124
  with FHud.Material.Texture do
125
  begin
126
    Disabled := false;
127
    ImageClassName := 'TGLBlankImage';
128
    MinFilter := miNearest;
129
    TGLBlankImage(Image).Width := 128;
130
    TGLBlankImage(Image).Height := 128;
131
    TextureMode := tmReplace;
132
  end;
133
  FHud.Position.SetPoint(-200, 50, 0);
134

135
  FNavCam := TGLCamera.CreateAsChild(self);
136
  FNavCam.FocalLength := 55;
137
  FNavCam.TargetObject := self;
138

139
  FMem := TGLMemoryViewer.Create(aParentOwner);
140
  FMem.Width := 128;
141
  FMem.Height := 128;
142
  FMem.Camera := FNavCam;
143
  with FMem.Buffer do
144
  begin
145
    BackgroundAlpha := 0;
146
    Antialiasing := aa6x;
147
    ContextOptions := [roDestinationAlpha];
148
    Lighting := false;
149
  end;
150

151
  FCube := TGLDummyCube.CreateAsChild(self);
152
  FCube.Visible := false;
153

154
  with TGLDisk.CreateAsChild(FCube) do
155
  begin
156
    Position.SetPoint(0, -0.805, 0);
157
    Direction.SetVector(0, 1, 0);
158
    InnerRadius := 0.9;
159
    OuterRadius := 1.3;
160
    Slices := 60;
161
    Loops := 1;
162
    SetColor(Material, 0.6);
163
  end;
164

165
  with TGLDisk.CreateAsChild(FCube) do
166
  begin
167
    Position.SetPoint(0, -0.8, 0);
168
    Direction.SetVector(0, 1, 0);
169
    InnerRadius := 0.95;
170
    OuterRadius := 1.25;
171
    Slices := 60;
172
    Loops := 1;
173
    SetColor(Material, 1);
174
  end;
175

176
  addPlane(0, 'FRONT', 1, 0, 0, 0.7, 0, 0, 1);
177
  addPlane(1, 'RIGHT', 1, 0.7, 0, 0, 1, 0, 0);
178
  addPlane(2, 'LEFT', 1, -0.7, 0, 0, -1, 0, 0);
179
  addPlane(3, 'BACK', 1, 0, 0, -0.7, 0, 0, -1);
180
  addPlane(4, 'TOP', 1, 0, 0.7, 0, 0, 1, 0);
181
  addPlane(5, 'BOTTOM', 1, 0, -0.7, 0, 0, -1, 0);
182

183
  addCube(6, 0.9, 0, 0.6, 0.6, 1, 0.2, 0.2);
184
  addCube(7, 0.9, 0, 0.6, -0.6, 1, 0.2, 0.2);
185
  addCube(8, 0.9, 0, -0.6, 0.6, 1, 0.2, 0.2);
186
  addCube(9, 0.9, 0, -0.6, -0.6, 1, 0.2, 0.2);
187

188
  addCube(10, 0.9, 0.6, 0.6, 0, 0.2, 0.2, 1);
189
  addCube(11, 0.9, 0.6, -0.6, 0, 0.2, 0.2, 1);
190
  addCube(12, 0.9, -0.6, 0.6, 0, 0.2, 0.2, 1);
191
  addCube(13, 0.9, -0.6, -0.6, 0, 0.2, 0.2, 1);
192

193
  addCube(14, 0.9, 0.6, 0, 0.6, 0.2, 1, 0.2);
194
  addCube(15, 0.9, 0.6, 0, -0.6, 0.2, 1, 0.2);
195
  addCube(16, 0.9, -0.6, 0, 0.6, 0.2, 1, 0.2);
196
  addCube(17, 0.9, -0.6, 0, -0.6, 0.2, 1, 0.2);
197

198
  addCube(18, 0.8, 0.6, 0.6, 0.6, 0.2, 0.2, 0.2);
199
  addCube(19, 0.8, 0.6, 0.6, -0.6, 0.2, 0.2, 0.2);
200
  addCube(20, 0.8, 0.6, -0.6, 0.6, 0.2, 0.2, 0.2);
201
  addCube(21, 0.8, -0.6, 0.6, 0.6, 0.2, 0.2, 0.2);
202
  addCube(22, 0.8, 0.6, -0.6, -0.6, 0.2, 0.2, 0.2);
203
  addCube(23, 0.8, -0.6, -0.6, 0.6, 0.2, 0.2, 0.2);
204
  addCube(24, 0.8, -0.6, 0.6, -0.6, 0.2, 0.2, 0.2);
205
  addCube(25, 0.8, -0.6, -0.6, -0.6, 0.2, 0.2, 0.2);
206

207
end;
208

209
// DoProgress
210
//
211
procedure TGLNavCube.DoProgress(const pt: TProgressTimes);
212
const
213
  tb: array [0 .. 1] of array [0 .. 3] of TVector = (((x: 0; y: 20; z: 1;
214
    W: 0), (x: 1; y: 20; z: 0; W: 0), (x: 0; y: 20; z: - 1; W: 0), (x: - 1;
215
    y: 20; z: 0; W: 0)), ((x: 0; y: - 20; z: 1; W: 0), (x: 1; y: - 20; z: 0;
216
    W: 0), (x: 0; y: - 20; z: - 1; W: 0), (x: - 1; y: - 20; z: 0; W: 0)));
217
var
218
  mp: TPoint;
219
  mover: boolean;
220
  i: Integer;
221
  v0, v1, v2, v: TVector;
222
  obj: TGLBaseSceneObject;
223

224
procedure moveTo(trgv: TVector);
225
begin
226
  FPosAnimationStart := FCam.Position.AsVector;
227
  FPosAnimationEnd := FCam.TargetObject.AbsoluteToLocal
228
    (VectorScale(VectorNormalize(trgv), FCam.DistanceToTarget));
229
  FDelta := 0;
230
end;
231

232
begin
233
//  if not (csloading in componentstate) then
234
//  begin
235
  mp := FViewer.ScreenToClient(mouse.CursorPos);
236
  mover := (mp.x > FHud.Position.x - 64) and (mp.x < FHud.Position.x + 64) and
237
    (mp.y > FHud.Position.y - 64) and (mp.y < FHud.Position.y + 64);
238
  // mouse Down/Up
239
  if (mp.y<FViewer.Top) or (mp.x<FViewer.Left) or (mp.y>FViewer.Top+FViewer.Height) or (mp.x>FViewer.Left+FViewer.Width) then exit;
240
  if FDelta > 1 then
241
  begin
242
    if iskeydown(VK_LBUTTON) and (not FMouseRotation) then
243
    begin
244
      // selection > start auto rotation
245
      if mover and (FSel >= 0) then
246
      begin
247

248
        v := FCam.AbsoluteVectorToTarget;
249
        v.y := 0;
250
        if v.x < 0 then
251
          i := -1
252
        else
253
          i := 1;
254
        i := round((ArcCos(VectorAngleCosine(v, ZHmgPoint)) * i + PI) / PI
255
          * 2) mod 4;
256
        if (FSel = 4) or (FSel = 5) then
257
          moveTo(tb[FSel - 4][i])
258
        else
259
          moveTo(FSelPos);
260
        FInactiveTime := 0;
261
      end // start manual rotation
262
      else if FMouse then
263
      begin
264

265
        FMouseRotation := true;
266
        FMousePos := mouse.CursorPos;
267
        //FMousePos := point(sW2, sH2);
268
       // mouse.CursorPos := point(sW2, sH2);
269
        FInactiveTime := 0;
270
      end;
271
    end;
272
    // stop rotation, restore cursor
273
    if (not iskeydown(VK_LBUTTON)) and FMouseRotation and FMouse then
274
    begin
275
      FMouseRotation := false;
276
     // FMousePos := mouse.CursorPos;
277
     // mouse.CursorPos := FMousePos;
278

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

294
    v := VectorScale(VectorNormalize(v), 10);
295
    if FDelta < 1 then
296
      v := VectorScale(VectorNormalize(v), 10)
297
    else
298
      v := VectorScale(VectorNormalize(FPosAnimationEnd), 10);
299
    FNavCam.Position.SetPoint(v);
300

301
    for i := 2 to FCube.Count - 1 do
302
      with TGLSceneObject(FCube.Children[i]) do
303
        Material.FrontProperties.Diffuse.SetColor(tagfloat, tagfloat, 1);
304
    FInactiveTime := 0;
305
  end;
306
  FSel := -1;
307
  // manual rotation progress
308
  if FMouseRotation and FMouse then
309
  begin
310

311
    mp := mouse.CursorPos;
312
    if FCam <> nil then
313
    begin
314
      FCam.MoveAroundTarget((FMousePos.y - mp.y) * 0.02, (FMousePos.x - mp.x) * 0.02);
315
      FNavCam.MoveAroundTarget((FMousePos.y - mp.y) * 0.02, (FMousePos.x - mp.x) * 0.02);
316
//    FCam.MoveAroundTarget((sH2 - mp.y) * 0.2, (sW2 - mp.x) * 0.2);
317
//  FNavCam.MoveAroundTarget((sH2 - mp.y) * 0.2, (sW2 - mp.x) * 0.2);
318
    end;
319

320
   // mouse.CursorPos := point(sW2, sH2);
321

322
   FInactiveTime := 0;
323
  end
324
  else if FReady then
325
  begin
326
    // selection
327
    if mover and (FDelta > 1) then
328
    begin
329
      v0 := FNavCam.AbsolutePosition;
330
      v1 := FMem.Buffer.ScreenToVector(mp.x - round(FHud.Position.x) + 64,
331
        round(FHud.Position.y) - mp.y + 64);
332
      SetVector(v2, 99999, 99999, 99999);
333

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

373
// DoRender (setup)
374
//
375
procedure TGLNavCube.DoRender(var ARci: TGLRenderContextInfo;
376
  ARenderSelf, ARenderChildren: boolean);
377
begin
378
  inherited;
379
  if (FCam = nil) and (scene.CurrentGLCamera <> nil) then
380
  begin
381
    FCam := scene.CurrentGLCamera;
382
    FNavCam.Position.SetPoint
383
      (VectorScale(VectorNormalize(FCam.Position.AsVector), 10));
384
  end;
385
  if FViewer <> nil then
386
    FHud.Position.SetPoint(FViewer.Width - 80, 50, 0);
387
end;
388

389
initialization
390

391
sW2 := screen.Width div 2;
392
sH2 := screen.Height div 2;
393

394
end.
395

396