ArenaZ

1
unit uNCube;
2

3
{$IFDEF FPC}
4
  {$MODE Delphi}
5
{$ENDIF}
6

7
interface
8

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

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

32
    FPosAnimationStart: TVector;
33
    FPosAnimationEnd: TVector;
34

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

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

45
    property ActiveMouse: boolean read FMouse write FMouse;
46
    property InactiveTime: single read FInactiveTime write FInactiveTime;
47
  end;
48

49
var
50
  sW2, sH2: Integer;
51

52
implementation
53

54
// constructor
55
//
56
constructor TGLNCube.CreateAsChild(aParentOwner: TGLBaseSceneObject);
57

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

79
procedure SetColor(m: TGLMaterial; c: single);
80
begin
81
  m.FrontProperties.Diffuse.SetColor(c, c, 1);
82
end;
83

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

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

108
begin
109
  inherited CreateAsChild(aParentOwner);
110
  FDelta := 2;
111
  FFps := 30;
112
  FTimer := 10;
113
  FMouse := true;
114
  FInactiveTime := 0;
115

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

131

132

133
  FCube := TGLDummyCube.CreateAsChild(self);
134
  FCube.Visible := false;
135

136
  with TGLDisk.CreateAsChild(FCube) do
137
  begin
138
    Position.SetPoint(0, -0.805, 0);
139
    Direction.SetVector(0, 1, 0);
140
    InnerRadius := 0.9;
141
    OuterRadius := 1.3;
142
    Slices := 60;
143
    Loops := 1;
144
    SetColor(Material, 0.6);
145
  end;
146

147
  with TGLDisk.CreateAsChild(FCube) do
148
  begin
149
    Position.SetPoint(0, -0.8, 0);
150
    Direction.SetVector(0, 1, 0);
151
    InnerRadius := 0.95;
152
    OuterRadius := 1.25;
153
    Slices := 60;
154
    Loops := 1;
155
    SetColor(Material, 1);
156
  end;
157

158
  addPlane(0, 'FRONT', 1, 0, 0, 0.7, 0, 0, 1);
159
  addPlane(1, 'RIGHT', 1, 0.7, 0, 0, 1, 0, 0);
160
  addPlane(2, 'LEFT', 1, -0.7, 0, 0, -1, 0, 0);
161
  addPlane(3, 'BACK', 1, 0, 0, -0.7, 0, 0, -1);
162
  addPlane(4, 'TOP', 1, 0, 0.7, 0, 0, 1, 0);
163
  addPlane(5, 'BOTTOM', 1, 0, -0.7, 0, 0, -1, 0);
164

165
  addCube(6, 0.9, 0, 0.6, 0.6, 1, 0.2, 0.2);
166
  addCube(7, 0.9, 0, 0.6, -0.6, 1, 0.2, 0.2);
167
  addCube(8, 0.9, 0, -0.6, 0.6, 1, 0.2, 0.2);
168
  addCube(9, 0.9, 0, -0.6, -0.6, 1, 0.2, 0.2);
169

170
  addCube(10, 0.9, 0.6, 0.6, 0, 0.2, 0.2, 1);
171
  addCube(11, 0.9, 0.6, -0.6, 0, 0.2, 0.2, 1);
172
  addCube(12, 0.9, -0.6, 0.6, 0, 0.2, 0.2, 1);
173
  addCube(13, 0.9, -0.6, -0.6, 0, 0.2, 0.2, 1);
174

175
  addCube(14, 0.9, 0.6, 0, 0.6, 0.2, 1, 0.2);
176
  addCube(15, 0.9, 0.6, 0, -0.6, 0.2, 1, 0.2);
177
  addCube(16, 0.9, -0.6, 0, 0.6, 0.2, 1, 0.2);
178
  addCube(17, 0.9, -0.6, 0, -0.6, 0.2, 1, 0.2);
179

180
  addCube(18, 0.8, 0.6, 0.6, 0.6, 0.2, 0.2, 0.2);
181
  addCube(19, 0.8, 0.6, 0.6, -0.6, 0.2, 0.2, 0.2);
182
  addCube(20, 0.8, 0.6, -0.6, 0.6, 0.2, 0.2, 0.2);
183
  addCube(21, 0.8, -0.6, 0.6, 0.6, 0.2, 0.2, 0.2);
