MathgeomGLS

WorldDrawing.pas
3107 строк · 91.0 Кб
Перенос по словам
1
unit WorldDrawing;
2
(*
3
  TWorldDrawing
4
  Object for drawing in world coordinates
5
  Now the object powering TMathImage based on Renate Schaaf's source
6
 *)
7

8
interface
9

10
uses
11
  Winapi.Windows,
12
  System.Types,
13
  System.UITypes,
14
  System.Classes,
15
  System.SysUtils,
16
  System.Math,
17
  Vcl.Graphics;
18

19
type
20
  MathFloat = single; //double; extended;
21

22
  PFloatPoint = ^TFloatpoint;
23
  TFloatpoint = record
24
    x, y: MathFloat;
25
  end;
26

27
  TFloatPointArray = array of TFloatpoint;
28

29
  PD3FloatPoint = ^TD3FloatPoint;
30
  TD3FloatPoint = record
31
    x, y, z: MathFloat;
32
  end;
33

34
  POldFloatPoint = ^TOldFloatpoint;
35
  TOldFloatpoint = record
36
    x, y: MathFloat;
37
    Next: POldFloatPoint;
38
  end;
39

40

41
  POldD3FloatPoint = ^TOldD3FloatPoint;
42
  TOldD3FloatPoint = record
43
    x, y, z: MathFloat;
44
    Next: POldD3FloatPoint;
45
  end;
46

47
  Td3FloatPointArray = array of TD3FloatPoint;
48
  TColorArray = array of TColor;
49
  TFloatarray = array of MathFloat;
50

51

52
  TD3FloatPointers = record
53
    px, py, pz: ^MathFloat;
54
  end;
55

56
  TD3Triangle = record
57
    p, q, r: PD3FloatPoint;
58
    n: TD3FloatPoint; //(normal)
59
    FillColor, WireColor: ^TColor;
60
  end;
61

62
  TD3TriangleArray = array of TD3Triangle;
63

64
  TD3SurfaceCell = record
65
    p, q, r, s: PD3FloatPoint;
66
    FillColor, WireColor: ^TColor;
67
  end;
68

69
  TCube = record
70
     { TODO : Change that TCube }
71
    x1, y1, z1, x2, y2, z2: MathFloat;
72
    p1, p2, p3, p4, p5, p6, p7, p8: TD3FloatPoint;
73
    FillColor, WireColor: TColor;
74
  end;
75

76
  Td3FloatPointerArray = array of TD3FloatPointers;
77

78
  P4Cell = ^T4Cell;
79
  T4Cell = record
80
    Vertex: array[0..3] of TPoint;
81
    dist: MathFloat;
82
    FillColor, WireColor: TColor;
83
  end;
84

85
  P3Cell = ^T3Cell;
86
  T3Cell = record
87
    Vertex: array[0..2] of TPoint;
88
    dist, BDiff, BSpec: MathFloat;
89
    FillColor, WireColor: TColor;
90
  end;
91

92
  TPointArray = array of TPoint;
93

94
  Td3LineSegment = record
95
    p, q: PD3FloatPoint;
96
    N1, N2: TD3FloatPoint; //principal and secondary normal
97
    dist: MathFloat;
98
    Color: TColor;
99
    Width: MathFloat;
100
  end;
101

102
  Td3LineSegmentArray = array of Td3LineSegment;
103

104
  TNormalKind = (nkPrincipal, nkSecondary);
105

106
  TLightSource = class
107
  private
108
    fSourcePoint: TD3FloatPoint;
109
    fViewAngles: TFloatpoint;
110
    fyrot, fzrot, fdist: MathFloat;
111
    fFixed: Boolean;
112
    procedure SetYRot(Value: Integer);
113
    procedure SetZRot(Value: Integer);
114
    function GetYRot: Integer;
115
    function GetZRot: Integer;
116
    procedure SetDist(Value: MathFloat);
117
    procedure SetViewAngles(Value: TFloatpoint);
118
    procedure InitSourcePoint;
119
  public
120
    property YRotation: Integer read GetYRot write SetYRot;
121
    property ZRotation: Integer read GetZRot write SetZRot;
122
    property dist: MathFloat read fdist write SetDist;
123
    property fixed: Boolean read fFixed write fFixed;
124
    property ViewAngles: TFloatpoint read fViewAngles write SetViewAngles;
125
    property SourcePoint: TD3FloatPoint read fSourcePoint;
126
  end;
127

128

129

130
  { Object for drawing in world coordinates on any canvas. Use of this
131
  object is more advanced than using <See class=TMathImage>, because you need
132
  to set the world, and screen dimensions, and have to update them as needed
133
  if your area resizes. Second, there is no exception handling whatsoever done
134
  in this object. Third, you need to do your own clipping when using axes.
135
  The AxesRect property can be used }
136
  TWorldDrawing = class
137
  private
138
    fwidth, fHeight: Integer;    //Screen dimensions
139
    fd2x1, fd2xw, fd2y1, fd2yw: MathFloat;  //D2- worldsize
140
    fd2Axes: Boolean;    //Leave space for axes?
141

142
    fmaxxtw, fmaxytw, fmaxth: Integer;
143
    fd3ar: Boolean;    //true aspectratio in d3?
144
    fd3x1, fd3xw, fd3y1, fd3yw, fd3z1, fd3zw: MathFloat;   //D3-worldsize
145

146
    fd3alpha, fd3vd, fd3vdinv: MathFloat; //D3-lens: opening angle, viewdist
147
    fd3zr, fd3yr: MathFloat;   //D3 viewpoint angles
148
    fd3ViewPoint: TD3FloatPoint;   //D3 current viewpoint
149
    fd3ViewAngles: TFloatpoint;
150
    fd3L1, fd3L2: TLightSource;
151
    fd3xScale, fd3yScale, fd3zScale: MathFloat;  //D3 axes scalings
152
    fClipRect: TRect;
153

154
    //helper variables
155
    ax, bx, ay, by, axinv, ayinv, x1Snap, x2Snap, y1Snap, y2Snap: MathFloat;
156
    basex, basey, basez, frontx, fronty, frontz: MathFloat;
157
    arad, tana, thetaz, thetay, sinz, siny, cosz, cosy, coszinv,
158
      sinyinv, cosyinv,
159
      axd3, ayd3, azd3, axd3Inv, ayd3Inv, azd3Inv, bxd3, byd3, bzd3, ap, bxp, byp: MathFloat;
160
    rightz, righty: MathFloat;
161
    fDefaultFillColor, fDefaultWireColor: TColor;
162

163
    procedure scalar(xb, yb, zb: MathFloat; var r: MathFloat);
164
    procedure Project(xb, yb, zb: MathFloat; var u, v: MathFloat);
165
    procedure MakeScalings;
166
    procedure dist(xb, yb, zb: MathFloat; var r: MathFloat);
167
    procedure FindBase(var i1, i2, i3: Integer);
168
    procedure InitWorld;
169
    procedure DrawOneAxis(ACanvas: TCanvas; x1, y1, z1, x2, y2, z2: MathFloat; Arrows: Boolean);
170
    procedure Block(x, y, z: MathFloat; var xb, yb, zb: MathFloat);
171
    procedure ScaleVector(const v: TD3FloatPoint; var w: TD3FloatPoint);
172
    procedure ScaleNormal(const v: TD3FloatPoint; var w: TD3FloatPoint);
173
    procedure d3DrawBaseAxes(ACanvas: TCanvas; xLabel, yLabel,
174
      zLabel: string; xTicks, yTicks, zTicks: byte; yx, zx, xy, zy, xz,
175
      yz: MathFloat; Arrows: Boolean = True);
176
  protected
177
    (*Low level routines that require the pointers to have been set up *)
178
    procedure d3ResetWorld;
179
    procedure GetBrightness(const p, n: TD3FloatPoint; var BDiff, BSpec: MathFloat);
180
    procedure Draw4Cells(ACanvas: TCanvas; const Cells: array of T4Cell);
181
    procedure d3DrawTriangles(ACanvas: TCanvas; const Triangles: array of TD3Triangle);
182
    procedure d3DrawSurfaceCells(ACanvas: TCanvas; const SurfaceCells: array of TD3SurfaceCell);
183
    procedure d3DrawLitTriangles(ACanvas: TCanvas; const Triangles: array of TD3Triangle; diffuse, focussed: MathFloat);
184
    function DoorInDoorOut(c, xp, yp, xq, yq, xr, yr, p, q, r: MathFloat;
185
      var x1, y1, x2, y2: MathFloat): Boolean;
186
    procedure DrawLevelLines(ACanvas: TCanvas; const Triangles: array of TD3Triangle; Level: MathFloat);
187
    procedure DrawLevelLine(ACanvas: TCanvas; Triangle: TD3Triangle; Level: MathFloat);
188
    procedure DrawProjection(ACanvas: TCanvas; Triangle: TD3Triangle);
189
    procedure DrawProjections(ACanvas: TCanvas; const Triangles: array of TD3Triangle);
190
    procedure GetIlluminatedLinesegments(AColor: TColor; diffuse, focussed, RightIntensity: MathFloat;
191
      z1, z2, y1, y2: Integer; d1, d2: MathFloat; fixed: Boolean; var l: Td3LineSegmentArray);
192
    procedure DrawLineSegments(ACanvas: TCanvas; l: Td3LineSegmentArray);
193
  public
194
    property AxesClipRect: TRect read fClipRect;
195
    constructor Create;
196
    //general d2-Stuff
197
    { Use this first thing to tell the object the pixel dimensions for the drawing area }
198
    procedure SetScreen(AWidth, AHeight: Integer);
199
    { Set the bounds for your world coordinates. x1, y1 are the lower bounds,
200
    x2,y2 the upper ones. This TWorldDrawing does no exception handling, so
201
    you need to make sure that x1<x2 and y1<y2. The canvas this is intended
202
    for, needs to be passed, so the right amount of space can be left for
203
    axes drawing depending on the canvas's font. If you change the font, you need
204
    to reset the world }
205
    procedure SetWorld(ACanvas: TCanvas; x1, y1, x2, y2: MathFloat);
206
    procedure ResetWorld(ACanvas: TCanvas);
207
    procedure Setd2Axes(ACanvas: TCanvas; Value: Boolean);
208
    function Windowx(x: MathFloat): Integer;
209
    function Windowy(y: MathFloat): Integer;
210
    procedure WorldToScreen(const x, y: MathFloat; var xs, Ys: Integer);
211
    function WorldX(xs: longint): MathFloat;
212
    function WorldY(Ys: longint): MathFloat;
213
    procedure Convert(const src: TFloatpoint; var dest: TPoint);
214
    function Norm(x, y: MathFloat): MathFloat;
215
    procedure DrawPoint(ACanvas: TCanvas; x, y: MathFloat);
216
    procedure MoveToPoint(ACanvas: TCanvas; x, y: MathFloat);
217
    procedure DrawLine(ACanvas: TCanvas; x1, y1, x2, y2: MathFloat);
218
    procedure DrawLineTo(ACanvas: TCanvas; x, y: MathFloat);
219
    procedure DrawEllipse(ACanvas: TCanvas; x1, y1, x2, y2: MathFloat);
220
    procedure DrawCircle(ACanvas: TCanvas; xCenter, yCenter: MathFloat; PixRadius: Integer);
221
    procedure DrawRectangle(ACanvas: TCanvas; x1, y1, x2, y2: MathFloat);
222
    procedure DrawAxes(ACanvas: TCanvas; xLabel, yLabel: string;
223
      AxesColor: TColor; Arrows: Boolean = True);
224
    procedure DrawZeroLines(ACanvas: TCanvas; AColor: TColor);
225
    procedure DrawVector(ACanvas: TCanvas; x, y, A, b: MathFloat);
226
    procedure DrawPolyline(ACanvas: TCanvas; const FloatPointArray: array of TFloatpoint; PointCount: Integer);
227
    procedure DrawPolygon(ACanvas: TCanvas; const FloatPointArray: array of TFloatpoint; PointCount: Integer);
228
    procedure DrawPolyPolyline(ACanvas: TCanvas; const GraphList: array of TFloatPointArray);
229
    //general d3 stuff
230
    procedure d3SetWorld(x1, y1, z1, x2, y2, z2: MathFloat; AspectRatio: Boolean);
231
    procedure d3SetViewPoint(vd, alpha, yr, zr: MathFloat);
232
    procedure d3SetScales(xScale, yScale, zScale: MathFloat);
233
    procedure d3Window(x, y, z: MathFloat; var xs, Ys: longint);
234
    procedure PseudoD3World(xs, Ys: longint; var x, y, z: MathFloat);
235
    procedure d3Moveto(ACanvas: TCanvas; x, y, z: MathFloat);
236
    procedure d3DrawPoint(ACanvas: TCanvas; x, y, z: MathFloat);
237
    procedure d3DrawLine(ACanvas: TCanvas; x1, y1, z1, x2, y2, z2: MathFloat);
238
    procedure d3DrawLineto(ACanvas: TCanvas; x, y, z: MathFloat);
239
    procedure d3DrawAxes(ACanvas: TCanvas; xLabel, yLabel, zLabel: string;
240
      xTicks, yTicks, zTicks, xPos, yPos, zPos: byte; Arrows: Boolean = True);
241
    procedure d3DrawBestAxes(ACanvas: TCanvas; xLabel, yLabel, zLabel: string;
242
      xTicks, yTicks, zTicks: byte; Arrows: Boolean = True);
243
    procedure d3DrawCustomAxes(ACanvas: TCanvas;
244
      xmin, ymin, zmin, xmax, ymax, zmax: MathFloat;
245
      xLabel, yLabel, zLabel: string);
246
    procedure d3DrawWorldbox(ACanvas: TCanvas);
247
    procedure d3DrawBox(ACanvas: TCanvas; x1, y1, z1, x2, y2,
248
      z2: MathFloat);
249
    procedure d3DrawFullWorldBox(ACanvas: TCanvas);
250
    procedure d3drawZeroCross(ACanvas: TCanvas);
251
    procedure d3Polyline(ACanvas: TCanvas; const FloatPointArray: array of TD3FloatPoint; PointCount: Integer);
252
    procedure d3LitPolyLine(ACanvas: TCanvas;
253
      const FloatPointArray: array of TD3FloatPoint; PointCount: Integer;
254
      NormalKind: TNormalKind; ambient, directed: MathFloat; zrot1, zrot2, yrot1, yrot2: Integer; dist1, dist2: MathFloat; fixed: Boolean);
255
    procedure d3PolyPolyline(ACanvas: TCanvas; const GraphList: array of Td3FloatPointArray);
256

257
    //Surface stuff
258
    procedure d3DistanceToViewer(x, y, z: MathFloat; var r: MathFloat);
259
    procedure d3DrawSurface(ACanvas: TCanvas; const SurfArray: array of Td3FloatPointArray; fill: Boolean);
260
    procedure d3DrawLitSurface
261
      (ACanvas: TCanvas; const SurfArray: array of Td3FloatPointArray; diffuse, focussed: MathFloat);
262
    procedure d3DrawColorSurface(ACanvas: TCanvas; const SurfArray: array of Td3FloatPointArray;
263
      Colors: array of TColorArray);
264
    procedure d3DrawHeightCubes(ACanvas: TCanvas; const HeightArray: array of TFloatarray;
265
      const Colors: array of TColorArray);
266
    procedure d3DrawLitHeightCubes(ACanvas: TCanvas; const HeightArray: array of TFloatarray;
267
      const Colors: array of TColorArray; diffuse, focussed: MathFloat);
268
    procedure d3DrawLitLevelSurface
269
      (ACanvas: TCanvas; const SurfArray: array of Td3FloatPointArray;
270
      const Levels: array of MathFloat; const Colors: array of TColor;
271
      diffuse, focussed: MathFloat);
272
    procedure d3DrawCubes(ACanvas: TCanvas; const Cubes: array of TCube; fill: Boolean);
273
    procedure d3DrawLitCubes(ACanvas: TCanvas; const Cubes: array of TCube; diffuse, focussed: MathFloat);
274

275
    //Level stuff
276
    procedure DrawLevelCurves(ACanvas: TCanvas; const SurfArray: array of Td3FloatPointArray; Level: MathFloat);
277
    procedure DrawFilledLevelCurves(ACanvas: TCanvas; const SurfArray: array of Td3FloatPointArray;
278
      const Levels: array of MathFloat; const Colors: array of TColor);
279

280
    //properties
281
    property d2x1: MathFloat read fd2x1;
282
    property d2y1: MathFloat read fd2y1;
283
    property d2xw: MathFloat read fd2xw;
284
    property d2yw: MathFloat read fd2yw;
285
    property d2Axes: Boolean read fd2Axes;
286
    property d2x1Snap: MathFloat read x1Snap;
287
    property d2x2Snap: MathFloat read x2Snap;
288
    property d2y1Snap: MathFloat read y1Snap;
289
    property d2y2Snap: MathFloat read y2Snap;
290
    property d3ar: Boolean read fd3ar;
291
    property d3x1: MathFloat read fd3x1;
292
    property d3xw: MathFloat read fd3xw;
293
    property d3y1: MathFloat read fd3y1;
294
    property d3yw: MathFloat read fd3yw;
295
    property d3z1: MathFloat read fd3z1;
296
    property d3zw: MathFloat read fd3zw;
297
    property d3alpha: MathFloat read fd3alpha;
298
    property d3vd: MathFloat read fd3vd;
299
    property d3zr: MathFloat read fd3zr;
300
    property d3yr: MathFloat read fd3yr;
301
    property d3Xscale: MathFloat read fd3xScale;
302
    property d3Yscale: MathFloat read fd3yScale;
303
    property d3Zscale: MathFloat read fd3zScale;
304
    property LightSource1: TLightSource read fd3L1;
305
    property LightSource2: TLightSource read fd3L1;
306
  end;
307

