MathgeomGLS

1
unit Vor.GraphObjects;
2
(*
3
  Graphical objects and modification routines as part of Voronoi algorithm
4
  of Christian Huettig Copyright (C) 2002
5
  Restrictions: None
6
*)
7
interface
8

9
uses
10
  System.Types,
11
  System.SysUtils,
12
  System.Classes,
13
  System.Math,
14
  Vcl.Dialogs,
15
  Vcl.Forms,
16
  Vcl.Graphics;
17

18
type
19
  TRGB = packed record // Variant record to mix colors fast
20
    case boolean of
21
      True:
22
        (Color: LongWord); // 32bit Color value (like TColor)
23
      False:
24
        (R, G, B, A: Byte); // 8bit RGBA split, alpha isn't used
25
  end;
26
  TGLineState = (TwoPoint, OnePoint, Vector);
27
  // |------|, |----->, <---|------|----> (Vector isn't the right name, its an endless line in both directions marked through two point)
28

29
  // Graphical Objects
30
  TGraphObject = class // Base object for all drawable elements + management
31
  private
32
    orig_index: integer;
33
    // Index of list at create time (movetolist and clonetolist don't change this index, only set on create
34
    index: integer; // Index of current list
35
    List: TList;
36
    // Current list, can only be changed through movetolist or clonetolist
37
    Canvas: TCanvas;
38
  protected
39
    constructor Create(L: TList; C: TCanvas);
40
  public
41
    Color: TRGB;
42
    aColor: TColor; // not Used
43
    procedure MoveToList(L: TList);
44
    procedure CopyToList(L: TList);
45
    // same as move, but now the object is on more than one list. careful, because index is left on old list !
46
    function CloneToList(L: TList): TGraphObject;
47
    // Creates a new object and moves it to L
48
    function GetIndex: integer;
49
    function GetOrigIndex: integer;
50
    // returns the index of the list were it was created
51
    procedure Delete(orig: boolean);
52
    // orig=true means that the object is in its "original" list. now reindexes also orig_index
53
    procedure SetCanvas(C: TCanvas);
54
    function GetCanvas: TCanvas;
55
    procedure ReIndex(orig: boolean); overload;
56
    // slow reindex by searching the list for "self"
57
    procedure ReIndex(orig: boolean; i: integer); overload;
58
    // fast reindex with validation
59
    procedure Draw; virtual; abstract;
60
    procedure Clear; virtual; abstract;
61
    function Clone: TGraphObject; virtual; abstract;
62
  end;
63

64
  TGPoint = class; // forward declaration
65

66
  TGLine = class(TGraphObject)
67
  private
68
    state: TGLineState; // see above
69
    d, dx, dy: extended; // d=distance, dx,dy=delta
70
    ix, iy, t, R: extended;
71
    // ex,ey=unity vector, ix,iy=crosspoint(set after Intersect), t,r=distances to ipoint
72
    procedure initialize; // evaluates all constants if line has changed
73
  public
74
    p1, p2: TGPoint;
75
    ex, ey: extended; // Unity vector of the line
76
    BisectorOf: array [1 .. 2] of integer;
77
    // The orig_index of the points from which this line is the bisector. -1 if none
78
    constructor Create(p1_, p2_: TGPoint; s: TGLineState; L: TList; C: TCanvas);
79
    function Clone: TGraphObject; override;
80
    procedure Draw; override;
81
    procedure Clear; override;
82
    function GetState: TGLineState;
83
    function Intersect(ln: TGLine): boolean;
84
    procedure GetCurrentIPoint(var x, y: extended); overload;
85
    // copies ix and iy. only valid after intersect() call !
86
    procedure GetCurrentIPoint(var p: TGPoint); overload;
87
    // copies ix and iy to a point. only valid after intersect() call !
88
    procedure CutRight(ln: TGLine); // Cuts the line right on ln
89
    procedure CutLeft(ln: TGLine);
90
    procedure CutBoth(ln: TGLine);
91
  end;
92

93
  TGPoint = class(TGraphObject)
94
  private
95
    x, y: extended;
96
  public
97
    closeDist: extended;
98
    // distance to point for MatchPoint=true (0=exact match)
99
    constructor Create(x_, y_: extended; L: TList; C: TCanvas);
