MathgeomGLS

1
unit fIsoSurfaces;
2

3
interface
4

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

21
  GLS.SceneViewer,
22

23
  GLS.BaseClasses,
24
  GLS.Scene,
25
  GLS.Objects,
26
  GLS.Coordinates,
27
  GLS.Color,
28
  GLS.VectorGeometry,
29
  GLS.Mesh,
30
  GLS.VectorFileObjects,
31
  GLS.State,
32
  GLS.GeomObjects,
33
  GLS.Extrusion,
34
  GLS.VectorTypesExt,
35
  GLS.IsosurFace,
36
  GLS.SimpleNavigation,
37
  GLS.Material;
38

39
type
40
  TForm1 = class(TForm)
41
    Scene: TGLScene;
42
    Viewer: TGLSceneViewer;
43
    Camera: TGLCamera;
44
    dcWorld: TGLDummyCube;
45
    Light: TGLLightSource;
46
    meshSurf: TGLMesh;
47
    SimpleNavigation: TGLSimpleNavigation;
48
    freeSurf: TGLFreeForm;
49
    PanelLeft: TPanel;
50
    rgSurface: TRadioGroup;
51
    Label2: TLabel;
52
    edIsoValue: TEdit;
53
    bbRunMC: TBitBtn;
54
    cbFillLines: TCheckBox;
55
    rgScalarField: TRadioGroup;
56
    rgFaceCulling: TRadioGroup;
57
    tbIsoValue: TTrackBar;
58
    procedure FormDestroy(Sender: TObject);
59
    procedure cbFillLinesClick(Sender: TObject);
60
    procedure FormCreate(Sender: TObject);
61
    procedure bbRunMCClick(Sender: TObject);
62
    procedure rgSurfaceClick(Sender: TObject);
63
    procedure rgScalarFieldClick(Sender: TObject);
64
    procedure rgFaceCullingClick(Sender: TObject);
65
    procedure tbIsoValueChange(Sender: TObject);
66
  private
67
    meshObj: TGLMeshObject;
68
    MC: TGLMarchingCube;
69
  end;
70

71
(*
72
// Sphere surface
73
function SFSphere(X, Y, Z: Extended): TScalarValue;
74
// Minkowski space (http://mathworld.wolfram.com)
75
function SFMinkowski(X, Y, Z: Extended): TScalarValue;
76
// Klein Bottle (http://mathworld.wolfram.com)
77
function SFKleinBottle(X, Y, Z: Extended): TScalarValue;
78
// Chmutov-surface-1 (http://mathworld.wolfram.com)
79
function SFChmutov1(X, Y, Z: Extended): TScalarValue;
80
// Chmutov-surface-2 (http://mathworld.wolfram.com)
81
function SFChmutov2(X, Y, Z: Extended): TScalarValue;
82
// Toroidal surface (phantasy!)
83
function SFToroidal(X, Y, Z: Extended): TScalarValue;
84
// Double torus Surface (phantasy!)
85
function SFDoubleTorus(X, Y, Z: Extended): TScalarValue;
86
*)
87
const
88
  DemoScalarField: array [0 .. 6] of
89
  record
90
    // xMin, xMax, yMin, yMax, zMin, zMax:Single; // default -0.5..0.5
91
    ScalarField: TScalarField;
92
    IsoValue: TScalarValue
93
  end = ((ScalarField: SFSphere; IsoValue: 0.3),
94
         (ScalarField: SFMinkowski; IsoValue: 0.0),
95
         (ScalarField: SFKleinBottle; IsoValue: 0.0),
96
         (ScalarField: SFChmutov1; IsoValue: 3.0),
97
         (ScalarField: SFChmutov2; IsoValue: 3.0),
98
         (ScalarField: SFToroidal; IsoValue: 3.0),
99
         (ScalarField: SFDoubleTorus; IsoValue: 0.015));
100

101
var
102
  Form1: TForm1;
103

104
//===========================================
105
implementation
106
//===========================================
107

