MathgeomGLS

1
unit FMain;
2

3
interface
4

5
uses
6
  Winapi.Windows,
7
  Winapi.Messages,
8
  System.UITypes,
9
  System.Math,
10
  System.SysUtils,
11
  System.Variants,
12
  System.Classes,
13
  Vcl.Graphics,
14
  Vcl.Controls,
15
  Vcl.Forms,
16
  Vcl.Dialogs,
17
  Vcl.StdCtrls,
18
  Vcl.ExtCtrls,
19
  Vcl.Menus,
20
  Vcl.ComCtrls,
21
   
22
  GLS.VectorTypes,
23
  GLS.VectorTypesExt,
24
  GLS.PersistentClasses,
25
  GLS.Scene,
26
  GLS.SceneViewer,
27
  GLS.Objects,
28
  GLS.VectorFileObjects,
29
  GLS.VectorGeometry,
30
  GLS.State,
31
  GLS.Mesh,
32
  GLS.Color,
33
  GLS.Coordinates,
34
  
35
  GLS.BaseClasses,
36
  GLS.Spline,
37
  GLS.Material,
38
  GLS.Isosurface;
39

40
type
41
  TFrmMain = class(TForm)
42
    GLSceneViewer: TGLSceneViewer;
43
    Scene: TGLScene;
44
    Camera: TGLCamera;
45
    dcBox: TGLDummyCube;
46
    PUSerInterface: TPanel;
47
    Label1: TLabel;
48
    Label2: TLabel;
49
    lblVertices: TLabel;
50
    lblTriangles: TLabel;
51
    rbgAlgorithm: TRadioGroup;
52
    ffObject: TGLFreeForm;
53
    MatLib: TGLMaterialLibrary;
54
    Light: TGLLightSource;
55
    rbgWireFrameFill: TRadioGroup;
56
    tbSize: TTrackBar;
57
    tbIsoValue: TTrackBar;
58
    Label3: TLabel;
59
    Label4: TLabel;
60
    rbgShading: TRadioGroup;
61
    TrackBar1: TTrackBar;
62
    Label5: TLabel;
63
    rbgInterpolation: TRadioGroup;
64
    MainMenu: TMainMenu;
65
    File1: TMenuItem;
66
    New1: TMenuItem;
67
    Open1: TMenuItem;
68
    Save1: TMenuItem;
69
    SaveAs1: TMenuItem;
70
    Exit1: TMenuItem;
71
    N1: TMenuItem;
72
    N2: TMenuItem;
73
    OpenDialog: TOpenDialog;
74
    Help1: TMenuItem;
75
    SearchforHelpOn1: TMenuItem;
76
    About1: TMenuItem;
77
    N3: TMenuItem;
78
    procedure FormCreate(Sender: TObject);
79
    procedure FormMouseWheel(Sender: TObject; Shift: TShiftState;
80
      WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean);
81
    procedure GLSceneViewerMouseDown(Sender: TObject; Button: TMouseButton;
82
      Shift: TShiftState; X, Y: Integer);
83
    procedure GLSceneViewerMouseMove(Sender: TObject; Shift: TShiftState;
84
      X, Y: Integer);
85
    procedure rbgAlgorithmClick(Sender: TObject);
86
    function MakeSphere(Rad: Integer; var ADataout: TArray3DExt;
87
      var Dims: array of word; CPt: array of Integer): Integer;
88
    procedure rbgInvertClick(Sender: TObject);
89
    procedure tbSizeChange(Sender: TObject);
90
    procedure rbgShadingClick(Sender: TObject);
91
    procedure TrackBar1Change(Sender: TObject);
92
    procedure FormDestroy(Sender: TObject);
93
    procedure rbgWireFrameFillClick(Sender: TObject);
94
    procedure Exit1Click(Sender: TObject);
95
    procedure Open1Click(Sender: TObject);
96
  private
97
    ExtractedVertices: TVertexArray; // array of TVertex