308
procedure D3FloatPoint(x, y, z: MathFloat; var p: TD3FloatPoint);
309
procedure FloatPoint(x, y: MathFloat; var r: TFloatpoint);
310
procedure CrossProduct(x1, y1, z1, x2, y2, z2: MathFloat; var u1, u2, u3: MathFloat);
311
procedure GetLineSegments(const f: array of TD3FloatPoint;
312
  aCount: Integer; NormalKind: TNormalKind; var l: Td3LineSegmentArray);
313

314

315
//========================================================================
316
implementation
317
//========================================================================
318

319
const piInv = 2 / pi;
320

321

322
procedure D3FloatPoint(x, y, z: MathFloat; var p: TD3FloatPoint);
323
begin
324
  p.x := x;
325
  p.y := y;
326
  p.z := z;
327
end;
328

329
procedure FloatPoint(x, y: MathFloat; var r: TFloatpoint);
330
begin
331
  r.x := x;
332
  r.y := y;
333
end;
334

335
procedure d3Norm(const p: TD3FloatPoint; var r: MathFloat);
336
begin
337
  r := sqrt(sqr(p.x) + sqr(p.y) + sqr(p.z));
338
end;
339

340
{ TWorldDrawing }
341

342
constructor TWorldDrawing.Create;
343
begin
344
  inherited;
345
  fd3x1 := 0; fd3xw := 1; fd3y1 := 0; fd3yw := 1; fd3z1 := 0; fd3zw := 1;
346
  fd3vd := 6.4; fd3alpha := 6; fd3yr := 0; fd3zr := 0;
347
  fd3ar := True; fd3xScale := 1; fd3yScale := 1; fd3zScale := 1;
348
  fd2Axes := False;
349
  fd2x1 := 0; fd2xw := 1; fd2y1 := 0; fd2yw := 1;
350
  //all properties for which a 0 value makes sense must be set to 0
351
  //because 0 is never stored in the dfm file
352
  fwidth := 30; fHeight := 30; fmaxxtw := 20; fmaxytw := 20; fmaxth := 10;
353
  x1Snap := 0; x2Snap := 1; y1Snap := 0; y2Snap := 1;
354
  fd3L1 := TLightSource.Create;
355
  fd3L2 := TLightSource.Create;
356
  fd3L1.YRotation := 0;
357
  fd3L1.ZRotation := 30;
358
  fd3L1.dist := 2 * fd3vd;
359
  fd3L2.YRotation := 0;
360
  fd3L2.ZRotation := -60;
361
  fd3L2.dist := 2 * fd3vd;
362
  MakeScalings;
363
end;
364

365
procedure TWorldDrawing.SetScreen(AWidth, AHeight: Integer);
366
begin
367
  if (AWidth <> fwidth) or (AHeight <> fHeight) then
368
  begin
369
    fwidth := AWidth;
370
    fHeight := AHeight;
371
  end;
372
end;
373

374
procedure TWorldDrawing.Setd2Axes(ACanvas: TCanvas; Value: Boolean);
375
begin
376
  fd2Axes := Value;
377
  SetWorld(ACanvas, fd2x1, fd2y1, fd2x1 + fd2xw, fd2y1 + fd2yw);
378
end;
379

380
procedure TWorldDrawing.d3SetWorld(x1, y1, z1, x2, y2, z2: MathFloat; AspectRatio: Boolean);
381
begin
382
  //do exception handling in TMathImage
383
  fd3x1 := x1;
384
  fd3xw := x2 - x1;
385
  fd3y1 := y1;
386
  fd3yw := y2 - y1;
387
  fd3z1 := z1;
388
  fd3zw := z2 - z1;
389
  fd3ar := AspectRatio;
390
  InitWorld;
391
end;
392

393
procedure TWorldDrawing.d3Window(x, y, z: MathFloat; var xs, Ys: Integer);
394
var
395
  xb, yb, zb, u, v, Temp: MathFloat;
396
begin
397
  Block(x, y, z, xb, yb, zb);
398
  Project(xb, yb, zb, u, v);
399
  Temp := bxp + ap * u;
400
  if Temp < -22000 then xs := -22000 else if Temp > 22000 then xs := 22000 else
401
    xs := round(Temp);
402
  Temp := byp - ap * v;
403
  if Temp < -22000 then Ys := -22000 else if Temp > 22000 then Ys := 22000 else
404
    Ys := round(Temp);
405
end;
406

407
procedure TWorldDrawing.dist(xb, yb, zb: MathFloat; var r: MathFloat);
408
begin
409
  scalar(xb, yb, zb, r);
410
  r := fd3vd - r;
411
end;
412

413
procedure TWorldDrawing.Block(x, y, z: MathFloat; var xb, yb, zb: MathFloat);
414
begin
415
  xb := bxd3 + axd3 * x;
416
  yb := byd3 + ayd3 * y;
417
  zb := bzd3 + azd3 * z;
418
end;
419

420

421
procedure TWorldDrawing.d3DistanceToViewer(x, y, z: MathFloat;
422
//Note: this is the square distance, all we need to sort!
423
  var r: MathFloat);
424
var
425
  xb, yb, zb: MathFloat;
426
begin
427
  Block(x, y, z, xb, yb, zb);
428
  r := sqr(fd3vd * siny * sinz - yb) +
429
    sqr(fd3vd * cosy - zb) + sqr(fd3vd * siny * cosz - xb);
430
end;
431

432
procedure TWorldDrawing.FindBase(var i1, i2, i3: Integer);
433
var
434
  dmax, d: MathFloat; i, j, k: Integer;
435
begin
436
  i1 := -1; i2 := -1; i3 := -1;
437
  dmax := 0;
438
  for i := 0 to 1 do
439
    for j := 0 to 1 do
440
      for k := 0 to 1 do
441
      begin
442
        dist(-1 + 2 * i, -1 + 2 * j, -1 + 2 * k, d);
443
        dmax := max(dmax, d);
444
        if d = dmax then
445
        begin
446
          i1 := -1 + 2 * i; i2 := -1 + 2 * j; i3 := -1 + 2 * k;
447
        end;
448
      end;
449
end;
450

451
procedure TWorldDrawing.InitWorld;
452
var
453
  i1, i2, i3: Integer;
454
begin
455
  if fd3vd < 0.0001 then fd3vd := 0.0001;
456
  if fd3alpha > 179 then fd3alpha := 179;
457
  if fd3alpha < 0.01 then fd3alpha := 0.01;
458
  MakeScalings;
459
  FindBase(i1, i2, i3);
460
  if i1 = -1 then basex := fd3x1 else basex := fd3x1 + fd3xw;
461
  if i2 = -1 then basey := fd3y1 else basey := fd3y1 + fd3yw;
462
  if i3 = -1 then basez := fd3z1 else basez := fd3z1 + fd3zw;
463
  if i1 = 1 then frontx := fd3x1 else frontx := fd3x1 + fd3xw;
464
  if i2 = 1 then fronty := fd3y1 else fronty := fd3y1 + fd3yw;
465
  if i3 = 1 then frontz := fd3z1 else frontz := fd3z1 + fd3zw;
466
end;
467

468
procedure TWorldDrawing.Project(xb, yb, zb: MathFloat; var u,
469
  v: MathFloat);
470
var
471
  scal, d: MathFloat;
472
begin
473
  scalar(xb, yb, zb, scal);
474
  d := fd3vd - scal;
475
  if righty <> 0 then
476
    v := (zb - scal * cosy) * sinyinv
477
  else
478
    v := -(yb * sinz + xb * cosz) * cosyinv;
479
  if rightz <> 0 then
480
    u := (yb + sinz * (v * cosy - scal * siny)) * coszinv
481
  else
482
    u := -xb * sinz;
483
  if d <= 0 then d := 1.0E-10;
484
  d := 1 / d;
485
  u := u * d;
486
  v := v * d;
487
end;
488

489

490

491
procedure TWorldDrawing.PseudoD3World(xs, Ys: Integer; var x, y,
492
  z: MathFloat);
493
var
494
  u, v, xb, yb, zb: MathFloat;
495
begin
496
  u := (xs - bxp) / ap * fd3vd;
497
  v := (byp - Ys) / ap * fd3vd;
498
  zb := siny * v;
499
  yb := cosz * u - sinz * cosy * v;
500
  xb := -sinz * u - cosy * cosz * v;
501
  x := (xb - bxd3) / axd3;
502
  y := (yb - byd3) / ayd3;
503
  z := (zb - bzd3) / azd3;
504
end;
505

506
procedure TWorldDrawing.scalar(xb, yb, zb: MathFloat; var r: MathFloat);
507
begin
508
  r := yb * sinz * siny + zb * cosy + xb * siny * cosz;
509
end;
510

511
procedure TWorldDrawing.MakeScalings;
512
var
513
  A: MathFloat;
514
begin
515
  fd3vdinv := 1 / fd3vd;
516
  thetaz := 1 / 180 * pi * fd3zr;
517
  thetay := 1 / 180 * pi * fd3yr;
518
  arad := 1 / 360 * pi * fd3alpha;
519
  sinz := sin(thetaz); cosz := cos(thetaz);
520
  siny := sin(thetay); cosy := cos(thetay);
521
  if siny <> 0 then
522
    sinyinv := 1 / siny;
523
  if cosy <> 0 then
524
    cosyinv := 1 / cosy;
525
  if cosz <> 0 then
526
    coszinv := 1 / cosz;
527
  tana := sin(arad) / cos(arad);
528
  rightz := (fd3zr + 90) - 180 * round(1 / 180 * (fd3zr + 90.0));
529
  righty := fd3yr - 180 * round(1 / 180 * fd3yr);
530
  axd3 := fd3xw;
531
  ayd3 := fd3yw;
532
  azd3 := fd3zw;
533
  if not fd3ar then
534
  begin
535
    axd3 := 2 / axd3;
536
    ayd3 := 2 / ayd3;
537
    azd3 := 2 / azd3;
538
  end else
539
  begin
540
    A := 2 / max(max(fd3xScale * axd3, fd3yScale * ayd3), fd3zScale * azd3);
541
    ayd3 := fd3yScale * A; axd3 := fd3xScale * A; azd3 := fd3zScale * A;
542
  end;
543
  bxd3 := -axd3 * (fd3x1 + 0.5 * fd3xw);
544
  byd3 := -ayd3 * (fd3y1 + 0.5 * fd3yw);
545
  bzd3 := -azd3 * (fd3z1 + 0.5 * fd3zw);
546
  ap := min(fHeight, fwidth) * 0.5 / tana * fd3vdinv;
547
  bxp := fwidth * 0.5; byp := fHeight * 0.5;
548
  axd3Inv := 1 / axd3;
549
  ayd3Inv := 1 / ayd3;
550
  azd3Inv := 1 / azd3;
551
  D3FloatPoint(fd3vd * cosz * siny, fd3vd * sinz * siny, fd3vd * cosy, fd3ViewPoint);
552
  FloatPoint(thetaz, thetay, fd3ViewAngles);
553
  fd3L1.ViewAngles := fd3ViewAngles;
554
  fd3L2.ViewAngles := fd3ViewAngles;
555
end;
556

557

558
procedure TWorldDrawing.d3DrawAxes(ACanvas: TCanvas; xLabel, yLabel,
559
  zLabel: string; xTicks, yTicks, zTicks, xPos, yPos, zPos: byte; Arrows: Boolean = True);
560
var
561
  yx, zx, xy, zy, xz, yz: MathFloat;
562

563

564
begin {******* drawd3axes ******}
565
  yx := fd3y1; zx := fd3z1;
566
  xy := fd3x1; zy := fd3z1;
567
  xz := fd3x1; yz := fd3y1;
568
  case xPos of
569
    0: begin yx := fd3y1; zx := fd3z1; end;
570
    1: begin yx := fd3y1; zx := fd3z1 + fd3zw; end;
571
    2: begin yx := fd3y1 + fd3yw; zx := fd3z1; end;
572
    3: begin yx := fd3y1 + fd3yw; zx := fd3z1 + fd3zw; end;
573
  end;
574
  case yPos of
575
    0: begin xy := fd3x1; zy := fd3z1; end;
576
    1: begin xy := fd3x1; zy := fd3z1 + fd3zw; end;
577
    2: begin xy := fd3x1 + fd3xw; zy := fd3z1; end;
578
    3: begin xy := fd3x1 + fd3xw; zy := fd3z1 + fd3zw; end;
579
  end;
580
  case zPos of
581
    0: begin xz := fd3x1; yz := fd3y1; end;
582
    1: begin xz := fd3x1; yz := fd3y1 + fd3yw; end;
583
    2: begin xz := fd3x1 + fd3xw; yz := fd3y1; end;
584
    3: begin xz := fd3x1 + fd3xw; yz := fd3y1 + fd3yw; end;
585
  end;
586
  d3DrawBaseAxes(ACanvas, xLabel, yLabel, zLabel, xTicks, yTicks, zTicks, yx, zx, xy, zy, xz, yz, Arrows);
587
end;
588

589
procedure TWorldDrawing.d3DrawBaseAxes(ACanvas: TCanvas; xLabel, yLabel,
590
  zLabel: string; xTicks, yTicks, zTicks: byte; yx, zx, xy, zy, xz, yz: MathFloat; Arrows: Boolean = True);
591
var
592
  xs, Ys, i, iStart, Ticks: longint;
593
  SaveBrush: TBrush;
594
  SavePen: TPen;
595
  t: string;
596
  iTemp, Tick, log, invlog, invTick: MathFloat;
597

598

599
begin {******* drawd3axes ******}
600
  SavePen := TPen.Create;
601
  SaveBrush := TBrush.Create;
602
  SavePen.assign(ACanvas.Pen);
603
  SaveBrush.assign(ACanvas.Brush);
604
  ACanvas.Brush.Style := bsClear;
605
  DrawOneAxis(ACanvas, fd3x1, yx, zx, fd3x1 + fd3xw, yx, zx, Arrows);
606
  d3Window(fd3x1 + 0.5 * fd3xw, yx, zx, xs, Ys);
607
  with ACanvas do
608
    TextOut(xs - TextWIdth(xLabel) div 2, Ys -TextHeight(xLabel)-6, xLabel);
609
  DrawOneAxis(ACanvas, xy, fd3y1, zy, xy, fd3y1 + fd3yw, zy, Arrows);
610
  d3Window(xy, fd3y1 + 0.5 * fd3yw, zy, xs, Ys);
611
  ACanvas.TextOut(xs - ACanvas.TextWIdth(yLabel) div 2, Ys-ACanvas.TextHeight(yLabel)-6, yLabel);
612
  DrawOneAxis(ACanvas, xz, yz, fd3z1, xz, yz, fd3z1 + fd3zw, Arrows);
613
  d3Window(xz, yz, fd3z1 + 0.5 * fd3zw, xs, Ys);
614
  log := ln(10); invlog := 1 / log;
615
  with ACanvas do
616
    TextOut(xs +6, Ys, zLabel);
617
  if xTicks > 0 then
618
  begin
619
    iTemp := ln(1 / 8 * abs(fd3xw)) * invlog;
620
    if iTemp >= 0 then
621
      i := trunc(iTemp) else i := trunc(iTemp) - 1;
622
    Tick := exp(i * log);
623
    with ACanvas.Font do Size := Size - 1;
624
    if Tick > 0 then
625
    begin
626
      invTick := 1 / Tick;
627
      iStart := round(fd3x1 * invTick);
628
      while iStart * Tick < fd3x1 do inc(iStart);
629
      Ticks := round(fd3xw * invTick) div xTicks;
630
      i := iStart;
631
      if Ticks <= 500 then
632
        repeat
633
          d3Window(i * Tick, yx, zx, xs, Ys);
634
          t := FloatToStrf(i * Tick, ffgeneral, 3, 3);
635
          with ACanvas do
636
            if i > iStart then
637
            begin
638
              TextOut(xs - (TextWIdth(t) div 2), Ys + 6, t);
639
              MoveTo(xs, Ys);
640
              LineTo(xs, Ys + 6);
641
            end;
642
          i := i + Ticks;
643
        until i * Tick >= fd3x1 + fd3xw;
644
    end;
645
    with ACanvas.Font do Size := Size + 1;
646
  end;
647
  if yTicks > 0 then
648
  begin
649
    iTemp := ln(1 / 8 * abs(fd3yw)) * invlog;
650
    if iTemp >= 0 then
651
      i := trunc(iTemp) else i := trunc(iTemp) - 1;
652
    Tick := exp(i * log);
653
    with ACanvas.Font do Size := Size - 1;
654
    if Tick > 0 then
655
    begin
656
      invTick := 1 / Tick;
657
      iStart := round(fd3y1 * invTick);
658
      while iStart * Tick < fd3y1 do inc(iStart);
659
      Ticks := round(fd3yw * invTick) div yTicks;
660
      i := iStart;
661
      if Ticks <= 500 then
662
        repeat
663
          d3Window(xy, i * Tick, zy, xs, Ys);
664
          t := FloatToStrf(i * Tick, ffgeneral, 3, 3);
665
          with ACanvas do
666
            if i > iStart then
667
            begin
668
              TextOut(xs - (TextWIdth(t) div 2), Ys + 6, t);
669
              MoveTo(xs, Ys);
670
              LineTo(xs, Ys + 6);
671
            end;
672
          i := i + Ticks;
673
        until i * Tick >= fd3y1 + fd3yw;
674
    end;
675
    with ACanvas.Font do Size := Size + 1;
676
  end;
677
  if zTicks > 0 then
678
  begin
679
    iTemp := ln(1 / 8 * abs(fd3zw)) * invlog;
680
    if iTemp >= 0 then
681
      i := trunc(iTemp) else i := trunc(iTemp) - 1;
682
    Tick := exp(i * log);
683
    with ACanvas.Font do Size := Size - 1;
684
    if Tick > 0 then
685
    begin
686
      invTick := 1 / Tick;
687
      iStart := round(fd3z1 * invTick);
688
      while iStart * Tick <= fd3z1 do inc(iStart);
689
      Ticks := round(fd3zw * invTick) div zTicks;