100
    function Clone: TGraphObject; override;
101
    procedure Draw; override;
102
    procedure Clear; override;
103
    function getX: extended;
104
    function getY: extended;
105
    function DistanceTo(p: TGPoint): extended; overload;
106
    function DistanceTo(x_, y_: extended): extended; overload;
107
    procedure MoveTo(x_, y_: extended);
108
    function Match(p: TGPoint): boolean; overload;
109
    function Match(x_, y_: extended): boolean; overload;
110
    function Angle(p: TGPoint): extended;
111
    // required for the convex hull (preparata-hong)
112
    function IsRightTurn(p1, p2: TGPoint): boolean;
113
    // required for Graham scan (discarded, but left for further use)
114
    function areCollinear(A, B: TGPoint): boolean;
115
    function Bisector(p: TGPoint): TGLine;
116
    // Creates a line and sets BisectorOf[1..2]
117
    function CircleCenter(A, B: TGPoint): TGPoint; // never used
118
  end;
119

120
//==================================================
121
implementation
122
//==================================================
123

124
uses
125
  fVor2dPick;
126

127

128
//========================= TGraphObject =========================
129

130
constructor TGraphObject.Create(L: TList; C: TCanvas);
131
begin
132
  List := L;
133
  if List <> nil then
134
    index := L.Add(self);
135
  orig_index := index;
136
  Canvas := C;
137
end;
138

139
procedure TGraphObject.MoveToList(L: TList);
140
begin
141
  if List <> nil then
142
    List.items[index] := nil;
143
  index := L.Add(self);
144
  List := L;
145
end;
146

147
procedure TGraphObject.CopyToList(L: TList);
148
begin
149
  L.Add(self);
150
end;
151

152
function TGraphObject.CloneToList(L: TList): TGraphObject;
153
begin
154
  result := Clone;
155
  result.MoveToList(L);
156
end;
157

158
procedure TGraphObject.Delete;
159
var
160
  z: integer;
161
begin
162
  if List <> nil then
163
  begin
164
    List.Delete(index);
165
    List.pack;
166
    for z := 0 to List.count - 1 do
167
      TGraphObject(List.items[z]).ReIndex(orig);
168
  end;
169
  free;
170
end;
171

172
procedure TGraphObject.ReIndex(orig: boolean);
173
// slow reindex by searching List for "self"
174
begin
175
  index := List.IndexOf(self);
176
  if index < 0 then
177
    raise ERangeError.Create
178
      ('An object lost its bounding to a list ! (ReIndex call failed)');
179
  if orig then
180
    orig_index := index;
181
end;
182

183
procedure TGraphObject.ReIndex(orig: boolean; i: integer);
184
// fast reindex with validation
185
begin
186
  if List.items[i] <> self then
187
    raise ERangeError.Create
188
      ('An object lost its bounding to a list ! (ReIndex call failed)');
189
  index := i;
190
  if orig then
191
    orig_index := index;
192
end;
193

194
function TGraphObject.GetIndex: integer;
195
begin
196
  result := index;
197
end;
198

199
function TGraphObject.GetOrigIndex: integer;
200
begin
201
  result := orig_index;
202
end;
203

204
procedure TGraphObject.SetCanvas(C: TCanvas);
205
begin
206
  Canvas := C;
207
end;
208

209
function TGraphObject.GetCanvas: TCanvas;
210
begin
211
  result := Canvas;
212
end;
213

214
// ================== TGLine =======================
215

216
procedure TGLine.initialize;
217
begin
218
  dx := p2.getX - p1.getX;
219
  dy := p2.getY - p1.getY;
220
  d := sqrt(dx * dx + dy * dy);
221
  // m:=dy/dx;
222
  ex := dx / d;
223
  ey := dy / d;
224
end;
225

226
constructor TGLine.Create(p1_, p2_: TGPoint; s: TGLineState; L: TList;
227
  C: TCanvas);
228
begin
229
  p1 := p1_;
230
  p2 := p2_;
231
  BisectorOf[1] := -1;
232
  BisectorOf[2] := -1;
233

234
  state := s;
235
  inherited Create(L, C);
236
  Color.Color := $00FFFFFF;
237
  initialize;
