MathgeomGLS

1
unit fEllipsoid;
2

3
interface
4

5
uses
6
  Winapi.Windows,
7
  Winapi.Messages,
8
  System.SysUtils,
9
  System.Variants,
10
  System.Classes,
11
  System.Math,
12
  Vcl.Graphics,
13
  Vcl.Controls,
14
  Vcl.Forms,
15
  Vcl.Dialogs,
16
  Vcl.Buttons,
17
  Vcl.ButtonGroup,
18
  Vcl.StdCtrls,
19
  Vcl.ComCtrls,
20
  Vcl.ExtCtrls,
21

22
  GLS.OpenGLTokens,
23
  GLS.SceneViewer,
24
  GLS.BaseClasses,
25
  GLS.Scene,
26
  GLS.GeomObjects,
27
  GLS.Objects,
28
  GLS.Coordinates,
29
  GLS.Graph,
30
  GLS.VectorLists,
31
  GLS.VectorTypes,
32
  GLS.Mesh,
33
  GLS.HUDObjects,
34
  GLS.BitmapFont,
35
  GLS.WindowsFont,
36
  GLS.VectorGeometry,
37
  GLS.Color,
38
  GLS.Texture,
39
  GLS.Context,
40
  GLS.Cadencer;
41

42
type
43
  TFormEllipsoid = class(TForm)
44
    StatusBar: TStatusBar;
45
    GLScene1: TGLScene;
46
    GLSceneViewer1: TGLSceneViewer;
47
    CameraCube: TGLDummyCube;
48
    Camera: TGLCamera;
49
    ObjectsCube: TGLDummyCube;
50
    ArrowZ: TGLArrowLine;
51
    ArrowY: TGLArrowLine;
52
    ArrowX: TGLArrowLine;
53
    GLLightSource1: TGLLightSource;
54
    Panel1: TPanel;
55
    Label1: TLabel;
56
    Label2: TLabel;
57
    Label3: TLabel;
58
    Label4: TLabel;
59
    Label5: TLabel;
60
    Label6: TLabel;
61
    Label7: TLabel;
62
    Label8: TLabel;
63
    Label9: TLabel;
64
    Label10: TLabel;
65
    Label12: TLabel;
66
    xRadiusTrackBar: TTrackBar;
67
    yRadiusTrackBar: TTrackBar;
68
    zRadiusTrackBar: TTrackBar;
69
    VCurveTrackBar: TTrackBar;
70
    HCurveTrackBar: TTrackBar;
71
    GridCheckBox: TCheckBox;
72
    ArrowsCheckBox: TCheckBox;
73
    SlicesTrackBar: TTrackBar;
74
    StacksTrackBar: TTrackBar;
75
    TopCapRadioGroup: TRadioGroup;
76
    BottomTrackBar: TTrackBar;
77
    TopTrackBar: TTrackBar;
78
    StartTrackBar: TTrackBar;
79
    StopTrackBar: TTrackBar;
80
    BottomCapRadioGroup: TRadioGroup;
81
    Button1: TButton;
82
    GLXYZGridXZ: TGLXYZGrid;
83
    GLWindowsBitmapFont1: TGLWindowsBitmapFont;
84
    GLHUDText: TGLHUDText;
85
    Button2: TButton;
86
    GLCadencer1: TGLCadencer;
87
    GLLightSource: TGLLightSource;
88
    GLSuperellipsoid: TGLSuperellipsoid;
89
    GLMesh: TGLMesh;
90
    procedure FormShow(Sender: TObject);
91
    procedure FormCreate(Sender: TObject);
92
    procedure GLSceneViewer1MouseDown(Sender: TObject; Button: TMouseButton;
93
      Shift: TShiftState; X, Y: Integer);
94
    procedure GLSceneViewer1MouseMove(Sender: TObject; Shift: TShiftState;
95
      X, Y: Integer);
96
    procedure GLSceneViewer1MouseUp(Sender: TObject; Button: TMouseButton;
97
      Shift: TShiftState; X, Y: Integer);
98

99
    procedure RadiusTrackBarChange(Sender: TObject);
100
    procedure VCurveTrackBarChange(Sender: TObject);
101
    procedure HCurveTrackBarChange(Sender: TObject);
102
    procedure SlicesTrackBarChange(Sender: TObject);