98
    ExtractedTriangles: TIntegerArray; // array of Integer
99
    Dimensions: array ['x' .. 'z'] of Word;
100
    CenterPt: array ['x' .. 'z'] of Integer;
101
    CenterPts: array of array ['x' .. 'z'] of Integer;
102

103
    SingleData: TArray3DExt; // array of array of array of Single
104
    mdx, mdy: Integer;
105
    procedure GeneratePositions;
106
    procedure FillBlock;
107
        // Load Data from file
108
    function LoadCharData(AFileName: String; out ADataout: TArray3DExt;
109
      var Dims: array of word): Integer;
110

111
  end;
112

113
var
114
  FrmMain: TFrmMain;
115

116
implementation
117

118
{$R *.dfm}
119

120
procedure TFrmMain.FormCreate(Sender: TObject);
121
begin
122
  SingleData := nil;
123
  GeneratePositions;
124
  FillBlock;
125
end;
126

127
procedure TFrmMain.FormDestroy(Sender: TObject);
128
begin
129
  SetLength(SingleData, 0, 0, 0);
130
end;
131

132
procedure TFrmMain.rbgInvertClick(Sender: TObject);
133
begin
134
  FillBlock;
135
end;
136

137
procedure TFrmMain.GeneratePositions;
138
var
139
  DataAmount: Cardinal;
140
  i: Integer;
141
  X, Y, z: Integer;
142
begin
143
  // don't redraw when the trackbar is exited, already drawn when it was moved
144
  if TrackBar1.Position = Length(CenterPts) then
145
    Exit;
146

147
  Dimensions['x'] := tbSize.Position;
148
  Dimensions['y'] := tbSize.Position;
149
  Dimensions['z'] := tbSize.Position;
150

151
  SetLength(CenterPts, TrackBar1.Position);
152
  if TrackBar1.Position = 1 then
153
  begin
154
    CenterPts[0, 'x'] := 50;
155
    CenterPts[0, 'y'] := 50;
156
    CenterPts[0, 'z'] := 50;
157
  end
158
  else
159
    for i := 0 to TrackBar1.Position - 1 do
160
    begin
161
      CenterPts[i, 'x'] := Random(100);
162
      CenterPts[i, 'y'] := Random(100);
163
      CenterPts[i, 'z'] := Random(100);
164
    end;
165
end;
166

167
procedure TFrmMain.Exit1Click(Sender: TObject);
168
begin
169
  Close;
170
end;
171

172
procedure TFrmMain.FillBlock;
173
var
174
  DataAmount: cardinal;
175
  i: Integer;
176
  X, Y, Z: Integer;
177
begin
178
  Dimensions['x'] := tbSize.Position;
179
  Dimensions['y'] := tbSize.Position;
180
  Dimensions['z'] := tbSize.Position;
181
  SetLength(SingleData, 0, 0, 0);
182
  SetLength(SingleData, tbSize.Position, tbSize.Position, tbSize.Position);
183
  for i := 0 to TrackBar1.Position - 1 do
184
  begin
185
    CenterPt['x'] := round(CenterPts[i, 'x'] / 100 * tbSize.Position);
186
    CenterPt['y'] := round(CenterPts[i, 'y'] / 100 * tbSize.Position);
187
    CenterPt['z'] := round(CenterPts[i, 'z'] / 100 * tbSize.Position);
188
    MakeSphere(round(tbSize.Position / 2.5), SingleData, Dimensions, CenterPt);
189
  end;
190
  rbgAlgorithmClick(Self);
191
end;
192

193
// MakeSphere --------------------------------------------------------
194
function TFrmMain.MakeSphere(Rad: Integer; var ADataout: TArray3DExt;
195
  var Dims: array of word; CPt: array of Integer): Integer;
196
var
197
  X, Y, Z: Integer;
198
  DataPoint: Byte;
199
  Counter: Integer;
200
  v: single;
201
begin
202
  // SetLength(ADataout, Dims[0], Dims[1], Dims[2]);
