unit Unit8;
{
This software has been designed and it is
CopyLefted by Han de Bruijn:

                          (===)
                         @-O^O-@
                          #/_\#
                           ###

   MORE EFFICIENT DELAUNAY TRIANGULATION
   =====================================
}
INTERFACE

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ExtCtrls, Algemeen, Shamos, Grafisch, Voorlopig, Franco;
type
  TForm1 = class(TForm)
    Image1: TImage;
    procedure Toetsdruk(Sender: TObject; var Key: Char);
    procedure Scheppen(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

IMPLEMENTATION

{$R *.dfm}

type
  bijeen = record
    nr : integer;
    x,y : double;
  end;
var
  nodes : integer;
  rij : punten;
  keer : integer;
  klaar : boolean;
  info : boolean;
  nr,grens : integers;
  gedaan : array of boolean;
  vrij,nieuw : array of bijeen;
  klein : integer;
  rond : edges;

procedure Some_Help;
begin
  Writeln;
  writeln('Syntax: [program] [nodes]');
  Writeln(' nodes = # random points');
  Writeln(' Default # nodes = 10');
end;

procedure Read_Parameters;
var
  woord : string;
  OK : boolean;
  k : integer;
begin
  nodes := 10;
  if not (ParamCount = 1) then Some_Help;
  if ParamCount = 0 then Exit;
  woord := ParamStr(1);
  OK := true;
  for k := 1 to Length(woord) do
    if not (woord[k] in ['0'..'9']) then OK := false;
  if not OK then
  begin
    Some_Help; Halt;
  end;
  nodes := StrToInt(woord);
  if nodes < 3 then
  begin
    Writeln('# nodes must be > 2');
    Halt;
  end;
end;

function determinant(a,b,c : punt) : double;
begin
  determinant := (b.x-a.x)*(c.y-a.y)-(b.y-a.y)*(c.x-a.x);
end;

function gevonden(i,j,k : integer) : boolean;
{
  Circumscribed circle of (i,j,k)
  with no other points (L) inside
}
var
  L,n : integer;
  a,b,c,m : punt;
  RR,x,y : double;
  OK : boolean;
begin
  a := rij[i]; b := rij[j]; c := rij[k];
  if determinant(a,b,c) > 0 then OK := true else OK := false;
  if OK then
  begin
    omcirkel(a,b,c,m);
    RR := sqr(a.x-m.x)+sqr(a.y-m.y);
    for n := 0 to klein-1 do
    begin
      L := vrij[n].nr;
      if (L = i) or (L = j) or (L = k) then Continue;
      x := vrij[n].x; y := vrij[n].y;
      if sqr(x-m.x) + sqr(y-m.y) < RR then OK := false;
      if not OK then Break;
    end;
  end;
  gevonden := OK;
end;

procedure minder;
var
  k,N,i,j,t,nop : integer;
  OK : boolean;
  W : edge;
begin
  N := Length(rij);
  grens[0] := 0;
  for k := 1 to N do
  begin
    grens[k] := 0;
    for t := 0 to k-1 do
    begin
      grens[k] := grens[k] + nr[t];
    end;
  end;
  for k := 0 to N-1 do
  begin
    if gedaan[k] then Continue;
    OK := (nr[k] > 0);
    if OK then
    for t := grens[k] to grens[k+1]-1 do
    begin
      i := zijde[t].A; j := zijde[t].B;
      W.A := j; W.B := i;
      OK := OK and BinZoek(W,nop);
    end;
    gedaan[k] := OK;
  end;
end;

procedure krimpen;
var
  k,L,tel : integer;
begin
  tel := 0;
  for k := 0 to klein-1 do
  begin
    L := vrij[k].nr;
    if gedaan[L] then Continue;
    nieuw[tel] := vrij[k];
    tel := tel + 1;
  end;
  klein := tel;
  for k := 0 to klein-1 do
  begin
    vrij[k] := nieuw[k];
  end;
end;

function min(a,b,c : double) : double;
{
  Minimum of (a,b,c)
}
var
  m : double;
begin
  m := a;
  if b < a then m := b;
  if c < m then m := c;
  min := m;
end;

function binnen(a,b,c,p : punt) : boolean;
var
  det,xi,eta : double;
begin
  det := (b.x-a.x)*(c.y-a.y)-(c.x-a.x)*(b.y-a.y);
  xi := ((c.y-a.y)*(p.x-a.x)-(c.x-a.x)*(p.y-a.y))/det;
  eta := ((b.x-a.x)*(p.y-a.y)-(b.y-a.y)*(p.x-a.x))/det;
  binnen := min(xi,eta,1-xi-eta) > 0;
end;

procedure vanouds(var mesh : drietal);
var
  E,N,R,F,p,q,t : integer;
  i,j,k,L,m,tel : integer;
  V : edge;
  a,b,c : punt;
  OK : boolean;
  gereed : array of boolean;
begin
  N := Length(rij);
  E := Length(zijde);
  SetLength(gereed,E);
  for L := 0 to E-1 do
  begin
    gereed[L] := false;
  end;
{ R := 3*N - (E div 2) - 3; }
  R := Length(rond);
  F := 2*N-R-2;
  SetLength(mesh,F);

  for k := 0 to R-1 do
  begin
    BinZoek(rond[k],p);
    gereed[p] := true;
  end;

  tel := 0;
  for L := 0 to E-1 do
  begin
    if gereed[L] then Continue;
    i := zijde[L].A; j := zijde[L].B;
    gereed[L] := true;
    for m := grens[j] to grens[j+1]-1 do
    begin
      if gereed[m] then Continue;
      k := zijde[m].B;
      V.A := k; V.B := i;
      OK := BinZoek(V,p);
      if not OK then Continue;
      a := rij[i]; b := rij[j]; c := rij[k];
      OK := (determinant(a,b,c) > 0);
      if not OK then Continue;
      for t := 0 to N-1 do
      begin
        if (t = i) or (t = j) or (t = k) then Continue;
        OK := OK and (not binnen(a,b,c,rij[t]));
        if not OK then Break;
      end;
      if not OK then Continue;
      if info then
        Writeln(i:3,j:3,k:3);
      gereed[p] := true;
      V.A := j; V.B := k;
      BinZoek(V,q);
      gereed[q] := true;
      mesh[tel].A := i; mesh[tel].B := j; mesh[tel].C := k;
      tel := tel + 1;
      Break;
    end;
  end;
  Writeln(tel,' = ',F)
end;

procedure Delaunay;
{
  Delaunay Triangulation
  starting with Convex Hull
}
const
  d : integer = 2;
var
  N,R,E,maal,nop : integer;
  k,m,i,j,t,tel : integer;
  OK : boolean;
  a,b : punt;
  rand : drietal;
  ruimte : edges;
  V,W : edge;
  kleur : TColor;
  uit : string;
  nrs : integers;
  mesh : drietal;
begin
  Franco.convex_hull(rij,nrs);
  R := Length(nrs);
  SetLength(rand,R);
  SetLength(rond,R);
  rand[0].B := nrs[R-1];
  rand[0].A := nrs[0];
  for k := 1 to R-1 do
  begin
    rand[k].B := nrs[k-1];
    rand[k].A := nrs[k];
  end;
  for k := 0 to R-1 do
  begin
    rond[k].A := rand[k].A;
    rond[k].B := rand[k].B;
  end;
{ Shamos.convex_hull(rij,rand); }
  N := Length(rij);
  SetLength(nr,N);
  SetLength(grens,N+1);
  SetLength(gedaan,N);
  for k := 0 to N-1 do
  begin
    nr[k] := 0;
    gedaan[k] := false;
  end;
  R := Length(rand);
  E := 2*(3*N-R-3);
  SetLength(zijde,E);
  boven := 0;
  for k := 0 to E-1 do
  begin
    zijde[k].A := 0;
    zijde[k].B := 0;
    zijde[k].g := 0;
  end;
  Form1.Image1.Canvas.Pen.Color := clRed;
  Form1.Image1.Canvas.Pen.Width := 1;
  for k := 0 to R-1 do
  begin
    i := rand[k].A; j := rand[k].B;
    OK := invoegen(i,j);
    if OK then nr[i] := nr[i] + 1;
    a := rij[i]; b := rij[j];
    teken_zijde(a,b);
  end;
  klein := N;
  SetLength(vrij,klein);
  for k := 0 to N-1 do
  begin
    vrij[k].x := rij[k].x;
    vrij[k].y := rij[k].y;
    vrij[k].nr := k;
  end;
  SetLength(nieuw,klein);

  SetLength(ruimte,E);
  SetLength(rand,E);
  maal := 0;
  tel := R;
  while (boven < E) and (maal < keer) do
  begin
    t := 0;
    for k := 0 to tel-1 do
    begin
      j := rand[k].A; i := rand[k].B;
      OK := invoegen(i,j);
      if OK then nr[i] := nr[i] + 1;
      for m := 0 to N-1 do
      begin
        if (m = i) or (m = j) then Continue;
        if gedaan[m] then Continue;
        OK := gevonden(i,j,m);
        if not OK then Continue;
        ruimte[t].A := j; ruimte[t].B := m;
        t := t + 1;
        ruimte[t].A := m; ruimte[t].B := i;
        t := t + 1;
      end;
    end;
    for k := 0 to t-1 do
    begin
      i := ruimte[k].A; j := ruimte[k].B;
      OK := invoegen(i,j);
      if OK then nr[i] := nr[i] + 1;
    end;
    tel := 0;
    for k := 0 to boven-1 do
    begin
      V := zijde[k];
      W.A := V.B; W.B := V.A;
      if BinZoek(W,nop) then Continue;
      i := V.A; j := V.B;
      rand[tel].A := i; rand[tel].B := j;
      tel := tel + 1;
    end;
    minder; krimpen;
    maal := maal + 1;
  end;
  klaar := (boven = E);

  for k := 0 to boven-1 do
  begin
    V := zijde[k];
    W.A := V.B; W.B := V.A;
    with Form1.Image1.Canvas.Pen do
    if BinZoek(W,nop)
      then Color := clBlack else Color := clRed;
    i := V.A; j := V.B;
    a := rij[i]; b := rij[j];
    teken_zijde(a,b);
  end;
  for k := 0 to N-1 do
  begin
    if gedaan[k] then kleur := clBlack else kleur := clRed;
    Form1.Image1.Canvas.Pen.Color := kleur;
    Form1.Image1.Canvas.Brush.Color := kleur;
    i := x2i(rij[k].x); j := y2j(rij[k].y);
    Form1.Image1.Canvas.Ellipse(i-d,j-d,i+d,j+d);
    if info then
    begin
      uit := IntToStr(k);
      Form1.Image1.Canvas.Brush.Color := clWhite;
      Form1.Image1.Canvas.TextOut(x2i(rij[k].x),y2j(rij[k].y),uit);
    end;
  end;
  if klaar then vanouds(mesh);
end;

procedure opnieuw(N : integer);
{
  Calculate and Draw
}
var
  k : integer;
begin
{ Random points in the plane }
  SetLength(rij,N);
  for k := 0 to N-1 do
  begin
    rij[k].x := Random; rij[k].y := Random;
  end;
end;

procedure TForm1.Toetsdruk(Sender: TObject; var Key: Char);
{
  On KeyPress
}
var
  uit : string;
begin
  Tijdmeting('');
  ClearDevice;
  keer := keer + 1;
  if keer = 0 then Writeln;
  Delaunay;
  Tijdmeting('Duur');
  uit := IntToStr(keer);
  if Length(uit) = 1 then uit := '0'+uit;
  Form1.Image1.Picture.SaveToFile('Boris'+uit+'.bmp');
  if klaar then
  begin
    keer := -1; Opnieuw(nodes);
  end;
end;

procedure TForm1.Scheppen(Sender: TObject);
{
  At moment of creation
}
begin
  Tijdmeting('');
  Read_Parameters;
  xmin := -0.1; xmax := 1.1;
  ymin := -0.1; ymax := 1.1;
  TV(Form1.Image1);
  ClearDevice;
  Opnieuw(nodes);
  info := false;
  if nodes <= 25 then info := true;
  keer := 0;
  Delaunay;
  Tijdmeting('Duur');
  Form1.Image1.Picture.SaveToFile('Boris00.bmp');
end;

END.