103
    procedure StacksTrackBarChange(Sender: TObject);
104
    procedure GridCheckBoxClick(Sender: TObject);
105
    procedure ArrowsCheckBoxClick(Sender: TObject);
106
    procedure TopTrackBarChange(Sender: TObject);
107
    procedure BottomTrackBarChange(Sender: TObject);
108
    procedure TopCapRadioGroupClick(Sender: TObject);
109
    procedure BottomCapRadioGroupClick(Sender: TObject);
110
    procedure StartTrackBarChange(Sender: TObject);
111
    procedure StopTrackBarChange(Sender: TObject);
112
    procedure Button1Click(Sender: TObject);
113
    procedure checkclick(Sender: TObject);
114
    procedure CheckBoxClick(Sender: TObject);
115
    procedure Button2Click(Sender: TObject);
116
  private
117
    MousePoint: TPoint;
118
    Superellipsoids: array [0 .. 5, 0 .. 5] of TGLSuperellipsoid;
119
    procedure ShowCameraLocation;
120
    procedure ShowFocalLength;
121
    procedure ShowDisplacement;
122
    procedure ShowSuperellipsoid;
123
  public
124

125
  end;
126

127
var
128
  FormEllipsoid: TFormEllipsoid;
129

130
implementation
131

132
{$R *.dfm}
133
{$R CURSORS.RES}
134

135
const
136
  crLightxz = 1;
137
  crLightyz = 2;
138
  crLightxy = 3;
139
  crSlidexy = 4;
140
  crSlideyz = 5;
141
  crSlidexz = 6;
142
  crRotate = 7;
143
  crZoom = 8;
144
  crHandMove = 9;
145

146
procedure TFormEllipsoid.ArrowsCheckBoxClick(Sender: TObject);
147
begin
148
  ArrowX.Visible := not ArrowsCheckBox.Checked;
149
  ArrowY.Visible := ArrowX.Visible;
150
  ArrowZ.Visible := ArrowX.Visible;
151
end;
152

153
procedure TFormEllipsoid.FormCreate(Sender: TObject);
154
begin
155
  Screen.Cursors[crSlidexy] := LoadCursor(HInstance, 'SLIDEXY');
156
  Screen.Cursors[crRotate] := LoadCursor(HInstance, 'ROTATE');
157
  Screen.Cursors[crZoom] := LoadCursor(HInstance, 'ZOOM');
158

159
  Randomize;
160
  GLSuperellipsoid := TGLSuperellipsoid
161
    (GLScene1.Objects.AddNewChild(TGLSuperellipsoid));
162
  GLSuperellipsoid.Direction.SetVector(0, 0, 1);
163
  GLSuperellipsoid.Up.SetVector(0, 1, 0);
164
  GLSuperellipsoid.Position.SetPoint(0, 1, 0);
165
  GLSuperellipsoid.Material.FrontProperties.Ambient.RandomColor;
166
  GLSuperellipsoid.Material.FrontProperties.Diffuse.RandomColor;
167
  GLSuperellipsoid.Material.FrontProperties.Shininess := 100;
168
end;
169

170
procedure TFormEllipsoid.FormShow(Sender: TObject);
171
begin
172
  ShowCameraLocation;
173
  (* focallength: right mouse drag up/down *)
174
  ShowFocalLength;
175
  (*
176
    displace origin: x axis: ctrl/left mouse drag left/right
177
    y axis: ctrl/left mouse drag up/down
178
  *)
179
  ShowDisplacement;
180
  (*
181
    move light: x axis: ctrl right mouse drag left/right
182
    y axis: ctrl right mouse drag up/down
183
    z axis: shift right mouse drag up/down
184
  *)
185
  ShowSuperellipsoid;
186
end;
187