238
end;
239

240
function TGLine.Clone: TGraphObject;
241
begin
242
  result := TGLine.Create(p1, p2, state, nil, GetCanvas);
243
  result.orig_index := GetOrigIndex;
244
  TGLine(result).BisectorOf[1] := BisectorOf[1];
245
  TGLine(result).BisectorOf[2] := BisectorOf[2];
246
end;
247

248
procedure TGLine.Draw;
249
var
250
  maxl: extended; // maximal line length possible in canvas, let canvas clip.
251
  p: TPoint; // needed to set locations in canvas
252
begin
253
  maxl := sqrt(sqr(GetCanvas.ClipRect.Right) + sqr(GetCanvas.ClipRect.Bottom));
254
  GetCanvas.Pen.Color := Color.Color;
255
  case state of
256
    TwoPoint:
257
      begin
258
        p.x := round(p1.getX);
259
        p.y := round(p1.getY);
260
        GetCanvas.PenPos := p;
261
        GetCanvas.LineTo(round(p2.getX), round(p2.getY));
262
      end;
263
    OnePoint:
264
      begin
265
        p.x := round(p1.getX);
266
        p.y := round(p1.getY);
267
        GetCanvas.PenPos := p;
268
        GetCanvas.LineTo(round(p1.getX + maxl * 2 * ex),
269
          round(p1.getY + maxl * 2 * ey));
270
      end;
271
    Vector:
272
      begin
273
        p.x := round(p1.getX - maxl * ex);
274
        p.y := round(p1.getY - maxl * ey);
275
        GetCanvas.PenPos := p;
276
        GetCanvas.LineTo(round(p1.getX + maxl * 2 * ex),
277
          round(p1.getY + maxl * 2 * ey));
278
      end;
279
  end;
280
end;
281

282
procedure TGLine.Clear;
283
begin
284
end;
285

286
function TGLine.GetState: TGLineState;
287
begin
288
  result := state;
289
end;
290

291
function TGLine.Intersect(ln: TGLine): boolean;
292
var
293
  ax, ay, divider: extended;
294
begin
295
  result := false;
296
  divider := ex * ln.ey - ey * ln.ex;
297
  if divider = 0 then
298
    exit; // paralell
299
  R := -(p1.getX * ey - p1.getY * ex + ex * ln.p1.getY - ey * ln.p1.getX)
300
    / divider;
301
  t := -(p1.getX * ln.ey - p1.getY * ln.ex - ln.p1.getX * ln.ey + ln.p1.getY *
302
    ln.ex) / divider;
303
  ax := p1.getX + t * ex;
304
  ay := p1.getY + t * ey;
305
  if (state = Vector) and (ln.state = Vector) then
306
    result := true;
307
  if (state = Vector) and (ln.state = OnePoint) then
308
    if R >= 0 then
309
      result := true;
310
  if (state = Vector) and (ln.state = TwoPoint) then
311
    if (R >= 0) and (R <= ln.d) then
312
      result := true;
313
  if (state = OnePoint) and (ln.state = Vector) then
314
    if (t >= 0) then
315
      result := true;
316
  if (state = OnePoint) and (ln.state = OnePoint) then
317
    if (t >= 0) and (R >= 0) then
318
      result := true;
319
  if (state = OnePoint) and (ln.state = TwoPoint) then
320
    if (t >= 0) and (R >= 0) and (R <= ln.d) then
321
      result := true;
322
  if (state = TwoPoint) and (ln.state = Vector) then
323
    if (t >= 0) and (t <= d) then
324
      result := true;
325
  if (state = TwoPoint) and (ln.state = OnePoint) then
326
    if (t >= 0) and (t <= d) and (R >= 0) then
327
      result := true;
328
  if (state = TwoPoint) and (ln.state = TwoPoint) then
329
    if (t >= 0) and (t <= d) and (R >= 0) and (R <= ln.d) then
330
      result := true;
331
  if result then
332
  begin
333
    ix := ax;
334
    iy := ay;
335
  end;
336
end;
337

338
procedure TGLine.GetCurrentIPoint(var x, y: extended);
339
// copies ix and iy. only valid after intersect() call !
340
begin
341
  x := ix;
342
  y := iy;
343
end;
344