203
  Counter := 0;
204

205
  for X := -Rad to Rad do
206
    for Y := -Rad to Rad do
207
      for Z := -Rad to Rad do
208
      begin
209
        v := Sin(DegToRad(((X + Rad) / (2 * Rad)) * 180)) *
210
          Sin(DegToRad(((Y + Rad) / (2 * Rad)) * 180)) *
211
          Sin(DegToRad(((Z + Rad) / (2 * Rad)) * 180));
212
        if (v > 0) and ((X + CPt[0]) >= 0) and ((X + CPt[0]) <= high(ADataout))
213
          and ((Y + CPt[1]) >= 0) and ((Y + CPt[1]) <= high(ADataout[0])) and
214
          ((z + CPt[2]) >= 0) and ((z + CPt[2]) <= high(ADataout[0, 0])) and
215
          (ADataout[X + CPt[0], Y + CPt[1], z + CPt[2]] < v * 255) then
216
          ADataout[X + CPt[0], Y + CPt[1], z + CPt[2]] := v * 255;
217
        inc(Counter);
218
      end;
219

220
  Result := Counter;
221
end;
222

223
procedure TFrmMain.Open1Click(Sender: TObject);
224
var
225
  DataAmount: Cardinal;
226

227
begin
228
  Dimensions['x'] := 27;  // only for Cube.vol sample
229
  Dimensions['y'] := 27;
230
  Dimensions['z'] := 27;
231

232
  OpenDialog.InitialDir := ExtractFilePath(ParamStr(0));
233
  OpenDialog.Filter := 'Volumes|*.vol';
234
  if OpenDialog.Execute() then
235
  begin
236
    DataAmount := LoadCharData(OpenDialog.FileName, SingleData, Dimensions);
237
    MessageDlg(format('%d read. %dx%dx%d', [DataAmount, Dimensions['x'],
238
      Dimensions['y'], Dimensions['z']]), mtInformation, [mbOK], -1);
239
  end;
240
  rbgAlgorithmClick(Self);
241
end;
242

243
procedure TFrmMain.rbgAlgorithmClick(Sender: TObject);
244
var
245
  IsoSurfaceEx: TGLIsoSurfaceExtractor;
246
  i: Integer;
247
  mo: TGLMeshObject;
248
begin
249
  // Create IsoSurfaceExtractor
250
  IsoSurfaceEx := TGLIsoSurfaceExtractor.Create(Dimensions['x'], Dimensions['y'],
251
    Dimensions['z'], SingleData);
252
  // Launch Calculation
253
  case rbgAlgorithm.ItemIndex of
254
    0:
255
      IsoSurfaceEx.MarchingTetrahedra(tbIsoValue.Position, ExtractedVertices,
256
        ExtractedTriangles, rbgInterpolation.ItemIndex.ToBoolean);
257
    1:
258
      IsoSurfaceEx.MarchingCubes(tbIsoValue.Position, ExtractedVertices,
259
        ExtractedTriangles, rbgInterpolation.ItemIndex.ToBoolean);
260
  end;
261

262
  lblVertices.Caption := Format('%d', [length(ExtractedVertices)]);
263
  lblTriangles.Caption := Format('%d', [length(ExtractedTriangles) div 3]);
264
  IsoSurfaceEx.Free();
265

266
  ffObject.MaterialLibrary := MatLib;
267

268
  ffObject.MeshObjects.Clear();
269
  mo := TGLMeshObject.CreateOwned(ffObject.MeshObjects);
270
  for i := length(ExtractedTriangles) - 1 downto 0 do
271
    with ExtractedVertices[ExtractedTriangles[i]] do
272
      mo.Vertices.Add(AffineVectorMake(X - Dimensions['x'] / 2,
273
        Y - Dimensions['y'] / 2, z - Dimensions['z'] / 2));
274

275
  ffObject.StructureChanged;
276
  rbgWireFrameFillClick(nil);
277
end;
278