108
{$R *.dfm}
109

110
(*
111
// Test surface functions
112
function SFSphere(X, Y, Z: Extended): TScalarValue;
113
begin
114
  Result := sqr(X) + sqr(Y) + sqr(Z)
115
end;
116

117
function SFToroidal(X, Y, Z: Extended): TScalarValue;
118
const
119
  FScale = 7;
120
  a = 2.5;
121
begin
122
  X := FScale * X;
123
  Y := FScale * Y;
124
  Z := FScale * Z;
125
  Result := (sqr(sqrt(sqr(X) + sqr(Y)) - a) + sqr(Z)) *
126
    (sqr(sqrt(sqr(Y) + sqr(Z)) - a) + sqr(X)) *
127
    (sqr(sqrt(sqr(Z) + sqr(X)) - a) + sqr(Y));
128
end;
129

130
function SFDoubleTorus(X, Y, Z: Extended): TScalarValue;
131
const
132
  FScale = 2.25;
133
begin
134
  X := FScale * X;
135
  Y := FScale * Y;
136
  Z := FScale * Z;
137
  Result := PowerInteger(X, 8) + PowerInteger(X, 4) - 2 * PowerInteger(X, 6) - 2
138
    * sqr(X) * sqr(Y) + 2 * PowerInteger(X, 4) * sqr(Y) +
139
    PowerInteger(Y, 4) + sqr(Z)
140
end;
141

142
function SFChmutov1(X, Y, Z: Extended): TScalarValue;
143
const
144
  FScale = 2.5;
145
begin
146
  X := FScale * X;
147
  Y := FScale * Y;
148
  Z := FScale * Z;
149
  Result := 8 * (sqr(X) + sqr(Y) + sqr(Z)) - 8 *
150
    (PowerInteger(X, 4) + PowerInteger(Y, 4) + PowerInteger(Z, 4));
151
end;
152

153
function SFChmutov2(X, Y, Z: Extended): TScalarValue;
154
const
155
  FScale = 2.5;
156
begin
157
  X := FScale * X;
158
  Y := FScale * Y;
159
  Z := FScale * Z;
160
  Result := 2 * (sqr(X) * sqr(3 - 4 * sqr(X)) + sqr(Y) * sqr(3 - 4 * sqr(Y)) +
161
    sqr(Z) * sqr(3 - 4 * sqr(Z)));
162
end;
163

164
function SFKleinBottle(X, Y, Z: Extended): TScalarValue;
165
const
166
  FScale = 7.5;
167
begin
168
  X := FScale * X;
169
  Y := FScale * Y;
170
  Z := FScale * Z;
171
  Result := (sqr(X) + sqr(Y) + sqr(Z) + 2 * Y - 1) *
172
    (sqr(sqr(X) + sqr(Y) + sqr(Z) - 2 * Y - 1) - 8 * sqr(Z)) + 16 * X * Z *
173
    (sqr(X) + sqr(Y) + sqr(Z) - 2 * Y - 1);
174
end;
175

176
function SFMinkowski(X, Y, Z: Extended): TScalarValue;
177
const
178
  FScale = 7;
179
begin
180
  X := FScale * X;
181
  Y := FScale * Y;
182
  Z := FScale * Z;
183
  Result := (sqr(X) - sqr(Y) - sqr(Z) - 2) * (sqr(X) - sqr(Y) - sqr(Z) + 2) *
184
    (sqr(X) - sqr(Y) - sqr(Z) - 4) * (sqr(X) - sqr(Y) - sqr(Z) + 4) *
185
    (sqr(X) - sqr(Y) - sqr(Z));
186
end;
187

188
*)
189

190
//----------------------------------------------------
191

192
procedure TForm1.FormCreate(Sender: TObject);
193
begin
194
  MC := TGLMarchingCube.Create(100, 100, 100);
195

196
  meshObj := TGLMeshObject.CreateOwned(freeSurf.MeshObjects);