345
procedure TGLine.GetCurrentIPoint(var p: TGPoint);
346
// copies ix and iy. only valid after intersect() call !
347
begin
348
  if assigned(p) then
349
    p.free;
350
  p := TGPoint.Create(ix, iy, nil, GetCanvas);
351
end;
352

353
procedure TGLine.CutRight(ln: TGLine);
354
begin
355
  if Intersect(ln) then
356
  begin
357
    if state = Vector then
358
    begin
359
      state := OnePoint;
360
      p1.MoveTo(ix, iy);
361
      if ex > 0 then
362
      begin
363
        ex := -ex;
364
        ey := -ey;
365
      end;
366
      p2.MoveTo(ix + ex, iy + ey);
367
    end
368
    else
369

370
      if state = OnePoint then
371
    begin
372
      if ex > 0 then
373
      begin
374
        state := TwoPoint;
375
        p2.MoveTo(ix, iy);
376
      end
377
      else
378
      begin
379
        // state unchanged ! stais OnePoint !!!
380
        p1.MoveTo(ix, iy);
381
        p2.MoveTo(ix + ex, iy + ey);
382
      end;
383
    end
384
    else
385

386
      if state = TwoPoint then
387
    begin
388
      state := TwoPoint;
389
      if ex > 0 then
390
      begin
391
        p2.MoveTo(ix, iy);
392
      end
393
      else
394
      begin
395
        p1.MoveTo(ix, iy);
396
      end;
397
    end;
398
    initialize;
399
  end;
400
end;
401

402
procedure TGLine.CutLeft(ln: TGLine);
403
begin
404
  if Intersect(ln) then
405
  begin
406
    if state = Vector then
407
    begin
408
      state := OnePoint;
409
      p1.MoveTo(ix, iy);
410
      if ex <= 0 then
411
      begin
412
        ex := -ex;
413
        ey := -ey;
414
      end;
415
      p2.MoveTo(ix + ex, iy + ey);
416
    end
417
    else if state = OnePoint then
418
    begin
419
      if ex <= 0 then
420
      begin
421
        state := TwoPoint;
422
        p2.MoveTo(ix, iy);
423
      end
424
      else
425
      begin
426
        // state unchanged ! stais OnePoint !!!
427
        p1.MoveTo(ix, iy);
428
        p2.MoveTo(ix + ex, iy + ey);
429
      end;
430
    end
431
    else if state = TwoPoint then
432
    begin
433
      if ex <= 0 then
434
      begin
435
        p2.MoveTo(ix, iy);
436
      end
437
      else
438
      begin
439
        p1.MoveTo(ix, iy);
440
      end;
441
    end;
442
    initialize;
443
  end;
444
end;
445

446
procedure TGLine.CutBoth(ln: TGLine); // caller line must be the one on top
447
var
448
  A, B: TGLine;
449
begin
450
  A := (Clone as TGLine);
451
  B := (ln.Clone as TGLine);
452
  if A.ey > 0 then
453
  begin
454
    A.ex := -A.ex;
455
    A.ey := -A.ey;
456
  end;
457

458
  if B.ey > 0 then
459
  begin
460
    B.ex := -B.ex;
461
    B.ey := -B.ey;
462
  end;
463

464
  if A.ex >= B.ex then
465
  begin
466
    if A.ex > 0 then
467
      CutRight(ln)
468
    else
469
      CutLeft(ln);
470
    if B.ex < 0 then
471
      ln.CutRight(A)
472
    else
473
      ln.CutLeft(A);
474
  end
475
  else
476
  begin
477
    if A.ex > 0 then
478
      CutRight(ln)
479
    else
480
      CutLeft(ln);
481
    if B.ex > 0 then
482
      ln.CutLeft(A)
483
    else
484
      ln.CutRight(A);
485
  end;
486
  A.free;
487
  B.free;
488
end;
489

490
// =========== TGPoint  ================================
491

492
constructor TGPoint.Create(x_, y_: extended; L: TList; C: TCanvas);
493
begin
494
  x := x_;
495
  y := y_;
496
  inherited Create(L, C);
497
  Color.Color := $00FFFFFF;
498
  closeDist := 2;
499
end;
500

501
// ------------------------------------------------------------------
502