279
procedure TFrmMain.tbSizeChange(Sender: TObject);
280
begin
281
  FillBlock;
282
end;
283

284
procedure TFrmMain.TrackBar1Change(Sender: TObject);
285
begin
286
  GeneratePositions;
287
  FillBlock;
288
end;
289

290

291
procedure TFrmMain.rbgShadingClick(Sender: TObject);
292
begin
293
  if rbgShading.ItemIndex = 0 then
294
    GLSceneViewer.Buffer.ShadeModel := smFlat
295
  else
296
    GLSceneViewer.Buffer.ShadeModel := smSmooth;
297
end;
298

299
procedure TFrmMain.rbgWireFrameFillClick(Sender: TObject);
300
begin
301
  if rbgWireFrameFill.ItemIndex = 0 then
302
    ffObject.Material.PolygonMode := pmFill
303
  else
304
    ffObject.Material.PolygonMode := pmLines;
305
  GLSceneViewer.Invalidate();
306
end;
307

308
procedure TFrmMain.FormMouseWheel(Sender: TObject; Shift: TShiftState;
309
  WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean);
310
begin
311
  Camera.AdjustDistanceToTarget(Power(1.1, WheelDelta / 120));
312
end;
313

314
procedure TFrmMain.GLSceneViewerMouseDown(Sender: TObject; Button: TMouseButton;
315
  Shift: TShiftState; X, Y: Integer);
316
begin
317
  mdx := X;
318
  mdy := Y;
319
end;
320

321
procedure TFrmMain.GLSceneViewerMouseMove(Sender: TObject; Shift: TShiftState;
322
  X, Y: Integer);
323
var
324
  dx, dy: Integer;
325
  v: TGLVector;
326
begin
327
  // calculate delta since last move or last mousedown
328
  dx := mdx - X;
329
  dy := mdy - Y;
330
  mdx := X;
331
  mdy := Y;
332
  if ssLeft in Shift then
333
  begin
334
    if ssShift in Shift then
335
    begin
336
      // right button with shift rotates the teapot
337
      // (rotation happens around camera's axis)
338
      Camera.RotateObject(dcBox, dy, dx);
339
    end
340
    else
341
    begin
342
      // right button without shift changes camera angle
343
      // (we're moving around the parent and target dummycube)
344
      Camera.MoveAroundTarget(dy, dx)
345
    end;
346
  end
347
  else if Shift = [ssRight] then
348
  begin
349
    // left button moves our target and parent dummycube
350
    v := Camera.ScreenDeltaToVectorXY(dx, -dy,
351
      0.12 * Camera.DistanceToTarget / Camera.FocalLength);
352
    dcBox.Position.Translate(v);
353
    // notify camera that its position/target has been changed
354
    Camera.TransformationChanged;
355
  end;
356
end;
357

358
// LoadCharData --------------------------------------------------------------
359
function TFrmMain.LoadCharData(aFileName: String; out aDataout: TArray3DExt;
360
  var Dims: array of word): Integer;
361

362
var
363
  DataFile: File of Byte;
364
  i, j, k: Integer;
365
  DataPoint: Byte;
366
  Counter: Integer;
367

368
begin
369
  AssignFile(DataFile, aFileName);
370
  Reset(DataFile);
371
  SetLength(aDataout, Dims[0], Dims[1], Dims[2]);
372
  i := 0;
373
  j := 0;
374
  k := 0;
375
  Counter := 0;
376
  try
377
    repeat
378
      Read(DataFile, DataPoint);
379
      aDataout[i, j, k] := DataPoint;
380
      inc(i);
381
      if (i = Dims[0]) then
382
      begin
383
        i := 0;
384
        inc(j);
385
      end;
386
      if (j = Dims[1]) then
387
      begin
388
        j := 0;
389
        inc(k);
390
      end;
391
      inc(Counter);
392
    until Eof(DataFile);
393
  finally
394
    Closefile(DataFile);
395
  end;
396
  Result := Counter;
397
end;
398

399
end.
400