197
  meshObj.Mode := momFaceGroups;
198

199
  Light.Position.SetPoint(100, 200, 300);
200
  Light.Ambient.SetColor(0.6, 0.6, 0.0, 0.1);
201
  Light.Diffuse.SetColor(0.2, 0.4, 1.0, 0.1);
202
  Light.Specular.SetColor(1.0, 1.0, 1.0, 0.1);
203

204
  if rgSurface.ItemIndex = 0 then // using GLFreeForm
205
    meshSurf.Visible := False
206
  else // using GLMesh
207
    freeSurf.Visible := False;
208

209
  cbFillLinesClick(Self);
210
  bbRunMCClick(Self)
211
end;
212

213
procedure TForm1.FormDestroy(Sender: TObject);
214
begin
215
  MC.Free;
216
  meshObj.Free;
217
end;
218

219
procedure TForm1.cbFillLinesClick(Sender: TObject);
220
begin
221
  if rgSurface.ItemIndex = 0 then // using TGLFreeForm
222
  begin
223
    if cbFillLines.Checked then
224
      freeSurf.Material.PolygonMode := pmFill
225
    else
226
      freeSurf.Material.PolygonMode := pmLines
227
  end
228
  else // using TGLMesh
229
  begin
230
    if cbFillLines.Checked then
231
      meshSurf.Material.PolygonMode := pmFill
232
    else
233
      meshSurf.Material.PolygonMode := pmLines
234
  end;
235
end;
236

237
procedure TForm1.rgScalarFieldClick(Sender: TObject);
238
begin
239
  edIsoValue.Text := FloatToStr(DemoScalarField[rgScalarField.ItemIndex].IsoValue);
240
  bbRunMCClick(Self)
241
end;
242

243
procedure TForm1.rgFaceCullingClick(Sender: TObject);
244
begin
245
  if rgSurface.ItemIndex = 0 then
246
    freeSurf.Material.FaceCulling := TGLFaceCulling(rgFaceCulling.ItemIndex)
247
  else
248
    meshSurf.Material.FaceCulling := TGLFaceCulling(rgFaceCulling.ItemIndex);
249
end;
250

251
procedure TForm1.bbRunMCClick(Sender: TObject);
252
var
253
  IsoValue: TScalarValue;
254
begin
255
  // try to accept user value, but if uncorrect assign a correct demo value
256
  IsoValue := StrToFloatDef(edIsoValue.Text, DemoScalarField[rgScalarField.ItemIndex].IsoValue);
257
  edIsoValue.Text := FormatFloat('0.0000', IsoValue);
258

259
  MC.FillVoxelData(IsoValue, DemoScalarField[rgScalarField.ItemIndex].ScalarField);
260
  MC.Run;
261

262
  if rgSurface.ItemIndex = 0 then // using GLFreeForm
263
  begin
264
    meshObj.Free;
265
    meshObj := TGLMeshObject.CreateOwned(freeSurf.MeshObjects);
266
    meshObj.Mode := momFaceGroups;
267
    MC.CalcMeshObject(meshObj, 0.6);
268
  end
269
  else // using GLMesh
270
    MC.CalcVertices(meshSurf.Vertices);
271
  Viewer.Invalidate;
272
end;
273

274
procedure TForm1.rgSurfaceClick(Sender: TObject);
275
begin
276
  if rgSurface.ItemIndex = 0 then // using GLFreeForm
277
  begin
278
    meshSurf.Visible := False;
279
    freeSurf.Visible := True;
280
  end
281
  else  // using GLMesh
282
  begin
283
    freeSurf.Visible := False;
284
    meshSurf.Visible := True;
285
  end;
286
  cbFillLinesClick(Self);
287
  rgScalarFieldClick(Self);
288
end;
289

290
procedure TForm1.tbIsoValueChange(Sender: TObject);
291
begin
292
  edIsoValue.Text := FloatToStr(tbIsoValue.Position/10);
293
end;
294

295
end.
296