188
procedure TFormEllipsoid.GLSceneViewer1MouseDown(Sender: TObject;
189
  Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
190
begin
191
  MousePoint.X := X;
192
  MousePoint.Y := Y;
193
  if ssShift in Shift then
194
  begin
195
    if ssLeft in Shift then
196
      Screen.Cursor := crZoom
197
    else if ssRight in Shift then
198
      Screen.Cursor := crLightxz;
199
  end
200
  else if ssCtrl in Shift then
201
  begin
202
    if ssLeft in Shift then
203
      Screen.Cursor := crSlidexy
204
    else if ssRight in Shift then
205
      Screen.Cursor := crLightxy;
206
  end
207
  else { no shift or ctrl key }
208
  begin
209
    if Shift = [ssLeft] then
210
      Screen.Cursor := crRotate
211
    else if Shift = [ssRight] then
212
      Screen.Cursor := crZoom;
213
  end;
214
end;
215

216
procedure TFormEllipsoid.GLSceneViewer1MouseMove(Sender: TObject; Shift: TShiftState;
217
  X, Y: Integer);
218
var
219
  dx, dy: Integer;
220
  nx, nz, d: TGLFloat;
221

222
begin { refer GLScene\Demos\interface\camera\Camera.dpr }
223
  dx := MousePoint.X - X;
224
  dy := MousePoint.Y - Y;
225
  if ssShift in Shift then { shift key down }
226
  begin
227
    if ssLeft in Shift then { left mouse button }
228
    begin
229
      { dy = a step which adjusts target distance by 1.25%; zoom in or out }
230
      with Camera do
231
        AdjustDistanceToTarget(Power(1.0125, dy));
232
      ShowCameraLocation;
233
    end
234
  end
235
  else if ssCtrl in Shift then { Ctrl key down }
236
  begin
237
    if ssLeft in Shift then { left mouse button }
238
    begin
239
      nz := Camera.Position.Z * dy;
240
      nx := Camera.Position.Z * dx;
241
      d := 5 * Camera.FocalLength;
242
      with CameraCube.Position do
243
      begin
244
        Z := Z - nz / d;
245
        X := X - nx / d;
246
      end;
247
      ShowDisplacement;
248
    end
249
  end
250
  else { no shift key }
251
  begin
252
    if Shift = [ssLeft] then
253
    { Left mouse button changes camera angle by moving around target }
254
    begin
255
      Camera.MoveAroundTarget(dy, dx);
256
      ShowCameraLocation;
257
    end;
258
    if Shift = [ssRight] then
259
    begin
260
      { Right mouse button alters the camera's focal length;
261
        zoom out or in by moving cursor up or down }
262
      with Camera do
263
      begin
264
        FocalLength := FocalLength - dy;
265
        if FocalLength > 1000 then
266
          FocalLength := 1000; { max focal length }
267
        if FocalLength < 20 then
268
          FocalLength := 20; { min focal length }
269
      end;
270
      ShowFocalLength; { display in statusbar palel }
271
    end;
272
  end;
273
  MousePoint.X := X; { update mouse position }
274
  MousePoint.Y := Y;
275
end;
276

277
procedure TFormEllipsoid.GLSceneViewer1MouseUp(Sender: TObject; Button: TMouseButton;
278
  Shift: TShiftState; X, Y: Integer);
279
begin
280
  Screen.Cursor := crDefault;
281
end;
282

283
procedure TFormEllipsoid.GridCheckBoxClick(Sender: TObject);
284
begin
285
  GLXYZGridXZ.Visible := not GridCheckBox.Checked;
286
end;
287

288
procedure TFormEllipsoid.CheckBoxClick(Sender: TObject);
289
begin
290
  ShowSuperellipsoid;
291
end;
292

293
procedure TFormEllipsoid.VCurveTrackBarChange(Sender: TObject);
294
var
295
  n: TGLFloat;
296

297
begin
298
  n := VCurveTrackBar.Position / 10;
299
  GLSuperellipsoid.VCurve := n;
300
  ShowSuperellipsoid;
301
end;
302

303
procedure TFormEllipsoid.HCurveTrackBarChange(Sender: TObject);
304
var
305
  n: TGLFloat;
306

307
begin
308
  n := HCurveTrackBar.Position / 10;
309
  GLSuperellipsoid.HCurve := n;
310
  ShowSuperellipsoid;
311
end;
312

313
procedure TFormEllipsoid.ShowCameraLocation;
314
begin
315
  with Camera.Position do
316
    StatusBar.Panels[0].Text := 'Camera: ' + FloatToStrF(X, ffNumber, 5, 2) +
317
      ', ' + FloatToStrF(Y, ffNumber, 5, 2) + ', ' +
318
      FloatToStrF(Z, ffNumber, 5, 2);
319
end;
320

321
procedure TFormEllipsoid.ShowFocalLength;
322
begin
323
  with Camera do
324
    StatusBar.Panels[1].Text := 'f = ' + FloatToStrF(FocalLength,
325
      ffNumber, 5, 2);
326
end;
327

328
procedure TFormEllipsoid.ShowDisplacement;
329
begin
330
  with CameraCube.Position do
331
    StatusBar.Panels[2].Text := 'Displaced: ' + FloatToStrF(-X, ffNumber, 5, 2)
332
      + ', ' + FloatToStrF(-Y, ffNumber, 5, 2);
333
end;
334

335
procedure TFormEllipsoid.ShowSuperellipsoid;
336
begin
337
  // Superellipsoid.NormalDirection := ndInside;
338
  // Superellipsoid.Normals :=
339
  (*
340
    Determines how and if normals are smoothed.
341
    - nsFlat : facetted look
342
    - nsSmooth : smooth look
343
    - nsNone : unlighted rendering, usefull for decla texturing
344
  *)
345
  GLSuperellipsoid.Scale.SetVector(xRadiusTrackBar.Position,
346
    yRadiusTrackBar.Position, zRadiusTrackBar.Position);
347
  GLSuperellipsoid.Slices := SlicesTrackBar.Position;
348
  GLSuperellipsoid.Stacks := StacksTrackBar.Position;
349
  GLSuperellipsoid.Top := TopTrackBar.Position;
350

351
  case TopCapRadioGroup.ItemIndex of
352
    0: GLSuperellipsoid.TopCap := ctNone;
353
    1: GLSuperellipsoid.TopCap := ctCenter;
354
    2: GLSuperellipsoid.TopCap := ctFlat;
355
  end;
356

357
  GLSuperellipsoid.Bottom := -BottomTrackBar.Position;
358

359
  case BottomCapRadioGroup.ItemIndex of
360
    0: GLSuperellipsoid.BottomCap := ctNone;
361
    1: GLSuperellipsoid.BottomCap := ctCenter;
362
    2: GLSuperellipsoid.BottomCap := ctFlat;
363
  end;
364

365
  if (StartTrackBar.Position <= StopTrackBar.Position) and
366
    (StartTrackBar.Position < 360) then
367
  begin
368
    GLSuperellipsoid.Start := StartTrackBar.Position;
369
    GLSuperellipsoid.Stop := StopTrackBar.Position;
370
  end;
371
  GLSuperellipsoid.Normals := nsNone;
372
  GLHUDText.Text := 'Scale:' + FloatToStrF(xRadiusTrackBar.Position / 10,
373
    ffNumber, 6, 2) + ', ' + FloatToStrF(yRadiusTrackBar.Position / 10,
374
    ffNumber, 6, 2) + ', ' + FloatToStrF(zRadiusTrackBar.Position / 10,
375
    ffNumber, 6, 2) + #13#10'VCurve:' +
376
    FloatToStrF(VCurveTrackBar.Position / 10, ffNumber, 6, 2) + #13#10'HCurve:'
377
    + FloatToStrF(HCurveTrackBar.Position / 10, ffNumber, 6, 2) +
378
    #13#10'Slices:' + IntToStr(SlicesTrackBar.Position) + #13#10'Stacks:' +
379
    IntToStr(StacksTrackBar.Position) + #13#10'Top:' +
380
    IntToStr(TopTrackBar.Position) + '�' + #13#10'Bottom:' +
381
    IntToStr(BottomTrackBar.Position) + '�' + #13#10'Start:' +
382
    IntToStr(StartTrackBar.Position) + '�' + #13#10'Stop:' +
383
    IntToStr(StopTrackBar.Position) + '�';
384
end;
385

386
procedure TFormEllipsoid.SlicesTrackBarChange(Sender: TObject);
387
begin
388
  ShowSuperellipsoid;
389
end;
390

391
procedure TFormEllipsoid.StacksTrackBarChange(Sender: TObject);
392
begin
393
  ShowSuperellipsoid;
394
end;
395

396
procedure TFormEllipsoid.StartTrackBarChange(Sender: TObject);
397
begin
398
  if (StartTrackBar.Position >= StopTrackBar.Position) then
399
    StartTrackBar.Position := StopTrackBar.Position;
400
  ShowSuperellipsoid;
401
end;
402

403
procedure TFormEllipsoid.TopCapRadioGroupClick(Sender: TObject);
404
begin
405
  ShowSuperellipsoid;
406
end;
407

408
procedure TFormEllipsoid.TopTrackBarChange(Sender: TObject);
409
begin
410
  ShowSuperellipsoid;
411
end;
412

413
procedure TFormEllipsoid.StopTrackBarChange(Sender: TObject);
414
begin
415
  if (StopTrackBar.Position <= StartTrackBar.Position) then
416
    StopTrackBar.Position := StartTrackBar.Position;
417
  ShowSuperellipsoid;
418
end;
419

420
procedure TFormEllipsoid.BottomCapRadioGroupClick(Sender: TObject);
421
begin
422
  ShowSuperellipsoid;
423
end;
424

425
procedure TFormEllipsoid.BottomTrackBarChange(Sender: TObject);
426
begin
427
  ShowSuperellipsoid;
428
end;
429

430
procedure TFormEllipsoid.Button1Click(Sender: TObject);
431
begin
432
  with GLSuperellipsoid.Material.Texture do
433
  begin
434
    // We need a CubeMapImage, which unlike the "regular Images" stores
435
    // multiple images.
436
    ImageClassName := TGLCubeMapImage.ClassName;
437
    with Image as TGLCubeMapImage do
438
    begin
439
      // Load all 6 texture map components of the cube map
440
      // The 'PX', 'NX', etc. refer to 'positive X', 'negative X', etc.
441
      // and follow the RenderMan specs/conventions
442
      Picture[cmtNX].LoadFromFile('cm_left.png');
443
      Picture[cmtPX].LoadFromFile('cm_right.png');
444
      Picture[cmtNY].LoadFromFile('cm_top.png');
445
      Picture[cmtPY].LoadFromFile('cm_bottom.png');
446
      Picture[cmtPZ].LoadFromFile('cm_back.png');
447
      Picture[cmtNZ].LoadFromFile('cm_front.png');
448
    end;
449
    // Select reflection cube map environment mapping
450
    // This is the mode you'll most commonly use with cube maps, normal cube
451
    // map generation is also supported (used for diffuse environment lighting)
452
    MappingMode := tmmCubeMapReflection;
453
    // That's all folks, let us see the thing!
454
    Disabled := False;
455
  end;
456
  Button1.Visible := False;
457
end;
458

459
procedure TFormEllipsoid.Button2Click(Sender: TObject);
460
var
461
  i, j: Integer;
462
  X, Y, d: single;
463
begin
464
  d := 6;
465
  Randomize;
466
  for j := 0 to 5 do
467
    for i := 0 to 5 do
468
    begin
469
      X := -d * 2.5 + d * i;
470
      Y := d * 2.5 - d * j;
471
      Superellipsoids[i, j] := TGLSuperellipsoid
472
        (GLScene1.Objects.AddNewChild(TGLSuperellipsoid));
473

474
      with Superellipsoids[i, j] do
475
      begin
476
        Slices := 32;
477
        Stacks := 32;
478
        Scale.SetVector(5, 5, 5);
479
        Position.SetPoint(X, Y, 0);
480
        Direction.SetVector(0, 1, 0);
481
        Up.SetVector(0, 0, 1);
482
        case i of
483
          0: VCurve := 0.2;
484
          1: VCurve := 0.8;
485
          2: VCurve := 1.0;
486
          3: VCurve := 1.5;
487
          4: VCurve := 2.0;
488
          5: VCurve := 3.0;
489
        end;
490
        case j of
491
          0: HCurve := 0.2;
492
          1: HCurve := 0.8;
493
          2: HCurve := 1.0;
494
          3: HCurve := 1.5;
495
          4: HCurve := 2.0;
496
          5: HCurve := 3.0;
497
        end;
498
        with Material.FrontProperties do
499
        begin
500
          Ambient.RandomColor;
501
          Diffuse.RandomColor;
502
          Specular.RandomColor;
503
          Shininess := 125;
504
        end;
505
      end;
506
    end;
507
  Button2.Visible := False;
508
end;
509

510
procedure TFormEllipsoid.checkclick(Sender: TObject);
511
begin
512
  ShowSuperellipsoid;
513
end;
514

515
procedure TFormEllipsoid.RadiusTrackBarChange(Sender: TObject);
516
begin
517
  ShowSuperellipsoid;
518
end;
519

520
end.
521