690
      i := iStart;
691
      if Ticks <= 500 then
692
        repeat
693
          d3Window(xz, yz, i * Tick, xs, Ys);
694
          t := FloatToStrf(i * Tick, ffgeneral, 3, 3);
695
          with ACanvas do
696
          begin
697
            TextOut(xs - TextWIdth(t) - 6, Ys - (TextHeight(t) div 2), t);
698
            MoveTo(xs, Ys);
699
            LineTo(xs - 6, Ys);
700
          end;
701
          i := i + Ticks;
702
        until i * Tick >= fd3z1 + fd3zw;
703
    end;
704
    with ACanvas.Font do Size := Size + 1;
705
  end;
706
  ACanvas.Brush.assign(SaveBrush);
707
  ACanvas.Pen.assign(SavePen);
708
  SaveBrush.Free;
709
  SavePen.Free;
710
end;
711

712

713
procedure TWorldDrawing.d3DrawBox(ACanvas: TCanvas; x1, y1, z1, x2, y2,
714
  z2: MathFloat);
715
  procedure MakePoint(x, y, z: MathFloat; var p: TPoint);
716
  var
717
    xs, Ys: longint;
718
  begin
719
    d3Window(x, y, z, xs, Ys);
720
    p := Point(xs, Ys);
721
  end;
722
var
723
  p11, p12, p13, p14, p21, p22, p23, p24: TPoint;
724
begin
725
  MakePoint(x1, y1, z1, p11);
726
  MakePoint(x2, y1, z1, p12);
727
  MakePoint(x2, y2, z1, p13);
728
  MakePoint(x1, y2, z1, p14);
729
  MakePoint(x1, y1, z2, p21);
730
  MakePoint(x2, y1, z2, p22);
731
  MakePoint(x2, y2, z2, p23);
732
  MakePoint(x1, y2, z2, p24);
733
  with ACanvas do
734
  begin
735
    Polyline([p11, p12, p13, p14, p11]);
736
    Polyline([p21, p22, p23, p24, p21]);
737
    MoveTo(p11.x, p11.y); LineTo(p21.x, p21.y);
738
    MoveTo(p12.x, p12.y); LineTo(p22.x, p22.y);
739
    MoveTo(p13.x, p13.y); LineTo(p23.x, p23.y);
740
    MoveTo(p14.x, p14.y); LineTo(p24.x, p24.y);
741
  end;
742
end;
743

744

745

746
procedure TWorldDrawing.d3DrawCustomAxes(ACanvas: TCanvas; xmin, ymin,
747
  zmin, xmax, ymax, zmax: MathFloat; xLabel, yLabel, zLabel: string);
748
var xs, Ys: Integer;
749

750
begin
751
  DrawOneAxis(ACanvas, xmin, ymin, zmin, xmax, ymin, zmin, True);
752
  DrawOneAxis(ACanvas, xmin, ymin, zmin, xmin, ymax, zmin, True);
753
  DrawOneAxis(ACanvas, xmin, ymin, zmin, xmin, ymin, zmax, True);
754
  d3Window(xmax, ymin, zmin, xs, Ys);
755
  with ACanvas do
756
    TextOut(xs - TextWIdth(xLabel) - 3, Ys + 6, xLabel);
757
  d3Window(xmin, ymax, zmin, xs, Ys);
758
  ACanvas.TextOut(xs + 3, Ys + 6, yLabel);
759
  d3Window(xmin, ymin, zmax, xs, Ys);
760
  with ACanvas do
761
    TextOut(xs, Ys - 6 - TextHeight(zLabel), zLabel);
762
end;
763

764
procedure TWorldDrawing.d3DrawFullWorldBox(ACanvas: TCanvas);
765
begin
766
  d3DrawBox(ACanvas, fd3x1, fd3y1, fd3z1, fd3x1 + fd3xw, fd3y1 + fd3yw, fd3z1 + fd3zw);
767
end;
768

769
procedure TWorldDrawing.d3DrawLine(ACanvas: TCanvas; x1, y1, z1, x2, y2,
770
  z2: MathFloat);
771
var
772
  Points: array[0..2] of TPoint;
773
begin
774
  d3Window(x1, y1, z1, Points[0].x, Points[0].y);
775
  d3Window(x2, y2, z2, Points[1].x, Points[1].y);
776
  Points[2] := Points[0];
777
  ACanvas.Polyline(Points);
778
end;
779

780
procedure TWorldDrawing.d3DrawLineto(ACanvas: TCanvas; x, y, z: MathFloat);
781
var
782
  xs, Ys: longint;
783
begin
784
  d3Window(x, y, z, xs, Ys);
785
  ACanvas.LineTo(xs, Ys);
786
end;
787

788
procedure TWorldDrawing.d3drawZeroCross(ACanvas: TCanvas);
789
begin
790
  if 0 >= fd3x1 then if 0 <= fd3x1 + fd3xw then if 0 >= fd3z1 then
791
        if 0 <= fd3z1 + fd3zw then
792
          d3DrawLine(ACanvas, 0, fd3y1, 0, 0, fd3y1 + fd3yw, 0);
793
  if 0 >= fd3z1 then if 0 <= fd3z1 + fd3zw then if 0 >= fd3y1 then
794
        if 0 <= fd3y1 + fd3yw then
795
          d3DrawLine(ACanvas, fd3x1, 0, 0, fd3x1 + fd3xw, 0, 0);
796
  if 0 >= fd3y1 then if 0 <= fd3y1 + fd3yw then if 0 >= fd3x1 then
797
        if 0 <= fd3x1 + fd3xw then
798
          d3DrawLine(ACanvas, 0, 0, fd3z1, 0, 0, fd3z1 + fd3zw);
799
end;
800

801
procedure TWorldDrawing.d3Moveto(ACanvas: TCanvas; x, y, z: MathFloat);
802
var
803
  xs, Ys: longint;
804
begin
805
  d3Window(x, y, z, xs, Ys);
806
  ACanvas.MoveTo(xs, Ys);
807
end;
808

809
procedure TWorldDrawing.d3DrawPoint(ACanvas: TCanvas; x, y, z: MathFloat);
810
var
811
  xs, Ys: longint;
812
begin
813
  d3Window(x, y, z, xs, Ys);
814
  ACanvas.Pixels[xs, Ys] := ACanvas.Pen.Color;
815
end;
816

817
procedure TWorldDrawing.d3DrawWorldbox(ACanvas: TCanvas);
818
begin
819
  d3DrawLine(ACanvas, basex, basey, basez, frontx, basey, basez);
820
  d3DrawLine(ACanvas, basex, basey, basez, basex, fronty, basez);
821
  d3DrawLine(ACanvas, basex, basey, basez, basex, basey, frontz);
822
  d3DrawLine(ACanvas, basex, fronty, basez, frontx, fronty, basez);
823
  d3DrawLine(ACanvas, basex, fronty, basez, basex, fronty, frontz);
824
  d3DrawLine(ACanvas, basex, basey, frontz, frontx, basey, frontz);
825
  d3DrawLine(ACanvas, basex, basey, frontz, basex, fronty, frontz);
826
  d3DrawLine(ACanvas, frontx, basey, basez, frontx, fronty, basez);
827
  d3DrawLine(ACanvas, frontx, basey, basez, frontx, basey, frontz);
828
end;
829

830
procedure TWorldDrawing.d3Polyline(ACanvas: TCanvas;
831
  const FloatPointArray: array of TD3FloatPoint; PointCount: Integer);
832
var
833
  i: Integer; p: array of TPoint;
834
begin
835
  //Do exception checking in TMathImage
836
  SetLength(p, PointCount);
837
  for i := 0 to PointCount - 1 do
838
    with FloatPointArray[i] do
839
    begin
840
      d3Window(x, y, z, p[i].x, p[i].y);
841
    end;
842
  ACanvas.Polyline(p);
843
end;
844

845
function GetIlluminatedColor(AColor: TColor; BDiff, BSpec: MathFloat): TColor; forward;
846

847

848

849
procedure SortLineSegments(var AArray: Td3LineSegmentArray);
850

851
  procedure QuickSort(iLo, iHi:
852
    Integer);
853
  var
854
    Lo, Hi: Integer; Mid: Td3LineSegment; Temp: Td3LineSegment;
855
  begin
856
    Lo := iLo;
857
    Hi := iHi;
858
    Mid := AArray[(Lo + Hi) div 2];
859
    repeat
860
      while AArray[Lo].dist > Mid.dist do inc(Lo);
861
      while AArray[Hi].dist < Mid.dist do dec(Hi);
862
      if Lo <= Hi then
863
      begin
864
        Temp := AArray[Lo];
865
        AArray[Lo] := AArray[Hi];
866
        AArray[Hi] := Temp;
867
        inc(Lo);
868
        dec(Hi);
869
      end;
870
    until Lo > Hi;
871
    if Hi > iLo then QuickSort(iLo, Hi);
872
    if Lo < iHi then QuickSort(Lo, iHi);
873
  end;
874

875
begin
876
  QuickSort(0, High(AArray));
877
end;
878

879
procedure GetLineSegments(const f: array of TD3FloatPoint; aCount: Integer; NormalKind: TNormalKind; var l: Td3LineSegmentArray);
880
var i: Integer;
881
  x1, y1, z1, x2, y2, z2, X3, Y3, z3, u, v: MathFloat;
882
begin
883
  SetLength(l, (aCount - 1) div 2);
884
  for i := 0 to High(l) do
885
  begin
886
    l[i].p := @f[2 * i];
887
    l[i].q := @f[2 * i + 2];
888
    with f[2 * i] do
889
    begin
890
      x1 := x; y1 := y; z1 := z;
891
    end;
892
    with f[2 * i + 1] do
893
    begin
894
      x2 := x; y2 := y; z2 := z;
895
    end;
896
    with f[2 * i + 2] do
897
    begin
898
      X3 := x; Y3 := y; z3 := z;
899
    end;
900
    x1 := x2 - x1; y1 := y2 - y1; z1 := z2 - z1;
901
    if (x1 = 0) and (y1 = 0) and (z1 = 0) then
902
    begin
903
      D3FloatPoint(0, 0, 0, l[i].N1);
904
      D3FloatPoint(0, 0, 0, l[i].N2);
905
      Continue;
906
    end;
907
    x2 := (X3 - x2 - x1); y2 := (Y3 - y2 - y1); z2 := (z3 - z2 - z1);
908
    x1 := 0.5 * (l[i].q.x - l[i].p.x); y1 := 0.5 * (l[i].q.y - l[i].p.y); z1 := 0.5 * (l[i].q.z - l[i].p.z);
909
    u := sqr(x1) + sqr(y1) + sqr(z1);
910
    v := x1 * x2 + y1 * y2 + z1 * z2;
911
    X3 := u * x2 - v * x1;
912
    Y3 := u * y2 - v * y1;
913
    z3 := u * z2 - v * z1;
914
    u := 1 / sqr(u);
915
    X3 := u * X3; Y3 := u * Y3; z3 := u * z3;
916
    if (X3 = 0) and (Y3 = 0) and (z3 = 0) then
917
      if i = 0 then
918
      begin
919
        if x1 = 0 then
920
        begin
921
          X3 := 0; Y3 := z1; z3 := -y1;
922
        end
923
        else
924
        begin
925
          X3 := y1; Y3 := -x1; z3 := 0;
926
        end;
927
      end
928
      else
929
      begin
930
        l[i].N1 := l[i - 1].N1;
931
        l[i].N2 := l[i - 1].N2;
932
        Continue;
933
      end;
934
    //if NormalKind = nkSecondary then
935
    CrossProduct(x1, y1, z1, X3, Y3, z3, l[i].N2.x, l[i].N2.y, l[i].N2.z);
936
    l[i].N1.x := X3; l[i].N1.y := Y3; l[i].N1.z := z3;
937
  end;
938
 { l[aCount - 2].p := @f[aCount - 2];
939
  l[aCount - 2].q := @f[aCount - 1];
940
  with l[aCount - 2] do
941
  begin
942
    n1 := l[aCount - 3].n1;
943
    n2 := l[aCount - 3].n2;
944
  end; }
945
end;
946

947
procedure TWorldDrawing.GetIlluminatedLinesegments(AColor: TColor; diffuse, focussed, RightIntensity: MathFloat; z1, z2, y1, y2: Integer; d1, d2: MathFloat; fixed: Boolean; var l: Td3LineSegmentArray);
948
var i: Integer; bp, bs, bp1, bp2, bs1, bs2, bpSpec, bsSpec, b, BSpec, x, y, z, Norm1, Norm2,
949
  Norml1, Norml2, Normc, Normh1, Normh2, CamScalar1, CamScalar2: MathFloat;
950
  ns1, ns2, l1, l2, l1loc, l2loc, cam, h1, h2: TD3FloatPoint;
951
//this is a hodgepodge, so far. Needs to be organized  
952
begin
953
  fd3L1.fixed := fixed;
954
  fd3L2.fixed := fixed;
955
  fd3L1.dist := d1;
956
  fd3L1.YRotation := y1;
957
  fd3L1.ZRotation := z1;
958
  fd3L2.dist := d2;
959
  fd3L2.YRotation := y2;
960
  fd3L2.ZRotation := z2;
961
  l1 := fd3L1.SourcePoint;
962
  l2 := fd3L2.SourcePoint;
963
  bpSpec := 0;
964
  bsSpec := 0;
965
  for i := 0 to High(l) do
966
  begin
967
    with l[i] do
968
    begin
969
      Block(0.5 * (p.x + q.x), 0.5 * (p.y + q.y), 0.5 * (p.z + q.z), x, y, z);
970
      D3FloatPoint(l1.x - x, l1.y - y, l1.z - z, l1loc);
971
      D3FloatPoint(l2.x - x, l2.y - y, l2.z - z, l2loc);
972
      D3FloatPoint(fd3ViewPoint.x - x, fd3ViewPoint.y - y, fd3ViewPoint.z - z, cam);
973
      dist := sqr(cam.x) + sqr(cam.y) + sqr(cam.z); //squaredist
974
      ScaleNormal(N1, ns1);
975
      ScaleNormal(N2, ns2);
976

977
      CamScalar2 := cam.x * ns2.x + cam.y * ns2.y + cam.z * ns2.z;
978
      CamScalar1 := cam.x * ns1.x + cam.y * ns1.y + cam.z * ns1.z;
979
      d3Norm(l1loc, Norml1);
980
      d3Norm(l2loc, Norml2);
981
      Norml1 := 1 / Norml1;
982
      Norml2 := 1 / Norml2;
983
      d3Norm(ns1, Norm1);
984
      d3Norm(ns2, Norm2);
985
      if Norm1 = 0 then
986
      begin
987
        bp := 0;
988
       // Width := 0;
989
      end
990
      else
991
      begin
992
        bp1 := l1loc.x * ns1.x + l1loc.y * ns1.y + l1loc.z * ns1.z;
993
        bp1 := bp1 / Norm1 * Norml1;
994
        //bp1: light from light source 1 in principal direction
995
        if bp1 > 0 then //shines on direction in curvature
996
          if CamScalar1 > 0 then
997
            bp1 := bp1 * (1 - 0.1 * Norm1)
998
          else bp1 := 0;
999
        if bp1 < 0 then
1000
          if CamScalar1 < 0 then
1001
            bp1 := -bp1 * (1 + 0.1 * Norm1)
1002
          else bp1 := 0;
1003
        //Width := b;
1004
        bp1 := bp1 * 49 * Norml1 * Norml1; //scaled by Light dist
1005
        bp2 := l2loc.x * ns1.x + l2loc.y * ns1.y + l2loc.z * ns1.z;
1006
        bp2 := bp2 / Norm1 * Norml2;
1007
        if bp2 > 0 then //shines on direction in curvature
1008
          if CamScalar1 > 0
1009
            then
1010
            bp2 := bp2 * (1 - 0.1 * Norm1)
1011
          else
1012
            bp2 := 0;
1013
        if bp2 < 0 then
1014
          if CamScalar1 < 0 then
1015
            bp2 := -bp2 * (1 + 0.1 * Norm1)
1016
          else
1017
            bp2 := 0;
1018
        bp2 := bp2 * 49 * Norml2 * Norml2;
1019
        bp := RightIntensity * bp1 + (1 - RightIntensity) * bp2;
1020
        Normc := sqrt(dist);
1021
        Normc := 1 / Normc;
1022
        D3FloatPoint(Normc * cam.x + l1loc.x * Norml1, Normc * cam.y + l1loc.y * Norml1, Normc * cam.z + l1loc.z * Norml1, h1);
1023
        d3Norm(h1, Normh1);
1024
        bp1 := ns1.x * h1.x + ns1.y * h1.y + ns1.z * h1.z;
1025
        if bp1 * CamScalar1 > 0 then
1026
          bp1 := abs(bp1) / Norm1 / Normh1
1027
        else
1028
          bp1 := 0;
1029
        if bp1 > 0 then
1030
        begin
1031
          if bp1 > 1 then
1032
            bp1 := 1;
1033
          bp1 := exp(40 * ln(bp1));
1034
          bp1 := bp1 * 55 * Norml1 * Norml1;
1035
        end;
1036
        D3FloatPoint(Normc * cam.x + l2loc.x * Norml2, Normc * cam.y + l2loc.y * Norml2, Normc * cam.z + l2loc.z * Norml2, h2);
1037
        d3Norm(h2, Normh2);
1038
        bp2 := ns1.x * h2.x + ns1.y * h2.y + ns1.z * h2.z;
1039
        if CamScalar1 * bp2 > 0 then
1040
          bp2 := abs(bp2) / Norm1 / Normh2
1041
        else
1042
          bp2 := 0;
1043
        if bp2 > 0 then
1044
        begin
1045
          if bp2 > 1 then bp2 := 1;
1046
          bp2 := exp(40 * ln(bp2));
1047
          bp2 := bp2 * 55 * Norml2 * Norml2;
1048
        end;
1049
        bpSpec := RightIntensity * bp1 + (1 - RightIntensity) * bp2;