503
function TGPoint.Clone: TGraphObject;
504
var
505
  A: TGPoint;
506
begin
507
  A := TGPoint.Create(x, y, nil, GetCanvas);
508
  A.orig_index := GetOrigIndex;
509
  result := A;
510
end;
511

512
procedure TGPoint.Draw;
513
begin
514
  GetCanvas.pixels[round(x), round(y)] := Color.Color;
515
end;
516

517
procedure TGPoint.Clear;
518
begin
519
end;
520

521
function TGPoint.getX: extended;
522
begin
523
  result := x;
524
end;
525

526
function TGPoint.getY: extended;
527
begin
528
  result := y;
529
end;
530

531
function TGPoint.DistanceTo(p: TGPoint): extended;
532
begin
533
  result := sqrt((p.x - x) * (p.x - x) + (p.y - y) * (p.y - y));
534
end;
535

536
function TGPoint.DistanceTo(x_, y_: extended): extended;
537
begin
538
  result := sqrt((x_ - x) * (x_ - x) + (y_ - y) * (y_ - y));
539
end;
540

541
procedure TGPoint.MoveTo(x_, y_: extended);
542
begin
543
  x := x_;
544
  y := y_;
545
end;
546

547
function TGPoint.Match(p: TGPoint): boolean;
548
begin
549
  result := (DistanceTo(p) <= closeDist);
550
end;
551

552
function TGPoint.Match(x_, y_: extended): boolean;
553
begin
554
  result := (DistanceTo(x_, y_) <= closeDist);
555
end;
556

557
function TGPoint.Angle(p: TGPoint): extended;
558
// required for building the convex hull
559
begin
560
  result := arcsin((p.x - x) / DistanceTo(p));
561
  if (p.x >= x) and (p.y >= y) then
562
  else if (p.x >= x) and (p.y < y) then
563
    result := pi - result
564
  else if (p.x < x) and (p.y >= y) then
565
    result := (pi + pi) + result
566
  else if (p.x < x) and (p.y < y) then
567
    result := pi - result;
568

569
end;
570

571
function TGPoint.IsRightTurn(p1, p2: TGPoint): boolean;
572
// required for Graham scan
573
var
574
  a1, a2: extended;
575
begin
576
  a1 := Angle(p1);
577
  a2 := Angle(p2);
578
  a1 := a1 - a2;
579
  if a1 < 0 then
580
    a1 := 2 * pi + a1;
581
  if a1 > pi then
582
    result := true
583
  else
584
    result := false;
585
end;
586

587
function TGPoint.areCollinear(A, B: TGPoint): boolean;
588
begin
589
  result := ((B.y - A.y) * (x - A.x) - (B.x - A.x) * (y - A.y)) = 0;
590
end;
591

592
function TGPoint.Bisector(p: TGPoint): TGLine;
593
var
594
  A: TGLine;
595
  sx, sy, dx, dy: extended;
596
begin
597
  sx := (x + p.x) / 2;
598
  sy := (y + p.y) / 2;
599
  dx := p.x - x;
600
  dy := p.y - y;
601
  A := TGLine.Create(TGPoint.Create(sx - dy, sy + dx, nil, nil),
602
    TGPoint.Create(sx + dy, sy - dx, nil, nil), Vector, nil, GetCanvas);
603
  A.BisectorOf[1] := GetOrigIndex;
604
  A.BisectorOf[2] := p.GetOrigIndex;
605
  result := A;
606
end;
607

608
// Got this one from the internet
609
function TGPoint.CircleCenter(A, B: TGPoint): TGPoint;
610
var
611
  u, v, den: extended;
612
begin
613
  u := ((A.x - B.x) * (A.x + B.x) + (A.y - B.y) * (A.y + B.y)) / 2.0;
614
  v := ((B.x - x) * (B.x + x) + (B.y - y) * (B.y + y)) / 2.0;
615
  den := (A.x - B.x) * (B.y - y) - (B.x - x) * (A.y - B.y);
616
  result := TGPoint.Create((u * (B.y - y) - v * (A.y - B.y)) / den,
617
    (v * (A.x - B.x) - u * (B.x - x)) / den, nil, GetCanvas);
618

619
end;
620

621
end.
622