184
  addCube(22, 0.8, 0.6, -0.6, -0.6, 0.2, 0.2, 0.2);
185
  addCube(23, 0.8, -0.6, -0.6, 0.6, 0.2, 0.2, 0.2);
186
  addCube(24, 0.8, -0.6, 0.6, -0.6, 0.2, 0.2, 0.2);
187
  addCube(25, 0.8, -0.6, -0.6, -0.6, 0.2, 0.2, 0.2);
188

189
  FNavCam := TGLCamera.CreateAsChild(self);
190
  FNavCam.FocalLength := 55;
191
  FNavCam.TargetObject := self;//aParentOwner;//self;
192

193
  FMem := TGLMemoryViewer.Create(aParentOwner);
194
  FMem.Width := 128;
195
  FMem.Height := 128;
196
  FMem.Camera := FNavCam;
197
  with FMem.Buffer do
198
  begin
199
    BackgroundAlpha := 0;
200
    Antialiasing := aa6x;
201
    ContextOptions := [roDestinationAlpha];
202
    Lighting := false;
203
  end;
204

205
end;
206

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

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

230
begin
231
  if not (csloading in componentstate) then
232
  begin
233
  mp := FViewer.ScreenToClient(mouse.CursorPos);
234
  mover := (mp.x > FHud.Position.x - 64) and (mp.x < FHud.Position.x + 64) and
235
    (mp.y > FHud.Position.y - 64) and (mp.y < FHud.Position.y + 64);
236
  // mouse Down/Up
237
  if FDelta > 1 then
238
  begin
239
    if iskeydown(VK_LBUTTON) and (not FMouseRotation) then
240
    begin
241
   //    selection > start auto rotation
242
      if mover and (FSel >= 0) then
243
      begin
244
        v.z:=0;
245
        v.x:=0;
246
        if (FCam.TargetObject<>nil) then v := FCam.AbsoluteVectorToTarget;
247
        v.y := 0;
248
        if v.x < 0 then
249
          i := -1
250
        else
251
          i := 1;
252
        i := round((ArcCos(VectorAngleCosine(v, ZHmgPoint)) * i + PI) / PI
253
          * 2) mod 4;
254
        if (FSel = 4) or (FSel = 5) then
255
          moveTo(tb[FSel - 4][i])
256
        else
257
          moveTo(FSelPos);
258
        FInactiveTime := 0;
259
      end // start manual rotation
260
      else
261
      if FMouse then
262
      begin
263

264
        FMouseRotation := true;
265
        FMousePos := mouse.CursorPos;
266

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

277
      FInactiveTime := 0;
278
    end;
279
  end
280
  // auto rotation progress
281
  else
282
  begin
283
    FDelta := FDelta + pt.deltaTime * 2;
284
    v := VectorLerp(FPosAnimationStart, FPosAnimationEnd,
285
      FDelta * FDelta * (3 - 2 * FDelta));
286
    v := VectorScale(VectorNormalize(v), VectorLength(FPosAnimationStart));
287
    if FDelta < 1 then
288
      FCam.Position.SetPoint(v)
289
    else
290
      FCam.Position.SetPoint(FPosAnimationEnd);
291

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

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

309
    mp := mouse.CursorPos;
310
    if (FCam <> nil) and (FCam.TargetObject<>nil) then
311
      FCam.MoveAroundTarget((sH2 - mp.y) * 0.2, (sW2 - mp.x) * 0.2);
312
    FNavCam.MoveAroundTarget((sH2 - mp.y) * 0.2, (sW2 - mp.x) * 0.2);
313
    mouse.CursorPos := point(sW2, sH2);
314

315
    FInactiveTime := 0;
316
  end
317
  else if FReady then
318
  begin
319
    // selection
320
    if mover and (FDelta > 1) then
321
    begin
322
      v0 := FNavCam.AbsolutePosition;
323
      v1 := FMem.Buffer.ScreenToVector(mp.x - round(FHud.Position.x) + 64,
324
        round(FHud.Position.y) - mp.y + 64);
325
      SetVector(v2, 99999, 99999, 99999);
326

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

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

382
initialization
383

384
sW2 := screen.Width div 2;
385
sH2 := screen.Height div 2;
386

387
end.
388