1050
      end;
1051
      if Norm2 = 0 then
1052
      begin
1053
        bs := 0;
1054
       // Width := 0;
1055
      end
1056
      else
1057
      begin
1058
        Norm2 := 1 / Norm2;
1059
        bs1 := l1loc.x * ns2.x + l1loc.y * ns2.y + l1loc.z * ns2.z;
1060
        bs1 := bs1 * Norm2 * Norml1; //bs1: light from light source 2 in secondary direction
1061
        if bs1 * CamScalar2 > 0 then
1062
          bs1 := abs(bs1) * 49 * Norml1 * Norml1
1063
        else
1064
          bs1 := 0;
1065
        bs2 := l2loc.x * ns2.x + l2loc.y * ns2.y + l2loc.z * ns2.z;
1066
        if CamScalar2 * bs2 > 0 then
1067
          bs2 := abs(bs2) * Norm2 * Norml2
1068
        else
1069
          bs2 := 0;
1070
        bs2 := bs2 * 49 * Norml2 * Norml2;
1071
        bs := RightIntensity * bs1 + (1 - RightIntensity) * bs2;
1072
        bs1 := ns2.x * h1.x + ns2.y * h1.y + ns2.z * h1.z;
1073
        if CamScalar2 * bs1 > 0 then
1074
          bs1 := abs(bs1) * Norm2 / Normh1
1075
        else
1076
          bs1 := 0;
1077
        if bs1 <> 0 then
1078
        begin
1079
          if bs1 > 1 then
1080
            bs1 := 1;
1081
          bs1 := exp(60 * ln(abs(bs1)));
1082
          bs1 := bs1 * 55 * Norml1 * Norml1;
1083
        end;
1084
        bs2 := ns2.x * h2.x + ns2.y * h2.y + ns2.z * h2.z;
1085
        if bs2 * CamScalar2 > 0 then
1086
          bs2 := abs(bs2) * Norm2 / Normh2
1087
        else
1088
          bs2 := 0;
1089
        if bs2 <> 0 then
1090
        begin
1091
          if bs2 > 1 then
1092
            bs2 := 1;
1093
          bs2 := exp(60 * ln(abs(bs2)));
1094
          bs2 := bs2 * 55 * Norml2 * Norml2;
1095
        end;
1096
        bsSpec := RightIntensity * bs1 + (1 - RightIntensity) * bs2;
1097
      end;
1098
      bs := (diffuse + focussed * bs);
1099
      bp := (diffuse + focussed * bp);
1100
      b := bp + bs;
1101
      b := b * 0.5 * sqr(fd3vd) / dist;
1102
      BSpec := 0.7 * bpSpec + 0.3 * bsSpec;
1103
      BSpec := focussed * 60 * BSpec*sqr(fd3vd)/dist;
1104
      Color := GetIlluminatedColor(AColor, b, BSpec);
1105
      //Width := 1;
1106
    end;
1107
  end;
1108
end;
1109

1110
procedure TWorldDrawing.ScaleVector(const v: TD3FloatPoint; var w: TD3FloatPoint);
1111
begin
1112
  w.x := axd3 * v.x;
1113
  w.y := ayd3 * v.y;
1114
  w.z := azd3 * v.z;
1115
end;
1116

1117
procedure TWorldDrawing.ScaleNormal(const v: TD3FloatPoint; var w: TD3FloatPoint);
1118
begin
1119
  w.x := axd3Inv * v.x;
1120
  w.y := ayd3Inv * v.y;
1121
  w.z := azd3Inv * v.z;
1122
end;
1123

1124

1125

1126
procedure TWorldDrawing.d3LitPolyLine(ACanvas: TCanvas;
1127
  const FloatPointArray: array of TD3FloatPoint; PointCount: Integer;
1128
  NormalKind: TNormalKind;
1129
  ambient, directed: MathFloat; zrot1, zrot2, yrot1, yrot2: Integer; dist1, dist2: MathFloat; fixed: Boolean);
1130
var
1131
  savecolor: TColor;
1132
  lines: Td3LineSegmentArray;
1133
  RightIntensity: MathFloat;
1134
begin
1135
  savecolor := ACanvas.Pen.Color;
1136
  GetLineSegments(FloatPointArray, PointCount, NormalKind, lines);
1137
  if NormalKind = nkPrincipal then RightIntensity := 0.8 else RightIntensity := 0.2;
1138
  GetIlluminatedLinesegments(savecolor, ambient, directed, RightIntensity, zrot1, zrot2, yrot1, yrot2, dist1, dist2, fixed, lines);
1139
  DrawLineSegments(ACanvas, lines);
1140
end;
1141

1142
procedure TWorldDrawing.d3PolyPolyline(ACanvas: TCanvas;
1143
  const GraphList: array of Td3FloatPointArray);
1144
var i: Integer;
1145
begin
1146
  for i := Low(GraphList) to High(GraphList) do
1147
    d3Polyline(ACanvas, GraphList[i], Length(GraphList[i]));
1148
end;
1149

1150

1151
(***************  procedures and types for surface drawing ******************)
1152

1153
procedure CrossProduct(x1, y1, z1, x2, y2, z2: MathFloat; var u1, u2, u3: MathFloat);
1154
begin
1155
  u1 := y1 * z2 - z1 * y2;
1156
  u2 := z1 * x2 - x1 * z2;
1157
  u3 := x1 * y2 - y1 * x2;
1158
end;
1159

1160
procedure TWorldDrawing.GetBrightness(const p, n: TD3FloatPoint; var BDiff, BSpec: MathFloat);
1161
var
1162
  xb2, yb2, zb2, Normu, Normv,
1163
    Norml, ViewScalar, LightScalar: MathFloat;
1164
  u, v, lloc, h: TD3FloatPoint;
1165
  CanSee: Boolean;
1166
begin
1167
  ScaleNormal(n, u);
1168
  {Block(p.x + n.x, p.y + n.y, p.z + n.z, xb1, yb1, zb1);}
1169
  Block(p.x, p.y, p.z, xb2, yb2, zb2);
1170
  {u1 := xb1 - xb2; u2 := yb1 - yb2; u3 := zb1 - zb2;}
1171
  Normu := sqrt(sqr(u.x) + sqr(u.y) + sqr(u.z));
1172
  if Normu = 0 then
1173
  begin
1174
    BDiff := 0; BSpec := 0; exit;
1175
  end;
1176
  D3FloatPoint(8 * (cosz * 1.732 - sinz) * (siny * 1.732 - cosy) - xb2, 8 * (sinz * 1.732 + cosz) * (siny * 1.732 - cosy) - yb2, 8 * (cosy * 1.732 + siny) - zb2, lloc);
1177
  //lightsource vector
1178
  D3FloatPoint(fd3vd * cosz * siny - xb2, fd3vd * sinz * siny - yb2, fd3vd * cosy - zb2, v);
1179
   //viewpoint vector
1180
  ViewScalar := v.x * u.x + v.y * u.y + v.z * u.z;
1181
  LightScalar := lloc.x * u.x + lloc.y * u.y + lloc.z * u.z;
1182
  //DotProduct of view- and light- vectors with normal
1183
  CanSee := ViewScalar * LightScalar > 0;
1184
  //Viewer can see the side of the triangle which is illuminated?
1185
  d3Norm(lloc, Norml);
1186
  d3Norm(v, Normv);
1187
  Norml := 1 / Norml;
1188
  Normu := 1 / Normu;
1189
  Normv := 1 / Normv;
1190
  D3FloatPoint(v.x * Normv + lloc.x * Norml, v.y * Normv + lloc.y * Norml, v.z * Normv + lloc.z * Norml, h);
1191
  if CanSee then
1192
    BDiff := abs(LightScalar) * Norml * Normu
1193
  else
1194
    BDiff := 0.5 * abs(LightScalar) * Norml * Normu;
1195
   //light up shadows
1196
  d3Norm(h, Normv);
1197
  if Normv = 0 then
1198
  begin
1199
    BSpec := 0; exit;
1200
  end;
1201
  LightScalar := h.x * u.x + h.y * u.y + h.z * u.z;
1202
  if CanSee then
1203
  begin
1204
    BSpec := abs(LightScalar) / Normv * Normu;
1205
    BSpec := exp(30 * ln(BSpec));
1206
  end
1207
  else
1208
    BSpec := 0;
1209
end;
1210

1211
type
1212
  TReal = double;
1213

1214
// RGB, each 0 to 255, to HSV.
1215
// H = 0.0 to 360.0 (corresponding to 0..360.0 degrees around hexcone)
1216
// S = 0.0 (shade of gray) to 1.0 (pure color)
1217
// V = 0.0 (black) to 1.0 {white)
1218

1219
// Based on C Code in "Computer Graphics -- Principles and Practice,"
1220
// Foley et al, 1996, p. 592.
1221

1222
procedure RGBToHSV(const r, g, b: TReal; var h, s, v: TReal);
1223
var
1224
  delta: TReal;
1225
  min: TReal;
1226
begin
1227
  min := MinValue([r, g, b]); // USES Math
1228
  v := MaxValue([r, g, b]);
1229

1230
  delta := v - min;
1231

1232
  // Calculate saturation: saturation is 0 if r, g and b are all 0
1233
  if v = 0.0
1234
    then s := 0
1235
  else s := delta / v;
1236
  if s = 0.0
1237
    then h := 0 // Achromatic: When s = 0, h is undefined
1238
  else begin // Chromatic
1239
    delta := 1 / delta;
1240
    if r = v
1241
      then // between yellow and magenta [degrees]
1242
      h := 60.0 * (g - b) * delta
1243
    else
1244
      if g = v
1245
        then // between cyan and yellow
1246
        h := 120.0 + 60.0 * (b - r) * delta
1247
      else
1248
        if b = v
1249
          then // between magenta and cyan
1250
          h := 240.0 + 60.0 * (r - g) * delta;
1251

1252
    if h < 0.0
1253
      then h := h + 360.0
1254
  end
1255
end {RGBtoHSV};
1256

1257

1258

1259

1260

1261
// Based on C Code in "Computer Graphics -- Principles and Practice,"
1262
// Foley et al, 1996, p. 593.
1263
//
1264
// H = 0.0 to 360.0 (corresponding to 0..360 degrees around hexcone)
1265
// NaN (undefined) for S = 0
1266
// S = 0.0 (shade of gray) to 1.0 (pure color)
1267
// V = 0.0 (black) to 1.0 (white)
1268

1269
procedure HSVtoRGB(const h, s, v: TReal; var r, g, b: TReal);
1270
var
1271
  f: TReal;
1272
  i: Integer;
1273
  hTemp: TReal; // since H is CONST parameter
1274
  p, q, t: TReal;
1275
begin
1276
  if s = 0.0 // color is on black-and-white center line
1277
    then begin
1278
    {IF       IsNaN(H)
1279
    THEN BEGIN}
1280
    r := v; // achromatic: shades of gray
1281
    g := v;
1282
    b := v
1283
    {END
1284
    ELSE RAISE EColorError.Create('HSVtoRGB: S = 0 and H has a value');}
1285
  end
1286

1287
  else begin // chromatic color
1288
    if h = 360.0 // 360 degrees same as 0 degrees
1289
      then hTemp := 0.0
1290
    else hTemp := h;
1291

1292
    hTemp := 1 / 60 * hTemp; // h is now IN [0,6)
1293
    i := trunc(hTemp); // largest integer <= h
1294
    f := hTemp - i; // fractional part of h
1295

1296
    p := v * (1.0 - s);
1297
    q := v * (1.0 - (s * f));
1298
    t := v * (1.0 - (s * (1.0 - f)));
1299

1300
    case i of
1301
      0: begin r := v; g := t; b := p end;
1302
      1: begin r := q; g := v; b := p end;
1303
      2: begin r := p; g := v; b := t end;
1304
      3: begin r := p; g := q; b := v end;
1305
      4: begin r := t; g := p; b := v end;
1306
      5: begin r := v; g := p; b := q end
1307
    end
1308
  end
1309
end {HSVtoRGB};
1310

1311
{Translated C-code from Microsoft Knowledge Base
1312
-------------------------------------------
1313
Converting Colors Between RGB and HLS (HBS)
1314
Article ID: Q29240
1315
Creation Date: 26-APR-1988
1316
Revision Date: 02-NOV-1995
1317
The information in this article applies to:
1318

1319
Microsoft Windows Software Development Kit (SDK) for Windows versions 3.1 and 3.0
1320
Microsoft Win32 Application Programming Interface (API) included with:
1321

1322
    - Microsoft Windows NT versions 3.5 and 3.51
1323
    - Microsoft Windows 95 version 4.0
1324
SUMMARY
1325

1326

1327
The code fragment below converts colors between RGB (Red, Green, Blue) and HLS/HBS (Hue, Lightness, Saturation/Hue, Brightness, Saturation).
1328

1329

1330
MORE INFORMATION
1331

1332

1333
/* Color Conversion Routines --
1334

1335
RGBtoHLS() takes a DWORD RGB value, translates it to HLS, and stores the results in the global vars H, L, and S. HLStoRGB takes the current values of H, L, and S and returns the equivalent value in an RGB DWORD. The vars H, L, and S are only written to by:
1336

1337

1338
   1. RGBtoHLS (initialization)
1339
   2. The scroll bar handlers
1340
A point of reference for the algorithms is Foley and Van Dam, "Fundamentals of Interactive Computer Graphics," Pages 618-19. Their algorithm is in floating point. CHART implements a less general (hardwired ranges) integral algorithm.
1341
There are potential round-off errors throughout this sample. ((0.5 + x)/y) without floating point is phrased ((x + (y/2))/y), yielding a very small round-off error. This makes many of the following divisions look strange. */
1342

1343
*************************************************************************) }
1344
const
1345
  HLSMAX = 240; // H,L, and S vary over 0-HLSMAX
1346
  RGBMAX = 255; // R,G, and B vary over 0-RGBMAX
1347
    // HLSMAX BEST IF DIVISIBLE BY 6
1348
    // RGBMAX, HLSMAX must each fit in a byte.
1349
{ Hue is undefined if Saturation is 0 (grey-scale)
1350
  This value determines where the Hue scrollbar is
1351
  initially set for achromatic colors }
1352
  UNDEFINED = HLSMAX * 2 div 3;
1353

1354
procedure RGBtoHLS(r, g, b: Integer; var h, l, s: Integer);
1355
var
1356
  // R, G, B: Integer;              (* input RGB values *)
1357
  // H, L, S: Integer;
1358
  cmax, cmin: byte; (* max and min RGB values *)
1359
  Rdelta, Gdelta, Bdelta: Integer; (* intermediate value: % of spread from max*)
1360
begin
1361
   (* get R, G, and B out of DWORD *)
1362
  // R := GetRValue(RGBColor);
1363
  // G := GetGValue(RGBColor);
1364
  // B := GetBValue(RGBColor);
1365

1366
   (* calculate lightness *)
1367
  cmax := r;
1368
  if g > cmax then cmax := g;
1369
  if b > cmax then cmax := b;
1370

1371
  cmin := r;
1372
  if g < cmin then cmin := g;
1373
  if b < cmin then cmin := b;
1374

1375
  l := (((cmax + cmin) * HLSMAX) + RGBMAX) div (2 * RGBMAX);
1376

1377
  if (cmax = cmin) then // r=g=b --> achromatic case
1378
  begin
1379
    s := 0; // saturation
1380
    h := UNDEFINED; // hue
1381
  end else
1382
  begin // chromatic case
1383
     { saturation }
1384
    if l <= (HLSMAX div 2) then
1385
      s := (((cmax - cmin) * HLSMAX) + ((cmax + cmin) div 2)) div (cmax + cmin)
1386
    else
1387
      s := (((cmax - cmin) * HLSMAX) + ((2 * RGBMAX - cmax - cmin) div 2))
1388
        div (2 * RGBMAX - cmax - cmin);
1389

1390
     (* hue *)
1391
    Rdelta := (((cmax - r) * (HLSMAX div 6)) + ((cmax - cmin) div 2)) div (cmax - cmin);
1392
    Gdelta := (((cmax - g) * (HLSMAX div 6)) + ((cmax - cmin) div 2)) div (cmax - cmin);
1393
    Bdelta := (((cmax - b) * (HLSMAX div 6)) + ((cmax - cmin) div 2)) div (cmax - cmin);
1394

1395
    if r = cmax then
1396
      h := Bdelta - Gdelta
1397
    else if g = cmax then
1398
      h := (HLSMAX div 3) + Rdelta - Bdelta
1399
    else (* B = cMax *)
1400
      h := ((2 * HLSMAX) div 3) + Gdelta - Rdelta;
1401

1402
    h := h mod HLSMAX;
1403
    if h < 0 then
1404
      inc(h, HLSMAX);
1405
  end;
1406
 // Result.Hue        := H;
1407
 // Result.Luminance  := L;
1408
 // Result.Saturation := S;
1409
end;
1410

1411
function HueToRGB(N1, N2, hue: Integer): Integer;
1412
(* utility routine for HLStoRGB *)
1413
begin
1414
  hue := hue mod HLSMAX;
1415
   (* range check: note values passed add div subtract thirds of range *)
1416
  if hue < 0 then
1417
    inc(hue, HLSMAX);
1418

1419
   (* return r,g, or b value from this tridrant *)
1420
  if hue < (HLSMAX div 6) then
1421
    Result := (N1 + (((N2 - N1) * hue + (HLSMAX div 12)) div (HLSMAX div 6))) else
1422
    if hue < (HLSMAX div 2) then
1423
      Result := N2 else
1424
      if hue < ((HLSMAX * 2) div 3) then
1425
        Result := (N1 + (((N2 - N1) * (((HLSMAX * 2) div 3) - hue) + (HLSMAX div 12)) div (HLSMAX div 6)))
1426
      else
1427
        Result := N1;
1428
end;
1429

1430
procedure HLStoRGB(hue, Luminance, Saturation: Integer; var r, g, b: Integer);
1431
var
1432
 //  R, G, B: Integer;              (* RGB component values *)
1433
  Magic1, Magic2: Integer; (* calculated magic numbers (really!) *)
1434
begin
1435
  if Saturation = 0 then (* achromatic case *)
1436
  begin
1437
    r := (Luminance * RGBMAX) div HLSMAX;
1438
    g := r;
1439
    b := r;
1440
    if hue <> UNDEFINED then
1441
    begin
1442
  (* ERROR *)
1443
    end
1444
  end else
1445
  begin (* chromatic case *)
1446
      (* set up magic numbers *)
1447
    if (Luminance <= (HLSMAX div 2)) then
1448
      Magic2 := (Luminance * (HLSMAX + Saturation) + (HLSMAX div 2)) div HLSMAX
1449
    else
1450
      Magic2 := Luminance + Saturation - ((Luminance * Saturation) + (HLSMAX div 2)) div HLSMAX;
1451
    Magic1 := 2 * Luminance - Magic2;
1452
      (* get RGB, change units from HLSMAX to RGBMAX *)
1453
    r := (HueToRGB(Magic1, Magic2, hue + (HLSMAX div 3)) * RGBMAX + (HLSMAX div 2)) div HLSMAX;
1454
    g := (HueToRGB(Magic1, Magic2, hue) * RGBMAX + (HLSMAX div 2)) div HLSMAX;
1455
    b := (HueToRGB(Magic1, Magic2, hue - (HLSMAX div 3)) * RGBMAX + (HLSMAX div 2)) div HLSMAX;
1456
  end;
1457
   //Result :=  RGB(R,G,B);
1458
end;
1459

1460

1461

1462
function GetIlluminatedColor(AColor: TColor; BDiff, BSpec: MathFloat): TColor;
1463
var
1464
  ri, gi, bi: Integer;
1465
begin
1466
  {epsilon := 1.E-12;
1467
  ri := GetRValue(AColor);
1468
  gi := GetGValue(AColor);
1469
  bi := GetBValue(AColor);
1470
  r := 1 / 255 * ri; g := 1 / 255 * gi; b := 1 / 255 * bi;
1471
  RGBtoHLS(ri, gi, bi, Hi, li, si);
1472
  li := round(5 / 3 * li * Brightness);
1473
  if li > HLSMAX then li := HLSMAX;
1474
  if li < 0 then li := 0;
1475
  HLStoRGB(Hi, li, si, ri, gi, bi);
1476
  RGBToHSV(r, g, b, h, s, v);
1477
  v := 5 / 3 * v * Brightness;
1478
  if v > 1 then v := 1;
1479
  if v < 0 then v := 0;
1480
  HSVtoRGB(h, s, v, r, g, b);
1481
  t := 0.5;
1482
  l := 1 - t;
1483
  r := 1 / 255 * t * ri + l * r;
1484
  g := 1 / 255 * t * gi + l * g;
1485
  b := 1 / 255 * t * bi + l * b;
1486
  if r > 1 then r := 1;
1487
  if g > 1 then g := 1;
1488
  if b > 1 then b := 1;
1489
  if r < epsilon then r := 0;
1490
  if b < epsilon then b := 0;
1491
  if g < epsilon then g := 0;
1492
  Result := RGB(round(255 * r), round(255 * g), round(255 * b));}
1493
  ri := GetRValue(AColor);
1494
  gi := GetGValue(AColor);
1495
  bi := GetBValue(AColor);
1496
  ri := round(BDiff * ri + BSpec);
1497
  if ri > 255 then ri := 255;
1498
  gi := round(BDiff * gi + BSpec);
1499
  if gi > 255 then gi := 255;
1500
  bi := round(BDiff * bi + 1.1 * BSpec);
1501
  if bi > 255 then bi := 255;
1502
  Result := RGB(ri, gi, bi);
1503
end;
1504

1505

1506

1507
procedure sort4Cells(var AArray: array of T4Cell);
1508

1509
  procedure QuickSort4(iLo, iHi:
1510
    Integer);
1511
  var
1512
    Lo, Hi: Integer; Mid: T4Cell; Temp: T4Cell;
1513
  begin
1514
    Lo := iLo;
1515
    Hi := iHi;
1516
    Mid := AArray[(Lo + Hi) div 2];
1517
    repeat
1518
      while AArray[Lo].dist > Mid.dist do inc(Lo);
1519
      while AArray[Hi].dist < Mid.dist do dec(Hi);
1520
      if Lo <= Hi then
1521
      begin
1522
        Temp := AArray[Lo];
1523
        AArray[Lo] := AArray[Hi];
1524
        AArray[Hi] := Temp;
1525
        inc(Lo);
1526
        dec(Hi);
1527
      end;
1528
    until Lo > Hi;
1529
    if Hi > iLo then QuickSort4(iLo, Hi);
1530
    if Lo < iHi then QuickSort4(Lo, iHi);
1531
  end;
1532

1533

1534
begin
1535
  QuickSort4(0, High(AArray));
1536
end;
1537

1538
procedure Sort3Cells(var AArray: array of T3Cell);
1539

1540
  procedure QuickSort3(iLo, iHi:
1541
    Integer);
1542
  var
1543
    Lo, Hi: Integer; Mid: T3Cell; Temp: T3Cell;
1544
  begin
1545
    Lo := iLo;
1546
    Hi := iHi;
1547
    Mid := AArray[(Lo + Hi) div 2];
1548
    repeat
1549
      while AArray[Lo].dist > Mid.dist do inc(Lo);
1550
      while AArray[Hi].dist < Mid.dist do dec(Hi);
1551
      if Lo <= Hi then
1552
      begin
1553
        Temp := AArray[Lo];
1554
        AArray[Lo] := AArray[Hi];
1555
        AArray[Hi] := Temp;
1556
        inc(Lo);
1557
        dec(Hi);
1558
      end;
1559
    until Lo > Hi;
1560
    if Hi > iLo then QuickSort3(iLo, Hi);
1561
    if Lo < iHi then QuickSort3(Lo, iHi);
1562
  end;
1563

1564
begin
1565
  QuickSort3(0, High(AArray));
1566
end;
1567

1568

1569

1570
procedure GetTriangles(const SurfArray: array of Td3FloatPointArray; var Triangles: TD3TriangleArray);
1571
var i, j, imax, jmax, Current: Integer;
1572
begin
1573
  imax := High(SurfArray);
1574
  jmax := High(SurfArray[0]);
1575
  SetLength(Triangles, 2 * imax * jmax);
1576
  Current := 0;
1577
  for i := 0 to imax - 1 do
1578
    for j := 0 to jmax - 1 do
1579
    begin
1580
      if not (odd(i) or odd(j)) or (odd(i) and odd(j)) then
1581
      begin
1582
        with Triangles[Current] do
1583
        begin
1584
          p := @SurfArray[i][j];
1585
          q := @SurfArray[i + 1][j];
1586
          r := @SurfArray[i][j + 1];
1587
        end;
1588
        inc(Current);
1589
        with Triangles[Current] do
1590
        begin
1591
          p := @SurfArray[i + 1][j + 1];
1592
          q := @SurfArray[i + 1][j];
1593
          r := @SurfArray[i][j + 1];
1594
        end;
1595
        inc(Current);
1596
      end
1597
      else
1598
      begin
1599
        with Triangles[Current] do
1600
        begin
1601
          p := @SurfArray[i][j];
1602
          q := @SurfArray[i][j + 1];
1603
          r := @SurfArray[i + 1][j + 1];
1604
        end;
1605
        inc(Current);
1606
        with Triangles[Current] do
1607
        begin
1608
          p := @SurfArray[i + 1][j];
1609
          q := @SurfArray[i + 1][j + 1];
1610
          r := @SurfArray[i][j];
1611
        end;
1612
        inc(Current);
1613
      end;
1614
    end;
1615
  for i := 0 to High(Triangles) do
1616
    with Triangles[i] do
1617
      CrossProduct(p.x - r.x, p.y - r.y, p.z - r.z, q.x - r.x, q.y - r.y, q.z - r.z, n.x, n.y, n.z);
1618
end;
1619

1620

1621
(*************** End: procedures and types for surface drawing ******************)
1622

1623

1624
(*************** The surface drawing routines *****************************)
1625

1626

1627
procedure TWorldDrawing.d3DrawLitSurface(ACanvas: TCanvas;
1628
  const SurfArray: array of Td3FloatPointArray; diffuse, focussed: MathFloat);
1629

1630
var
1631
  Triangles: TD3TriangleArray;
1632
  i: Integer;
1633
begin
1634
  GetTriangles(SurfArray, Triangles);
1635
  fDefaultFillColor := ACanvas.Brush.Color;
1636
  for i := 0 to High(Triangles) do
1637
    Triangles[i].FillColor := @fDefaultFillColor;
1638
  d3DrawLitTriangles(ACanvas, Triangles, diffuse, focussed);
1639
end;
1640

1641
procedure TWorldDrawing.d3DrawLitTriangles(ACanvas: TCanvas;
1642
  const Triangles: array of TD3Triangle; diffuse, focussed: MathFloat);
1643
var Cells: array of T3Cell;
1644
  i: Integer;
1645
  c: TD3FloatPoint;
1646
  SaveBrush: TBrush;
1647
  SavePen: TPen;
1648
begin
1649
  SaveBrush := TBrush.Create;
1650
  SavePen := TPen.Create;
1651
  SaveBrush.assign(ACanvas.Brush);
1652
  SavePen.assign(ACanvas.Pen);
1653
  SetLength(Cells, Length(Triangles));
1654
  for i := 0 to High(Triangles) do
1655
  begin
1656
    with Triangles[i], Cells[i] do
1657
    begin
1658
      c.x := 1 / 3 * (r.x + q.x + p.x);
1659
      c.y := 1 / 3 * (r.y + q.y + p.y);
1660
      c.z := 1 / 3 * (r.z + q.z + r.z);
1661
      d3DistanceToViewer(c.x, c.y, c.z, dist);
1662
      d3Window(p.x, p.y, p.z, Vertex[0].x, Vertex[0].y);
1663
      d3Window(q.x, q.y, q.z, Vertex[1].x, Vertex[1].y);
1664
      d3Window(r.x, r.y, r.z, Vertex[2].x, Vertex[2].y);
1665
    end;
1666
    GetBrightness(c, Triangles[i].n, Cells[i].BDiff, Cells[i].BSpec);
1667
    Cells[i].FillColor := GetIlluminatedColor(Triangles[i].FillColor^, (diffuse + Cells[i].BDiff * focussed), focussed * 100 * Cells[i].BSpec);
1668
  end;
1669
  Sort3Cells(Cells);
1670
  ACanvas.Brush.Style := bssolid;
1671
  ACanvas.Pen.Style := psSolid;
1672
  ACanvas.Pen.Width := 1;
1673
  for i := 0 to High(Cells) do
1674
    with Cells[i] do
1675
    begin
1676
      ACanvas.Brush.Color := FillColor;
1677
      ACanvas.Pen.Color := FillColor;
1678
      ACanvas.Polygon(Cells[i].Vertex);
1679
    end;
1680
  ACanvas.Brush.assign(SaveBrush);
1681
  ACanvas.Pen.assign(SavePen);
1682
  SaveBrush.Free;
1683
  SavePen.Free;
1684
end;
1685

1686

1687
procedure TWorldDrawing.d3DrawSurface(ACanvas: TCanvas;
1688
  const SurfArray: array of Td3FloatPointArray; fill: Boolean);
1689
var
1690
  i, j, imax, jmax: Integer;
1691
  p: TD3FloatPoint;
1692
  SurfaceCells: array of TD3SurfaceCell;
1693
  Current: Integer;
1694
begin
1695
  imax := High(SurfArray);
1696
  jmax := High(SurfArray[0]);
1697
  //assume all same length!! { TODO : warning }
1698
  if not fill then
1699
  begin
1700
    for i := 0 to imax do
1701
      d3Polyline(ACanvas, SurfArray[i], jmax + 1);
1702
    for j := 0 to jmax do
1703
    begin
1704
      p := SurfArray[0][j];
1705
      d3Moveto(ACanvas, p.x, p.y, p.z);
1706
      for i := 1 to imax do
1707
      begin
1708
        p := SurfArray[i][j];
1709
        d3DrawLineto(ACanvas, p.x, p.y, p.z);
1710
      end;
1711
    end;
1712
  end
1713
  else
1714
  begin
1715
    fDefaultFillColor := ACanvas.Brush.Color;
1716
    fDefaultWireColor := ACanvas.Pen.Color;
1717
    SetLength(SurfaceCells, imax * jmax);
1718
    Current := 0;
1719
    for i := 0 to imax - 1 do
1720
      for j := 0 to jmax - 1 do
1721
      begin
1722
        SurfaceCells[Current].p := @SurfArray[i][j];
1723
        SurfaceCells[Current].q := @SurfArray[i + 1][j];
1724
        SurfaceCells[Current].r := @SurfArray[i + 1][j + 1];
1725
        SurfaceCells[Current].s := @SurfArray[i][j + 1];
1726
        SurfaceCells[Current].WireColor := @fDefaultWireColor;
1727
        SurfaceCells[Current].FillColor := @fDefaultFillColor;
1728
        inc(Current);
1729
      end;
1730
    d3DrawSurfaceCells(ACanvas, SurfaceCells);
1731
  end;
1732
end;
1733

1734

1735

1736
procedure TWorldDrawing.d3DrawTriangles(ACanvas: TCanvas;
1737
  const Triangles: array of TD3Triangle);
1738
var Cells: array of T3Cell;
1739
  i: Integer;
1740
  d: MathFloat;
1741
  SaveBrush, SavePen: TColor;
1742
begin
1743
  SaveBrush := ACanvas.Brush.Color;
1744
  SavePen := ACanvas.Pen.Color;
1745
  SetLength(Cells, Length(Triangles));
1746
  for i := 0 to High(Cells) do
1747
  begin
1748
   // New(Cells[i]);
1749
    with Triangles[i], Cells[i] do
1750
    begin
1751
      d3Window(p.x, p.y, p.z, Vertex[0].x, Vertex[0].y);
1752
      d3DistanceToViewer(p.x, p.y, p.z, dist);
1753
      d3Window(q.x, q.y, q.z, Vertex[1].x, Vertex[1].y);
1754
      d3DistanceToViewer(q.x, q.y, q.z, d);
1755
      dist := dist + d;
1756
      d3Window(r.x, r.y, r.z, Vertex[2].x, Vertex[2].y);
1757
      d3DistanceToViewer(r.x, r.y, r.z, d);
1758
      dist := dist + d;
1759
    end;
1760
  end;
1761
  Sort3Cells(Cells);
1762
  for i := 0 to High(Cells) do
1763
  begin
1764
    ACanvas.Brush.Color := Triangles[i].FillColor^;
1765
    ACanvas.Pen.Color := Triangles[i].WireColor^;
1766
    ACanvas.Polygon(Cells[i].Vertex);
1767
  end;
1768
//  for i := 0 to High(Cells) do
1769
  //  dispose(Cells[i]);
1770
  ACanvas.Brush.Color := SaveBrush;
1771
  ACanvas.Pen.Color := SavePen;
1772
end;
1773

1774
procedure TWorldDrawing.Draw4Cells(ACanvas: TCanvas; const Cells: array of T4Cell);
1775
var
1776
  i: Integer;
1777
  SaveBrush: TBrush;
1778
  SavePen: TPen;
1779
begin
1780
  SaveBrush := TBrush.Create;
1781
  SavePen := TPen.Create;
1782
  SaveBrush.assign(ACanvas.Brush);
1783
  SavePen.assign(ACanvas.Pen);
1784
  for i := 0 to High(Cells) do
1785
  begin
1786
    ACanvas.Brush.Color := Cells[i].FillColor;
1787
    ACanvas.Pen.Color := Cells[i].WireColor;
1788
    ACanvas.Polygon(Cells[i].Vertex);
1789
  end;
1790
  ACanvas.Brush.assign(SaveBrush);
1791
  ACanvas.Pen.assign(SavePen);
1792
  SaveBrush.Free;
1793
  SavePen.Free;
1794
end;
1795

1796
procedure TWorldDrawing.d3DrawSurfaceCells(ACanvas: TCanvas;
1797
  const SurfaceCells: array of TD3SurfaceCell);
1798
var Cells: array of T4Cell;
1799
  i: Integer;
1800
  d: MathFloat;
1801
begin
1802
  SetLength(Cells, Length(SurfaceCells));
1803
  for i := 0 to High(Cells) do
1804
  begin
1805
  //  New(Cells[i]);
1806
    with SurfaceCells[i], Cells[i] do
1807
    begin
1808
      d3Window(p.x, p.y, p.z, Vertex[0].x, Vertex[0].y);
1809
      d3DistanceToViewer(p.x, p.y, p.z, dist);
1810
      d3Window(q.x, q.y, q.z, Vertex[1].x, Vertex[1].y);
1811
      d3DistanceToViewer(q.x, q.y, q.z, d);
1812
      dist := dist + d;
1813
      d3Window(r.x, r.y, r.z, Vertex[2].x, Vertex[2].y);
1814
      d3DistanceToViewer(r.x, r.y, r.z, d);
1815
      dist := dist + d;
1816
      d3Window(s.x, s.y, s.z, Vertex[3].x, Vertex[3].y);
1817
      d3DistanceToViewer(s.x, s.y, s.z, d);
1818
      dist := dist + d;
1819
    end;
1820
    Cells[i].FillColor := SurfaceCells[i].FillColor^;
1821
    Cells[i].WireColor := SurfaceCells[i].WireColor^;
1822
  end;
1823
  sort4Cells(Cells);
1824
  Draw4Cells(ACanvas, Cells);
1825
//  for i := 0 to High(Cells) do
1826
//    dispose(Cells[i]);
1827
end;
1828

1829

1830
procedure TWorldDrawing.d3DrawCubes(ACanvas: TCanvas; const Cubes: array of TCube; fill: Boolean);
1831
var
1832
  Cells: array of TD3SurfaceCell;
1833
  i, j: Integer;
1834
  SavePen: TColor;
1835
begin
1836
  if not fill then
1837
  begin
1838
    SavePen := ACanvas.Pen.Color;
1839
    for i := 0 to High(Cubes) do
1840
      with Cubes[i] do
1841
      begin
1842
        ACanvas.Pen.Color := Cubes[i].WireColor;
1843
        d3DrawBox(ACanvas, x1, y1, z1, x2, y2, z2);
1844
      end;
1845
    ACanvas.Pen.Color := SavePen;
1846
  end
1847
  else
1848
  begin
1849
    SetLength(Cells, 6 * Length(Cubes));
1850
    for i := Low(Cubes) to High(Cubes) do
1851
      with Cubes[i] do
1852
      begin
1853
        with Cells[6 * i] do
1854
        begin
1855
          p := @p1; q := @p2;
1856
          r := @p3; s := @p4;
1857
        end;
1858
        with Cells[6 * i + 1] do
1859
        begin
1860
          p := @p1; q := @p2;
1861
          r := @p6; s := @p5;
1862
        end;
1863
        with Cells[6 * i + 2] do
1864
        begin
1865
          p := @p2; q := @p3;
1866
          r := @p7; s := @p6;
1867
        end;
1868
        with Cells[6 * i + 3] do
1869
        begin
1870
          p := @p3; q := @p4;
1871
          r := @p8; s := @p7;
1872
        end;
1873
        with Cells[6 * i + 4] do
1874
        begin
1875
          p := @p4; q := @p1;
1876
          r := @p5; s := @p8;
1877
        end;
1878
        with Cells[6 * i + 5] do
1879
        begin
1880
          p := @p5; q := @p6;
1881
          r := @p7; s := @p8;
1882
        end;
1883
        for j := 0 to 5 do
1884
        begin
1885
          Cells[6 * i + j].WireColor := @WireColor;
1886
          Cells[6 * i + j].FillColor := @FillColor;
1887
        end;
1888

1889
      end;
1890
    d3DrawSurfaceCells(ACanvas, Cells);
1891
  end;
1892
end;
1893

1894

1895
procedure TWorldDrawing.d3DrawColorSurface(ACanvas: TCanvas;
1896
  const SurfArray: array of Td3FloatPointArray;
1897
  Colors: array of TColorArray);
1898
var
1899
  i, j, imax, jmax: Integer;
1900
  SurfaceCells: array of TD3SurfaceCell;
1901
  Current: Integer;
1902
begin
1903
  imax := High(SurfArray);
1904
  jmax := High(SurfArray[0]);
1905
  //assume al{ TODO : Warning }l same length!!
1906
  SetLength(SurfaceCells, imax * jmax);
1907
  Current := 0;
1908
  fDefaultWireColor := ACanvas.Pen.Color;
1909
  for i := 0 to imax - 1 do
1910
    for j := 0 to jmax - 1 do
1911
    begin
1912
      SurfaceCells[Current].p := @SurfArray[i][j];
1913
      SurfaceCells[Current].q := @SurfArray[i + 1][j];
1914
      SurfaceCells[Current].r := @SurfArray[i + 1][j + 1];
1915
      SurfaceCells[Current].s := @SurfArray[i][j + 1];
1916
      SurfaceCells[Current].WireColor := @fDefaultWireColor;
1917
      SurfaceCells[Current].FillColor := @Colors[i][j];
1918
      inc(Current);
1919
    end;
1920
  d3DrawSurfaceCells(ACanvas, SurfaceCells);
1921
end;
1922

1923

1924

1925
procedure TWorldDrawing.DrawAxes(ACanvas: TCanvas; xLabel, yLabel: string;
1926
  AxesColor: TColor; Arrows: Boolean = True);
1927
var
1928
  xs, Ys, i, iStart, Ticks: Integer;
1929
  SavePen: TPen; SaveBrush: TBrush;
1930
  t: string;
1931
  iTemp, xTick, yTick, inv, log, invlog: MathFloat;
1932

1933
  function min(i, j: longint): longint;
1934
  begin
1935
    if i < j then Result := i else Result := j;
1936
  end;
1937

1938
begin
1939
  if d2Axes then
1940
  begin
1941
    SavePen := TPen.Create;
1942
    SaveBrush := TBrush.Create;
1943
    SavePen.assign(ACanvas.Pen);
1944
    SaveBrush.assign(ACanvas.Brush);
1945
    ACanvas.Brush.Style := bsClear;
1946
    ACanvas.Pen.Style := psSolid;
1947
    ACanvas.Pen.Width := 1;
1948
    ACanvas.Pen.Color := AxesColor;
1949
    DrawLine(ACanvas, x1Snap, y1Snap, x2Snap, y1Snap);
1950
    log := ln(10);
1951
    invlog := 1 / log;
1952
    iTemp := ln(0.125 * (fd2xw)) * invlog;
1953
    if iTemp >= 0 then
1954
      i := trunc(iTemp) else i := trunc(iTemp) - 1;
1955
    xTick := exp(i * log);
1956
    iTemp := invlog * ln(0.125 * (fd2yw));
1957
    if iTemp >= 0 then
1958
      i := trunc(iTemp) else i := trunc(iTemp) - 1;
1959
    yTick := exp(i * log);
1960
    inv := 1 / xTick;
1961
    if xTick > 0 then
1962
      if abs(fd2x1 * inv) < maxint then
1963
      begin
1964
        iStart := round(fd2x1 * inv);
1965
        while iStart * xTick < fd2x1 do inc(iStart);
1966
        i := iStart;
1967
        Ticks := round((fd2xw) * inv);
1968
        with ACanvas.Font do
1969
          Size := Size - 1;
1970
        if Ticks <= 2000 then
1971
          repeat
1972
            WorldToScreen(i * xTick, y1Snap, xs, Ys);
1973
            ACanvas.MoveTo(xs, Ys);
1974
            ACanvas.LineTo(xs, Ys + 4);
1975
            if (i - iStart) mod (Ticks div 4) = 0 then
1976
            begin
1977
              t := FloatToStrf(i * xTick, ffgeneral, 3, 3);
1978
              with ACanvas do
1979
              begin
1980
                TextOut(xs - (TextWIdth(t) div 2), Ys + 6, t);
1981
                MoveTo(xs, Ys);
1982
                LineTo(xs, Ys + 6);
1983
              end;
1984
            end;
1985
            inc(i)
1986
          until i * xTick > fd2x1 + fd2xw;
1987
        with ACanvas.Font do Size := Size + 1;
1988
      end;
1989
    WorldToScreen(x2Snap, y1Snap, xs, Ys);
1990
    if Arrows then
1991
    begin
1992
      ACanvas.MoveTo(xs - 6, Ys - 6);
1993
      ACanvas.LineTo(xs, Ys);
1994
      ACanvas.MoveTo(xs - 6, Ys + 6);
1995
      ACanvas.LineTo(xs, Ys);
1996
    end;
1997
    ACanvas.TextOut(fwidth - ACanvas.TextWIdth(xLabel) - 2, fHeight - ACanvas.TextHeight(xLabel) - 2, xLabel);
1998
    DrawLine(ACanvas, x1Snap, y1Snap, x1Snap, y2Snap);
1999
    inv := 1 / yTick;
2000
    if yTick > 0 then
2001
      if abs(fd2y1 * inv) < maxint then
2002
      begin
2003
        iStart := round(fd2y1 * inv);
2004
        while iStart * yTick < fd2y1 do inc(iStart);
2005
        i := iStart;
2006
        Ticks := round((fd2yw) * inv);
2007
        with ACanvas.Font do
2008
          Size := Size - 1;
2009
        if Ticks <= 2000 then
2010
          repeat
2011
            WorldToScreen(x1Snap, i * yTick, xs, Ys);
2012
            ACanvas.MoveTo(xs, Ys);
2013
            ACanvas.LineTo(xs - 4, Ys);
2014
            if (i - iStart) mod (Ticks div 4) = 0 then
2015
            begin
2016
              t := FloatToStrf(i * yTick, ffgeneral, 3, 3);
2017
              with ACanvas do
2018
              begin
2019
                TextOut(xs - TextWIdth(t) - 6, Ys - TextHeight(t) div 2, t);
2020
                MoveTo(xs, Ys);
2021
                LineTo(xs - 6, Ys);
2022
              end;
2023
            end;
2024
            inc(i);
2025
          until i * yTick > fd2y1 + fd2yw;
2026
        with ACanvas.Font do
2027
          Size := Size + 1;
2028
      end;
2029
    WorldToScreen(x1Snap, y2Snap, xs, Ys);
2030
    if Arrows then
2031
    begin
2032
      ACanvas.MoveTo(xs + 6, Ys + 6);
2033
      ACanvas.LineTo(xs, Ys);
2034
      ACanvas.MoveTo(xs - 6, Ys + 6);
2035
      ACanvas.LineTo(xs, Ys);
2036
    end;
2037
    ACanvas.TextOut(2, 2, yLabel);
2038
    ACanvas.Pen.assign(SavePen);
2039
    ACanvas.Brush.assign(SaveBrush);
2040
    SaveBrush.Free;
2041
    SavePen.Free;
2042
  end;
2043
end;
2044

2045
procedure TWorldDrawing.DrawZeroLines(ACanvas: TCanvas; AColor: TColor);
2046
var save: TColor;
2047
begin
2048
  save := ACanvas.Pen.Color;
2049
  ACanvas.Pen.Color := AColor;
2050
  DrawLine(ACanvas, 0, y1Snap, 0, y2Snap);
2051
  DrawLine(ACanvas, x1Snap, 0, x2Snap, 0);
2052
  ACanvas.Pen.Color := save;
2053
end;
2054

2055
procedure TWorldDrawing.DrawEllipse(ACanvas: TCanvas; x1, y1, x2,
2056
  y2: MathFloat);
2057
var x1s, Y1s, x2s, Y2s: Integer;
2058
begin
2059
  WorldToScreen(x1, y1, x1s, Y1s);
2060
  WorldToScreen(x2, y2, x2s, Y2s);
2061
  if Y1s < Y2s then
2062
    ACanvas.Ellipse(x1s, Y1s, x2s, Y2s)
2063
  else
2064
    ACanvas.Ellipse(x1s, Y2s, x2s, Y1s);
2065
end;
2066

2067

2068
procedure TWorldDrawing.DrawLevelCurves(ACanvas: TCanvas;
2069
  const SurfArray: array of Td3FloatPointArray; Level: MathFloat);
2070
var
2071
  Triangles: TD3TriangleArray;
2072
begin
2073
  GetTriangles(SurfArray, Triangles);
2074
  DrawLevelLines(ACanvas, Triangles, Level);
2075
end;
2076

2077
procedure TWorldDrawing.DrawLine(ACanvas: TCanvas; x1, y1, x2,
2078
  y2: MathFloat);
2079
var
2080
  pnts: array[0..2] of TPoint;
2081
begin
2082
 { pnts[0].x:=round(bx+ax*x1);
2083
  pnts[0].y:=round(by+ay*y1);
2084
  pnts[1].x:=round(bx+ax*x2);
2085
  pnts[1].y:=round(by+ay*y2);
2086
  pnts[2]:=pnts[0];}
2087
  WorldToScreen(x1, y1, pnts[0].x, pnts[0].y);
2088
  WorldToScreen(x2, y2, pnts[1].x, pnts[1].y);
2089
  pnts[2] := pnts[0];
2090
  ACanvas.Polyline(pnts);
2091
end;
2092

2093
procedure TWorldDrawing.DrawLineTo(ACanvas: TCanvas; x, y: MathFloat);
2094
var xs, Ys: Integer;
2095
begin
2096
  WorldToScreen(x, y, xs, Ys);
2097
  ACanvas.LineTo(xs, Ys);
2098
end;
2099

2100
procedure TWorldDrawing.DrawOneAxis(ACanvas: TCanvas; x1, y1, z1, x2, y2,
2101
  z2: MathFloat; Arrows: Boolean);
2102
var
2103
  Norms, wx, wy: MathFloat;
2104
  xs1, Ys1, xs2, Ys2: longint; vsx, vsy, inv: MathFloat;
2105
begin
2106
  d3DrawLine(ACanvas, x1, y1, z1, x2, y2, z2);
2107
  if Arrows then
2108
  begin
2109
    d3Window(x1, y1, z1, xs1, Ys1);
2110
    d3Window(x2, y2, z2, xs2, Ys2);
2111
    vsx := (xs2 - xs1); vsy := (Ys2 - Ys1);
2112
    Norms := sqrt(vsx * vsx + vsy * vsy);
2113
    if Norms > 0 then
2114
    begin
2115
      Norms := 1 / Norms;
2116
      vsx := vsx * Norms; vsy := vsy * Norms;
2117
      wx := (-vsx + vsy) / sqrt(2); wy := (-vsy - vsx) / sqrt(2);
2118
      ACanvas.MoveTo(xs2, Ys2);
2119
      ACanvas.LineTo(xs2 + round(8 * wx), Ys2 + round(8 * wy));
2120
      inv := 1 / sqrt(2);
2121
      wx := (-vsx - vsy) * inv; wy := (-vsy + vsx) * inv;
2122
      ACanvas.MoveTo(xs2, Ys2);
2123
      ACanvas.LineTo(xs2 + round(8 * wx), Ys2 + round(8 * wy));
2124
    end;
2125
  end;
2126
end;
2127

2128
procedure TWorldDrawing.DrawPoint(ACanvas: TCanvas; x, y: MathFloat);
2129
var xs, Ys: Integer;
2130
begin
2131
  WorldToScreen(x, y, xs, Ys);
2132
  ACanvas.Pixels[xs, Ys] := ACanvas.Pen.Color;
2133
end;
2134

2135
procedure TWorldDrawing.DrawPolygon(ACanvas: TCanvas;
2136
  const FloatPointArray: array of TFloatpoint; PointCount: Integer);
2137
var
2138
  i: Integer; p: array of TPoint;
2139
begin
2140
  //Do exception checking in TMathImage
2141
  SetLength(p, PointCount);
2142
  for i := 0 to PointCount - 1 do
2143
    Convert(FloatPointArray[i], p[i]);
2144
  ACanvas.Polygon(p);
2145
end;
2146

2147
procedure TWorldDrawing.DrawPolyline(ACanvas: TCanvas;
2148
  const FloatPointArray: array of TFloatpoint; PointCount: Integer);
2149
var
2150
  i: Integer; p: array of TPoint;
2151
begin
2152
  //Win95/98 GDI only accepts up to 16320 points in p.
2153
  SetLength(p, PointCount);
2154
  for i := 0 to PointCount - 1 do
2155
    Convert(FloatPointArray[i], p[i]);
2156
  ACanvas.Polyline(p);
2157
end;
2158

2159

2160

2161
procedure TWorldDrawing.DrawPolyPolyline(ACanvas: TCanvas;
2162
  const GraphList: array of TFloatPointArray);
2163
var i: Integer;
2164
begin
2165
  for i := Low(GraphList) to High(GraphList) do
2166
    DrawPolyline(ACanvas, GraphList[i], Length(GraphList[i]));
2167
end;
2168

2169
procedure TWorldDrawing.DrawRectangle(ACanvas: TCanvas; x1, y1, x2,
2170
  y2: MathFloat);
2171
var x1s, Y1s, x2s, Y2s: Integer;
2172
begin
2173
  WorldToScreen(x1, y1, x1s, Y1s);
2174
  WorldToScreen(x2, y2, x2s, Y2s);
2175
  ACanvas.Rectangle(x1s, Y2s, x2s, Y1s);
2176
end;
2177

2178
procedure TWorldDrawing.DrawVector(ACanvas: TCanvas; x, y, A,
2179
  b: MathFloat);
2180
var
2181
  aw, bw, xw, yw, u1, u2, v1, v2: Integer;
2182
  n: MathFloat;
2183
  pts: array[0..5] of TPoint;
2184
begin
2185
  WorldToScreen(A + x, b + y, v1, v2);
2186
  WorldToScreen(x, y, xw, yw);
2187
  pts[0] := Point(xw, yw);
2188
  pts[1] := Point(v1, v2);
2189
  aw := v1 - xw;
2190
  bw := v2 - yw;
2191
  n := Norm(bw - aw, aw + bw);
2192
  if n > 0 then
2193
  begin
2194
    n := 1 / n;
2195
    u1 := round(8.0 * (bw - aw) * n);
2196
    u2 := round(8.0 * (-bw - aw) * n);
2197
    pts[2] := Point(v1 + u1, v2 + u2);
2198
    pts[3] := pts[1];
2199
    u1 := round(8.0 * (-aw - bw) * n);
2200
    u2 := round(8.0 * (aw - bw) * n);
2201
    pts[4] := Point(v1 + u1, v2 + u2);
2202
    pts[5] := pts[3];
2203
    ACanvas.Polyline(pts);
2204
  end;
2205
end;
2206

2207

2208
procedure TWorldDrawing.MoveToPoint(ACanvas: TCanvas; x, y: MathFloat);
2209
var xs, Ys: Integer;
2210
begin
2211
  WorldToScreen(x, y, xs, Ys);
2212
  ACanvas.MoveTo(xs, Ys);
2213
end;
2214

2215
function TWorldDrawing.Norm(x, y: MathFloat): MathFloat;
2216
begin
2217
  Result := sqrt(sqr(x) + sqr(y));
2218
end;
2219

2220
procedure GetExpoMant(x: MathFloat; var A: Integer; var m: MathFloat);
2221
{Only works for x>0}
2222
var r: MathFloat;
2223
begin
2224
  r := ln(x) / ln(10);
2225
  if r >= 0 then
2226
    A := trunc(r)
2227
  else
2228
    A := trunc(r) - 1;
2229
  m := x * exp(-ln(10) * A);
2230
end;
2231

2232
function MaxTextWidth(ACanvas: TCanvas; xx1, xx2: MathFloat): Integer;
2233
var
2234
  iTemp, xTick, xTickInv: MathFloat;
2235
  i, iStart, Ticks, w: longint;
2236
begin
2237
  iTemp := ln(0.125 * abs(xx2 - xx1)) / ln(10);
2238
  if iTemp >= 0 then i := trunc(iTemp) else i := trunc(iTemp) - 1;
2239
  xTick := exp(i * ln(10));
2240
  xTickInv := 1 / xTick;
2241
  if (abs(xx1 * xTickInv) >= maxint) then
2242
  begin
2243
    Result := 0;
2244
    exit; //beyond range don't draw any ticks
2245
  end;
2246
  iStart := round(xx1 * xTickInv);
2247
  while iStart * xTick < xx1 do
2248
    inc(iStart);
2249
  Ticks := round((xx2 - xx1) * xTickInv);
2250
  ACanvas.Font.Size := ACanvas.Font.Size - 1;
2251
  w := ACanvas.TextWIdth(FloatToStrf(iStart * xTick, ffgeneral, 3, 3));
2252
  for i := 1 to 4 do
2253
    w := max(w, ACanvas.TextWIdth(FloatToStrf((iStart + i * (Ticks div 4)) *
2254
      xTick, ffgeneral, 3, 3)));
2255
  Result := w;
2256
  ACanvas.Font.Size := ACanvas.Font.Size + 1;
2257
end;
2258

2259
procedure TWorldDrawing.SetWorld(ACanvas: TCanvas; x1, y1, x2, y2: MathFloat);
2260
var
2261
  XPixelWidth, YPixelWidth, XPixelStart, YPixelstart: Integer;
2262
  ex, k1: Integer;
2263
  m: MathFloat;
2264

2265
begin
2266
  fd2x1 := x1; fd2xw := x2 - x1; fd2y1 := y1; fd2yw := y2 - y1;
2267
  if fd2Axes then
2268
  begin
2269
    fmaxxtw := MaxTextWidth(ACanvas, x1, x2);
2270
    fmaxytw := MaxTextWidth(ACanvas, y1, y2);
2271
    fmaxth := ACanvas.TextHeight('-1.234');
2272
    XPixelWidth := fwidth - 10 - fmaxxtw - fmaxytw;
2273
    YPixelWidth := fHeight - 3 * fmaxth - fmaxth div 2;
2274
    XPixelStart := 10 + fmaxytw;
2275
    YPixelstart := 2 * fmaxth - fmaxth div 8;
2276
  end else
2277
  begin
2278
    XPixelWidth := fwidth;
2279
    XPixelStart := 0;
2280
    YPixelWidth := fHeight;
2281
    YPixelstart := 0;
2282
  end;
2283
  m := (x2 - x1) / XPixelWidth;
2284
  GetExpoMant(m, ex, m);
2285
  ax := exp(-ln(10) * (ex - 3)) / round(1000 * m);
2286
  axinv := 1 / ax;
2287
  k1 := round(0.5 * (XPixelWidth - ax * (x1 + x2)));
2288
  bx := XPixelStart + k1;
2289
  m := (y2 - y1) / YPixelWidth;
2290
  GetExpoMant(m, ex, m);
2291
  ay := -exp(-ln(10) * (ex - 3)) / round(1000 * m);
2292
  ayinv := 1 / ay;
2293
  k1 := round(0.5 * (YPixelWidth + ay * (y1 + y2)));
2294
  by := fHeight - YPixelstart - k1;
2295
  x1Snap := WorldX(XPixelStart);
2296
  x2Snap := WorldX(XPixelStart + XPixelWidth);
2297
  y1Snap := WorldY(fHeight - YPixelstart);
2298
  y2Snap := WorldY(fHeight - YPixelstart - YPixelWidth);
2299
  if d2Axes then
2300
    fClipRect := Rect(XPixelStart + 1, fHeight - YPixelstart - YPixelWidth, XPixelStart + XPixelWidth + 1, fHeight - YPixelstart)
2301
  else
2302
    fClipRect := Rect(0, 0, fwidth, fHeight);
2303
end;
2304

2305

2306
function TWorldDrawing.WorldX(xs: Integer): MathFloat;
2307
begin
2308
  Result := (xs - bx) * axinv;
2309
end;
2310

2311
function TWorldDrawing.WorldY(Ys: Integer): MathFloat;
2312
begin
2313
  Result := (Ys - by) * ayinv;
2314
end;
2315

2316

2317

2318
procedure TWorldDrawing.d3SetScales(xScale, yScale, zScale: MathFloat);
2319
begin
2320
   //do exception handling in TMathImage
2321
  fd3xScale := xScale;
2322
  fd3yScale := yScale;
2323
  fd3zScale := zScale;
2324
  InitWorld;
2325
end;
2326

2327
procedure TWorldDrawing.d3SetViewPoint(vd, alpha, yr, zr: MathFloat);
2328
begin
2329
   //do exception handling in TMathImage
2330
  if vd > 0 then
2331
    fd3vd := vd;
2332
  if alpha > 0 then
2333
    if alpha < 180 then
2334
      fd3alpha := alpha;
2335
  if yr > -180 then if yr < 180 then
2336
      fd3yr := yr;
2337
  if zr > -180 then if zr < 180 then
2338
      fd3zr := zr;
2339
  InitWorld;
2340
end;
2341

2342
procedure TWorldDrawing.d3DrawLitCubes(ACanvas: TCanvas;
2343
  const Cubes: array of TCube; diffuse, focussed: MathFloat);
2344
var
2345
  Cells: array of TD3Triangle;
2346
  i, j: Integer;
2347
begin
2348
  SetLength(Cells, 12 * Length(Cubes));
2349
  for i := 0 to High(Cubes) do
2350
    with Cubes[i] do
2351
    begin
2352

2353
      with Cells[12 * i] do
2354
      begin
2355
        p := @p1; q := @p2;
2356
        r := @p3;
2357
      end;
2358
      with Cells[12 * i + 1] do
2359
      begin
2360
        p := @p1; q := @p3;
2361
        r := @p4;
2362
      end;
2363
      with Cells[12 * i + 2] do
2364
      begin
2365
        p := @p2; q := @p3;
2366
        r := @p6;
2367
      end;
2368
      with Cells[12 * i + 3] do
2369
      begin
2370
        p := @p3; q := @p6;
2371
        r := @p7;
2372
      end;
2373
      with Cells[12 * i + 4] do
2374
      begin
2375
        p := @p3; q := @p4;
2376
        r := @p8;
2377
      end;
2378
      with Cells[12 * i + 5] do
2379
      begin
2380
        p := @p3; q := @p8;
2381
        r := @p7;
2382
      end;
2383
      with Cells[12 * i + 6] do
2384
      begin
2385
        p := @p1; q := @p4;
2386
        r := @p8;
2387
      end;
2388
      with Cells[12 * i + 7] do
2389
      begin
2390
        p := @p1; q := @p8;
2391
        r := @p5;
2392
      end;
2393
      with Cells[12 * i + 8] do
2394
      begin
2395
        p := @p1; q := @p2;
2396
        r := @p5;
2397
      end;
2398
      with Cells[12 * i + 9] do
2399
      begin
2400
        p := @p2; q := @p5;
2401
        r := @p6;
2402
      end;
2403
      with Cells[12 * i + 10] do
2404
      begin
2405
        p := @p5; q := @p6;
2406
        r := @p8;
2407
      end;
2408
      with Cells[12 * i + 11] do
2409
      begin
2410
        p := @p6; q := @p8;
2411
        r := @p7;
2412
      end;
2413
      for j := 0 to 11 do
2414
      begin
2415
        Cells[12 * i + j].WireColor := @WireColor;
2416
        Cells[12 * i + j].FillColor := @FillColor;
2417
      end;
2418
    end;
2419
  d3DrawLitTriangles(ACanvas, Cells, diffuse, focussed);
2420
end;
2421

2422
procedure MakeCubes(var Cubes: array of TCube; const HeightArray: array of TFloatarray; const Colors: array of TColorArray; imax, jmax: Integer; PenColor: TColor);
2423
var
2424
  i, j, Current: Integer;
2425
begin
2426
  //This is just the start of trying something else.
2427
  //This heightmap stuff doesn't really work without
2428
  //more sophisticated hidden parts removal.
2429
  Current := 0;
2430
  for i := 0 to imax do
2431
    for j := 0 to jmax do
2432
    begin
2433
      Cubes[Current].x1 := i;
2434
      Cubes[Current].y1 := j;
2435
      Cubes[Current].z1 := 0;
2436
      Cubes[Current].x2 := i + 1;
2437
      Cubes[Current].y2 := j + 1;
2438
      Cubes[Current].z2 := HeightArray[i][j];
2439
      with Cubes[Current] do
2440
      begin
2441
        D3FloatPoint(x1, y1, z1, p1);
2442
        D3FloatPoint(x2, y1, z1, p2);
2443
        D3FloatPoint(x2, y2, z1, p3);
2444
        D3FloatPoint(x1, y2, z1, p4);
2445
        D3FloatPoint(x1, y1, z2, p5);
2446
        D3FloatPoint(x2, y1, z2, p6);
2447
        D3FloatPoint(x2, y2, z2, p7);
2448
        D3FloatPoint(x1, y2, z2, p8);
2449
      end;
2450
      Cubes[Current].FillColor := Colors[i][j];
2451
      Cubes[Current].WireColor := PenColor;
2452
      inc(Current);
2453
    end;
2454
end;
2455

2456

2457

2458
procedure TWorldDrawing.d3DrawHeightCubes(ACanvas: TCanvas;
2459
  const HeightArray: array of TFloatarray; const Colors: array of TColorArray);
2460
var
2461
  Cubes: array of TCube;
2462
  imax, jmax: Integer;
2463
begin
2464
  imax := High(HeightArray);
2465
  jmax := High(HeightArray[0]);
2466
  SetLength(Cubes, (imax + 1) * (jmax + 1));
2467
  MakeCubes(Cubes, HeightArray, Colors, imax, jmax, ACanvas.Pen.Color);
2468
  d3DrawCubes(ACanvas, Cubes, True);
2469
end;
2470

2471
procedure TWorldDrawing.d3DrawLitHeightCubes(ACanvas: TCanvas;
2472
  const HeightArray: array of TFloatarray; const Colors: array of TColorArray; diffuse, focussed: MathFloat);
2473
var
2474
  Cubes: array of TCube;
2475
  imax, jmax: Integer;
2476
begin
2477
  imax := High(HeightArray);
2478
  jmax := High(HeightArray[0]);
2479
  SetLength(Cubes, (imax + 1) * (jmax + 1));
2480
  MakeCubes(Cubes, HeightArray, Colors, imax, jmax, ACanvas.Pen.Color);
2481
  d3DrawLitCubes(ACanvas, Cubes, diffuse, focussed);
2482
end;
2483

2484

2485

2486
procedure TWorldDrawing.DrawCircle(ACanvas: TCanvas; xCenter,
2487
  yCenter: MathFloat; PixRadius: Integer);
2488
var xs, Ys: Integer;
2489
begin
2490
  WorldToScreen(xCenter, yCenter, xs, Ys);
2491
  ACanvas.Ellipse(xs - PixRadius, Ys - PixRadius, xs + PixRadius, Ys + PixRadius);
2492
end;
2493

2494
procedure TWorldDrawing.ResetWorld(ACanvas: TCanvas);
2495
begin
2496
  Setd2Axes(ACanvas, fd2Axes);
2497
end;
2498

2499
procedure TWorldDrawing.d3ResetWorld;
2500
begin
2501
  InitWorld;
2502
end;
2503

2504
(****************  Levels Stuff *******************)
2505

2506

2507
function TWorldDrawing.DoorInDoorOut(c, xp, yp, xq, yq,
2508
  xr, yr, p, q, r: MathFloat; var x1, y1, x2, y2: MathFloat): Boolean;
2509
{(xp,yp),(xq,yq),(xr,yr) are meshpoints of a triangular graph cell,
2510
p,q,r are the function values at the meshpoints, c is the z-level which we want to
2511
draw a level line for. If the result is true, there is a level line
2512
through the triangle. In this case (x1,y1) and (x2,y2) return the
2513
endpoints of the (straight) level line.}
2514

2515
var
2516
  doors: Integer;
2517
  doorx, doory: array[1..2] of MathFloat;
2518
  t: MathFloat;
2519
begin
2520
  Result := False;
2521
  if not (((q - c) * (p - c) <= 0) or ((r - c) * (q - c) <= 0)) then
2522
    exit; //testing 2 is enough
2523
  doors := 0;
2524
  if (q - c) * (p - c) <= 0 then
2525
  begin
2526
    if q = p then //q=p=c
2527
    begin
2528
      x1 := xp;
2529
      y1 := yp;
2530
      x2 := xq;
2531
      y2 := yq;
2532
      Result := True;
2533
      exit;
2534
    end;
2535
    inc(doors);
2536
    t := (c - p) / (q - p);
2537
    doorx[doors] := t * xq + (1 - t) * xp;
2538
    doory[doors] := t * yq + (1 - t) * yp;
2539
  end;
2540
  if (r - c) * (q - c) <= 0 then
2541
  begin
2542
    if q = r then //q=r=c
2543
    begin
2544
      x1 := xr;
2545
      y1 := yr;
2546
      x2 := xq;
2547
      y2 := yq;
2548
      Result := True;
2549
      exit;
2550
    end;
2551
    inc(doors);
2552
    t := (c - q) / (r - q);
2553
    doorx[doors] := t * xr + (1 - t) * xq;
2554
    doory[doors] := t * yr + (1 - t) * yq;
2555
  end;
2556
  if doors = 1 then
2557
  begin
2558
    if (p - c) * (r - c) <= 0 then
2559
    begin
2560
      if p = r then //p=r=c
2561
      begin
2562
        x1 := xr;
2563
        y1 := yr;
2564
        x2 := xp;
2565
        y2 := yp;
2566
        Result := True;
2567
        exit;
2568
      end;
2569
      inc(doors);
2570
      t := (c - r) / (p - r);
2571
      doorx[doors] := t * xp + (1 - t) * xr;
2572
      doory[doors] := t * yp + (1 - t) * yr;
2573
    end;
2574
  end;
2575
  if doors = 2 then
2576
  begin
2577
    Result := True;
2578
    x1 := doorx[1]; y1 := doory[1];
2579
    x2 := doorx[2]; y2 := doory[2];
2580
  end;
2581
end;
2582

2583

2584
function SplitTriangle(c: MathFloat; tr: TD3Triangle; var tr1, tr2, tr3:
2585
  TD3Triangle; var NewPoint1, NewPoint2: PD3FloatPoint): Boolean;
2586
var
2587
  t1, t2, xp, yp, p, xq, yq, q, xr, yr, r, x1, y1, x2, y2, epsilon: MathFloat;
2588
begin
2589
  Result := False;
2590
  epsilon := 1.0E-12;
2591
  if not (((c - tr.p.z) * (tr.q.z - c) > epsilon) or ((c - tr.p.z) * (tr.r.z - c) > epsilon)) then
2592
    exit; //testing 2 is enough
2593
  xp := tr.p.x; yp := tr.p.y; p := tr.p.z;
2594
  xq := tr.q.x; yq := tr.q.y; q := tr.q.z;
2595
  xr := tr.r.x; yr := tr.r.y; r := tr.r.z;
2596
  if (c - p) * (q - c) > 0 then //sign change p-q
2597
  begin
2598
    t1 := (c - q) / (p - q);
2599
    x1 := t1 * xp + (1 - t1) * xq;
2600
    y1 := t1 * yp + (1 - t1) * yq;
2601
    if (c - p) * (r - c) >= 0 then //sign change p-r
2602
    begin
2603
      if p = r then
2604
        exit;
2605
      t2 := (c - r) / (p - r);
2606
      x2 := t2 * xp + (1 - t2) * xr;
2607
      y2 := t2 * yp + (1 - t2) * yr;
2608
      Result := True;
2609
      tr1.p := tr.p;
2610
      New(NewPoint1);
2611
      NewPoint1.x := x1;
2612
      NewPoint1.y := y1;
2613
      NewPoint1.z := c;
2614
      New(NewPoint2);
2615
      NewPoint2.x := x2;
2616
      NewPoint2.y := y2;
2617
      NewPoint2.z := c;
2618
      tr1.q := NewPoint1;
2619
      tr1.r := NewPoint2;
2620
      tr2.p := tr.q;
2621
      tr2.q := NewPoint1;
2622
      tr2.r := NewPoint2;
2623
      tr3.p := tr.q;
2624
      tr3.q := tr.r;
2625
      tr3.r := NewPoint2;
2626
      tr1.FillColor := nil;
2627
      tr2.FillColor := nil;
2628
      tr3.FillColor := nil;
2629
    end
2630
    else //sign change must be q-r
2631
    begin
2632
      if r = q then
2633
        exit;
2634
      t2 := (c - r) / (q - r);
2635
      x2 := t2 * xq + (1 - t2) * xr;
2636
      y2 := t2 * yq + (1 - t2) * yr;
2637
      Result := True;
2638
      tr1.p := tr.q;
2639
      New(NewPoint1);
2640
      NewPoint1.x := x1;
2641
      NewPoint1.y := y1;
2642
      NewPoint1.z := c;
2643
      New(NewPoint2);
2644
      NewPoint2.x := x2;
2645
      NewPoint2.y := y2;
2646
      NewPoint2.z := c;
2647
      tr1.q := NewPoint1;
2648
      tr1.r := NewPoint2;
2649
      tr2.p := tr.p;
2650
      tr2.q := NewPoint1;
2651
      tr2.r := NewPoint2;
2652
      tr3.p := tr.p;
2653
      tr3.q := tr.r;
2654
      tr3.r := NewPoint2;
2655
      tr1.FillColor := nil;
2656
      tr2.FillColor := nil;
2657
      tr3.FillColor := nil;
2658
    end;
2659
  end
2660
  else
2661
  begin
2662
    if (c - p) * (r - c) > 0 then
2663
      //sign change p-r which implies sign change q-r
2664
    begin
2665
      if p = r then
2666
        exit;
2667
      t1 := (c - r) / (p - r);
2668
      x1 := t1 * xp + (1 - t1) * xr;
2669
      y1 := t1 * yp + (1 - t1) * yr;
2670
      if q = r then
2671
        exit;
2672
      if p = q then
2673
        exit;
2674
      t2 := (c - r) / (q - r);
2675
      x2 := t2 * xq + (1 - t2) * xr;
2676
      y2 := t2 * yq + (1 - t2) * yr;
2677
      Result := True;
2678
      New(NewPoint1);
2679
      NewPoint1.x := x1;
2680
      NewPoint1.y := y1;
2681
      NewPoint1.z := c;
2682
      New(NewPoint2);
2683
      NewPoint2.x := x2;
2684
      NewPoint2.y := y2;
2685
      NewPoint2.z := c;
2686
      tr1.p := tr.q;
2687
      tr1.q := NewPoint1;
2688
      tr1.r := NewPoint2;
2689
      tr2.p := tr.r;
2690
      tr2.q := NewPoint1;
2691
      tr2.r := NewPoint2;
2692
      tr3.p := tr.p;
2693
      tr3.q := tr.q;
2694
      tr3.r := NewPoint1;
2695
      tr1.FillColor := nil;
2696
      tr2.FillColor := nil;
2697
      tr3.FillColor := nil;
2698
    end
2699
    else
2700
    begin
2701
      //now sign change must be q-r, and c=p, so:
2702
      x1 := xp; y1 := yp;
2703
      t2 := (c - r) / (q - r);
2704
      x2 := t2 * xq + (1 - t2) * xr;
2705
      y2 := t2 * yq + (1 - t2) * yr;
2706
      Result := True;
2707
      New(NewPoint1);
2708
      NewPoint1.x := x1;
2709
      NewPoint1.y := y1;
2710
      NewPoint1.z := c;
2711
      New(NewPoint2);
2712
      NewPoint2.x := x2;
2713
      NewPoint2.y := y2;
2714
      NewPoint2.z := c;
2715
      tr1.p := tr.q;
2716
      tr1.q := NewPoint1;
2717
      tr1.r := NewPoint2;
2718
      tr2.p := tr.r;
2719
      tr2.q := NewPoint1;
2720
      tr2.r := NewPoint2;
2721
      tr3.p := tr.p;
2722
      tr3.q := tr.q;
2723
      tr3.r := NewPoint2;
2724
      //still need to come up with 3 triangles, though it splits in 2
2725
      tr1.FillColor := nil;
2726
      tr2.FillColor := nil;
2727
      tr3.FillColor := nil;
2728
    end;
2729
  end;
2730
end;
2731

2732

2733
procedure TWorldDrawing.DrawLevelLine(ACanvas: TCanvas;
2734
  Triangle: TD3Triangle; Level: MathFloat);
2735
var
2736
  x1, y1, x2, y2: MathFloat;
2737
begin
2738
  if DoorInDoorOut(Level, Triangle.p.x, Triangle.p.y, Triangle.q.x, Triangle.q.y, Triangle.r.x, Triangle.r.y, Triangle.p.z, Triangle.q.z, Triangle.r.z, x1, y1, x2, y2) then
2739
    DrawLine(ACanvas, x1, y1, x2, y2);
2740
end;
2741

2742
procedure TWorldDrawing.DrawLevelLines(ACanvas: TCanvas;
2743
  const Triangles: array of TD3Triangle; Level: MathFloat);
2744
var i: Integer;
2745
begin
2746
  for i := 0 to High(Triangles) do
2747
    DrawLevelLine(ACanvas, Triangles[i], Level);
2748
end;
2749

2750

2751
procedure TWorldDrawing.d3DrawLitLevelSurface(ACanvas: TCanvas;
2752
  const SurfArray: array of Td3FloatPointArray; const Levels: array of MathFloat;
2753
  const Colors: array of TColor; diffuse, focussed: MathFloat);
2754
var
2755
  i, j,
2756
    ColCount, SplitCount,
2757
    TriangleCount, NewPointCount,
2758
    TriangleLength, NewPointLength: Integer;
2759
  Level: MathFloat;
2760
  Triangles: TD3TriangleArray;
2761
  NewPoints: array of PD3FloatPoint;
2762
  NewPoint1, NewPoint2: PD3FloatPoint;
2763
  tr1, tr2, tr3: TD3Triangle;
2764
begin
2765
  ColCount := High(Colors);
2766
  if ColCount > High(Levels) then
2767
    ColCount := High(Levels);
2768
  GetTriangles(SurfArray, Triangles);
2769
  TriangleCount := Length(Triangles);
2770
  SetLength(Triangles, TriangleCount + 200);
2771
  TriangleLength := Length(Triangles);
2772
  SetLength(NewPoints, 200);
2773
  NewPointLength := 200;
2774
  NewPointCount := 0;
2775
  i := 0;
2776
  while i < TriangleCount do
2777
  begin
2778
    SplitCount := 0;
2779
    for j := 0 to ColCount do
2780
    begin
2781
      if SplitTriangle(Levels[j], Triangles[i], tr1, tr2, tr3, NewPoint1, NewPoint2) then
2782
      begin
2783
        inc(SplitCount);
2784
        if NewPointCount > NewPointLength - 2 then
2785
        begin
2786
          NewPointLength := NewPointLength + 100;
2787
          SetLength(NewPoints, NewPointLength);
2788
        end;
2789
        NewPoints[NewPointCount] := NewPoint1;
2790
        inc(NewPointCount);
2791
        NewPoints[NewPointCount] := NewPoint2;
2792
        inc(NewPointCount);
2793
        if TriangleCount > TriangleLength - 2 then
2794
        begin
2795
          TriangleLength := TriangleLength + 100;
2796
          SetLength(Triangles, TriangleLength);
2797
        end;
2798
        Triangles[i] := tr1;
2799
        Triangles[TriangleCount] := tr2;
2800
        inc(TriangleCount);
2801
        Triangles[TriangleCount] := tr3;
2802
        inc(TriangleCount);
2803
      end
2804
      else
2805
        if SplitCount > 0 then break;
2806
    end;
2807
    inc(i);
2808
  end;
2809
  for i := 0 to TriangleCount - 1 do
2810
    with Triangles[i] do
2811
    begin
2812
      Level := (p.z + q.z + r.z) / 3;
2813
      for j := 0 to ColCount - 1 do
2814
        if Levels[j] <= Level then
2815
          if Levels[j + 1] >= Level then
2816
          begin
2817
            FillColor := @Colors[j];
2818
            break;
2819
          end;
2820
      if Levels[ColCount] < Level then
2821
        FillColor := @Colors[ColCount];
2822
      if Levels[0] > Level then
2823
        FillColor := @Colors[0];
2824
    end;
2825
  SetLength(Triangles, TriangleCount);
2826
  d3DrawLitTriangles(ACanvas, Triangles, diffuse, focussed);
2827
  for i := 0 to NewPointCount - 1 do
2828
    dispose(NewPoints[i]);
2829
end;
2830

2831
procedure TWorldDrawing.DrawProjection(ACanvas: TCanvas;
2832
  Triangle: TD3Triangle);
2833
var
2834
  ptns: array[0..2] of TPoint;
2835
  p: TFloatpoint;
2836
begin
2837
  with Triangle.p^ do
2838
  begin
2839
    FloatPoint(x, y, p);
2840
    Convert(p, ptns[0]);
2841
  end;
2842
  with Triangle.q^ do
2843
  begin
2844
    FloatPoint(x, y, p);
2845
    Convert(p, ptns[1]);
2846
  end;
2847
  with Triangle.r^ do
2848
  begin
2849
    FloatPoint(x, y, p);
2850
    Convert(p, ptns[2]);
2851
  end;
2852
  if Triangle.FillColor <> nil then
2853
  begin
2854
    ACanvas.Brush.Color := Triangle.FillColor^;
2855
    ACanvas.Pen.Style := psCLear;
2856
    ACanvas.Polygon(ptns);
2857
  end;
2858
end;
2859

2860
procedure TWorldDrawing.DrawFilledLevelCurves(ACanvas: TCanvas;
2861
  const SurfArray: array of Td3FloatPointArray; const Levels: array of MathFloat;
2862
  const Colors: array of TColor);
2863
var
2864
  i, j,
2865
    ColCount, SplitCount,
2866
    TriangleCount, NewPointCount,
2867
    TriangleLength, NewPointLength: Integer;
2868
  Level: MathFloat;
2869
  Done: Boolean;
2870
  Triangles: TD3TriangleArray;
2871
  NewPoints: array of PD3FloatPoint;
2872
  NewPoint1, NewPoint2: PD3FloatPoint;
2873
  tr1, tr2, tr3: TD3Triangle;
2874
  SavePen: TPen;
2875
  SaveBrush: TBrush;
2876
begin
2877
  SavePen := TPen.Create;
2878
  SaveBrush := TBrush.Create;
2879
  SavePen.assign(ACanvas.Pen);
2880
  SaveBrush.assign(ACanvas.Brush);
2881
  ColCount := High(Colors);
2882
  if ColCount > High(Levels) then
2883
    ColCount := High(Levels);
2884
  GetTriangles(SurfArray, Triangles);
2885
  TriangleCount := Length(Triangles);
2886
  SetLength(Triangles, TriangleCount + 200);
2887
  TriangleLength := Length(Triangles);
2888
  SetLength(NewPoints, 200);
2889
  NewPointLength := 200;
2890
  NewPointCount := 0;
2891
  i := 0;
2892
  while i < TriangleCount do
2893
  begin
2894
    SplitCount := 0;
2895
    for j := 0 to ColCount do
2896
    begin
2897
      if SplitTriangle(Levels[j], Triangles[i], tr1, tr2, tr3, NewPoint1, NewPoint2) then
2898
      begin
2899
        inc(SplitCount);
2900
        if NewPointCount > NewPointLength - 2 then
2901
        begin
2902
          NewPointLength := NewPointLength + 100;
2903
          SetLength(NewPoints, NewPointLength);
2904
        end;
2905
        NewPoints[NewPointCount] := NewPoint1;
2906
        inc(NewPointCount);
2907
        NewPoints[NewPointCount] := NewPoint2;
2908
        inc(NewPointCount);
2909
        if TriangleCount > TriangleLength - 2 then
2910
        begin
2911
          TriangleLength := TriangleLength + 100;
2912
          SetLength(Triangles, TriangleLength);
2913
        end;
2914
        Triangles[i] := tr1;
2915
        Triangles[TriangleCount] := tr2;
2916
        inc(TriangleCount);
2917
        Triangles[TriangleCount] := tr3;
2918
        inc(TriangleCount);
2919
      end
2920
      else
2921
        if SplitCount > 0 then break;
2922
    end;
2923
    inc(i);
2924
  end;
2925
  for i := 0 to TriangleCount - 1 do
2926
    with Triangles[i] do
2927
    begin
2928
      Done := False;
2929
      Level := 0.33333333333 * (p.z + q.z + r.z);
2930
      for j := 0 to ColCount - 1 do
2931
      begin
2932
        if Levels[j] <= Level then
2933
          if Level <= Levels[j + 1] then
2934
          begin
2935
            FillColor := @Colors[j];
2936
            Done := True;
2937
            break;
2938
          end;
2939
      end;
2940
      if not Done then
2941
      begin
2942
        if Level >= Levels[ColCount] then
2943
          FillColor := @Colors[ColCount]
2944
        else
2945
          if Level <= Levels[0] then
2946
            FillColor := @Colors[0];
2947
      end;
2948
    end;
2949
  for i := 0 to TriangleCount - 1 do
2950
    DrawProjection(ACanvas, Triangles[i]);
2951
  for i := 0 to NewPointCount - 1 do
2952
    dispose(NewPoints[i]);
2953
  ACanvas.Pen.assign(SavePen);
2954
  ACanvas.Brush.assign(SaveBrush);
2955
  SavePen.Free;
2956
  SaveBrush.Free;
2957
end;
2958

2959
procedure TWorldDrawing.DrawProjections(ACanvas: TCanvas;
2960
  const Triangles: array of TD3Triangle);
2961
var
2962
  i: Integer;
2963
  SaveBrush: TBrush;
2964
  SavePen: TPen;
2965
begin
2966
  SaveBrush := TBrush.Create;
2967
  SavePen := TPen.Create;
2968
  SaveBrush.assign(ACanvas.Brush);
2969
  SavePen.assign(ACanvas.Pen);
2970
  for i := 0 to High(Triangles) do
2971
    DrawProjection(ACanvas, Triangles[i]);
2972
  ACanvas.Brush.assign(SaveBrush);
2973
  ACanvas.Pen.assign(SavePen);
2974
  SaveBrush.Free;
2975
  SavePen.Free;
2976
end;
2977

2978
//need to do some "range checking" for safety. It's too cumbersome
2979
  //for the user to check whether the floats are in a safe region
2980
  //for mapping. 22000 is roughly the number at which line drawing
2981
  //doesn't work anymore. Internal procedures are now Convert and
2982
  //WorldToScreen, for speed.
2983

2984
function TWorldDrawing.Windowx(x: MathFloat): longint;
2985
var Temp: MathFloat;
2986
begin
2987
  Temp := bx + ax * x;
2988
  if Temp < -22000 then Result := -22000 else if Temp > 22000 then
2989
    Result := 22000 else Result := round(Temp);
2990
end;
2991

2992
function TWorldDrawing.Windowy(y: MathFloat): longint;
2993
var Temp: MathFloat;
2994
begin
2995
  Temp := by + ay * y;
2996
  if Temp < -22000 then Result := -22000 else if Temp > 22000 then
2997
    Result := 22000 else Result := round(Temp);
2998
end;
2999

3000

3001

3002
procedure TWorldDrawing.Convert(const src: TFloatpoint; var dest: TPoint);
3003
var
3004
  Temp: MathFloat;
3005
begin
3006
  Temp := bx + ax * src.x;
3007
  if Temp < -22000 then dest.x := -22000 else if Temp > 22000 then
3008
    dest.x := 22000 else
3009
    dest.x := round(Temp);
3010
  Temp := by + ay * src.y;
3011
  if Temp < -22000 then dest.y := -22000 else if Temp > 22000 then
3012
    dest.y := 22000 else
3013
    dest.y := round(Temp);
3014
end;
3015

3016

3017
procedure TWorldDrawing.WorldToScreen(const x, y: MathFloat; var xs, Ys: Integer);
3018
var Temp: MathFloat;
3019
begin
3020
  Temp := bx + ax * x;
3021
  if Temp < -22000 then xs := -22000 else if Temp > 22000 then
3022
    xs := 22000 else xs := round(Temp);
3023
  Temp := by + ay * y;
3024
  if Temp < -22000 then Ys := -22000 else if Temp > 22000 then
3025
    Ys := 22000 else Ys := round(Temp);
3026
end;
3027

3028

3029
procedure TWorldDrawing.DrawLineSegments(ACanvas: TCanvas;
3030
  l: Td3LineSegmentArray);
3031
var i: Integer; savecolor: TColor;
3032
begin
3033
  savecolor := ACanvas.Pen.Color;
3034
  SortLineSegments(l);
3035
  for i := 0 to High(l) do
3036
  begin
3037
    ACanvas.Pen.Color := l[i].Color;
3038
    with l[i] do
3039
      d3DrawLine(ACanvas, p.x, p.y, p.z, q.x, q.y, q.z);
3040
  end;
3041
  ACanvas.Pen.Color := savecolor;
3042
end;
3043

3044
procedure TWorldDrawing.d3DrawBestAxes(ACanvas: TCanvas; xLabel, yLabel,
3045
  zLabel: string; xTicks, yTicks, zTicks: byte; Arrows: Boolean = True);
3046
begin
3047
  d3DrawBaseAxes(ACanvas, xLabel, yLabel, zLabel, xTicks, yTicks, zTicks,
3048
    fronty, basez, frontx, basez, frontx, basey, Arrows);
3049
end;
3050

3051
{ TLightSource }
3052

3053
function TLightSource.GetYRot: Integer;
3054
begin
3055
  Result := round(fyrot * 180 / pi);
3056
end;
3057

3058
function TLightSource.GetZRot: Integer;
3059
begin
3060
  Result := round(fzrot * 180 / pi);
3061
end;
3062

3063
procedure TLightSource.InitSourcePoint;
3064
begin
3065
  if not fFixed then
3066
    with fViewAngles do
3067
      D3FloatPoint(fdist * cos(x + fzrot) * sin(y + fyrot), fdist * sin(x + fzrot) * sin(y + fyrot),
3068
        fdist * cos(y + fyrot), fSourcePoint);
3069
end;
3070

3071
procedure TLightSource.SetDist(Value: MathFloat);
3072
begin
3073
  if Value > 0 then
3074
  begin
3075
    fdist := Value;
3076
    InitSourcePoint;
3077
  end;
3078
end;
3079

3080

3081
procedure TLightSource.SetViewAngles(Value: TFloatpoint);
3082
begin
3083
  fViewAngles := Value;
3084
  InitSourcePoint;
3085
end;
3086

3087
procedure TLightSource.SetYRot(Value: Integer);
3088
begin
3089
  if Value <= 90 then
3090
    if Value >= -90 then
3091
    begin
3092
      fyrot := 1 / 180 * pi * Value;
3093
      InitSourcePoint;
3094
    end;
3095
end;
3096

3097
procedure TLightSource.SetZRot(Value: Integer);
3098
begin
3099
  if Value <= 180 then
3100
    if Value >= -180 then
3101
    begin
3102
      fzrot := 1 / 180 * pi * Value;
3103
      InitSourcePoint;
3104
    end;
3105
end;
3106

3107
end.
3108

3109
MathgeomGLS

Использование cookies
