unit dtriangulation;
//
//  Implements triangulation of any polygon.
//
//  The algorithm consists of three parts:
//    1. Event queue of sorted from left to right vertices (TTriangulationEventQue)
//    2. State of monotone polygons crossing sweep line (TTriangulationBinarySearch)
//    3. Triangulator of monotone polygons (TTriangulationSegment.Stack and OnTriangle)
//
//  The algorithm is greedy. It tries to build triangles as soon as possible.
//

{$MODE FPC}
{$MODESWITCH OUT}
{$MODESWITCH RESULT}

interface

uses
  dvector2f,
  dtriangulation_private;

type
PTriangulator = ^TTriangulator;
TTriangulator = object
public type
  PPoint = ^TPoint;
  TPoint = TTriangulationPoint; //record
  //  X, Y: Single;
  //  Data: Pointer;
  //end;
  TOnCross = procedure (Userdata: Pointer; P: PPoint);
      //  When new intersection detected.
  TOnTriangle = procedure (Userdata: Pointer; A, B, C: PPoint);
      //  When new triangle built.
public type
  PTemp = ^TTemp;
  TTemp = record
    Monotone: PTriangulationMonotone;
    Color: Cardinal;
    Up: array of PPoint;
    Down: array of PPoint;
  end;
public // Make private TODO
  FAllocator: TTriangulationAllocator;
  FEventQue: TTriangulationEventQue;
  FBinarySearch: TTriangulationBinarySearch;
  FUserdata: Pointer;
  FOnCross: TOnCross;
  FOnTriangle: TOnTriangle;
  // Data in client space
  FPoints: PVec2f;
  FCount: SizeUInt;
  // State -- make external structure later TODO
  Ev: PTriangulationEvent;
  FTemp: array of TTemp;
  function NewEdge(const A, B: PTriangulationPoint): PTriangulationEdge;
  procedure AddTempPoint(Monotone: PTriangulationMonotone; Point: PTriangulationPoint; Up: Boolean);
  procedure CloseTemp(Monotone: PTriangulationMonotone);
  procedure OnVertex(Monotone: PTriangulationMonotone; V: PTriangulationList);
  procedure OnFinish(Monotone: PTriangulationMonotone; V: PTriangulationList);
  procedure OnMonotoneUpdate(Monotone: PTriangulationMonotone);
  procedure OnMonotoneDone(Monotone: PTriangulationMonotone);
public
  procedure Init;
  procedure Done;
  procedure AddPoint(X, Y: Single; Data: Pointer);
  procedure AddPoints(Arr: Pointer; Count: SizeUInt);
  procedure AddPolygon(Arr: Pointer; Count: SizeUInt);
  procedure TriangulateStart;
  function TriangulateStep: Boolean;
  function Triangulate: Boolean;
  property Userdata: Pointer read FUserdata write FUserdata;
  property OnCross: TOnCross read FOnCross write FOnCross;
  property OnTriangle: TOnTriangle read FOnTriangle write FOnTriangle;
end;

implementation

procedure TTriangulator.Init;
begin
  FAllocator.Init;
  FEventQue.Init(@FAllocator);
  FBinarySearch.Init(@FAllocator);
  FBinarySearch.FQue := @FEventQue;
  FBinarySearch.OnMonotoneUpdate := @OnMonotoneUpdate;
  FBinarySearch.OnMonotoneDone := @OnMonotoneDone;
  FUserdata := nil;
  FOnCross := nil;
  FOnTriangle := nil;
  FPoints := nil;
  FCount := 0;
end;

procedure TTriangulator.Done;
begin
  FBinarySearch.Done;
  FEventQue.Done;
  FAllocator.Done;
end;

procedure TTriangulator.AddPoint(X, Y: Single; Data: Pointer);
begin
end;

procedure TTriangulator.AddPoints(Arr: Pointer; Count: SizeUInt);
begin
  FPoints := Arr;
  FCount := Count;
end;

function TTriangulator.NewEdge(const A, B: PTriangulationPoint): PTriangulationEdge;
begin
  Result := FAllocator.NewEdge;
  if A^.LessThan(B) then begin
    Result^.L := A;
    Result^.R := B;
  end else begin
    Result^.L := B;
    Result^.R := A;
  end;
end;

procedure TTriangulator.AddTempPoint(Monotone: PTriangulationMonotone; Point: PTriangulationPoint; Up: Boolean);
var
  T: PTemp;
  I: LongInt;
  Both: Boolean;
begin
  T := nil;
  for I := 0 to High(FTemp) do begin
    if FTemp[I].Monotone = Monotone then begin
      T := @FTemp[I];
      break;
    end;
  end;
  if T = nil then begin
    SetLength(FTemp, Length(FTemp) + 1);
    T := @FTemp[High(FTemp)];
  end;
  T^.Monotone := Monotone;
  T^.Color := 0;
  Both := (Length(T^.Up) = 0) and (Length(T^.Down) = 0);
  if Up or Both then begin
    SetLength(T^.Up, Length(T^.Up) + 1);
    T^.Up[High(T^.Up)] := Point;
  end;
  if (not Up) or Both then begin
    SetLength(T^.Down, Length(T^.Down) + 1);
    T^.Down[High(T^.Down)] := Point;
  end;
end;

procedure TTriangulator.CloseTemp(Monotone: PTriangulationMonotone);
var
  I: LongInt;
begin
  for I := 0 to High(FTemp) do
    if FTemp[I].Monotone = Monotone then
      FTemp[I].Monotone := nil;
end;

function Clockwise(A, B, C: PTriangulationPoint): Boolean; inline;
begin
  Result := (B^.Y - A^.Y) * (C^.X - B^.X) - (C^.Y - B^.Y) * (B^.X - A^.X) > 0;
end;

procedure TTriangulator.OnVertex(Monotone: PTriangulationMonotone; V: PTriangulationList);
var
  It, First, Current, Next: PTriangulationList;
begin
  It := Monotone^.Stack;
  if It = nil then begin
    Monotone^.Stack := V;
    V^.Next := nil;
    Exit;
  end;
  if V^.Up xor It^.Up then begin
    // Go wild
    First := It;
    Current := It;
    Next := Current^.Next;
    while Next <> nil do begin
      if FOnTriangle <> nil then
        FOnTriangle(FUserdata, Next^.P, Current^.P, V^.P);
      if First <> Current then
        FAllocator.FreeStack(Current);
      Current := Next;
      Next := Current^.Next;
    end;
    // Now push only two last points onto the stack
    First^.Next := nil;
    V^.Next := First;
    Monotone^.Stack := V;
    Exit;
  end;

  Current := It;
  Next := Current^.Next;
  while (Next <> nil) and (Clockwise(Next^.P, Current^.P, V^.P) xor V^.Up) do begin
    if FOnTriangle <> nil then
      FOnTriangle(FUserdata, Next^.P, Current^.P, V^.P);
    FAllocator.FreeStack(Current);
    Current := Next;
    Next := Current^.Next;
  end;
  V^.Next := Current;
  Monotone^.Stack := V;
end;

procedure TTriangulator.OnFinish(Monotone: PTriangulationMonotone; V: PTriangulationList);
var
  It: PTriangulationStack;
  Next: PTriangulationStack;
begin
  OnVertex(Monotone, V);
  It := Monotone^.Stack^.Next;
  if It = nil then
    Exit; // TODO free memory of remaining items in the stack
  Next := It^.Next;
  while Next <> nil do begin
    if FOnTriangle <> nil then
      FOnTriangle(FUserdata, Next^.P, It^.P, V^.P);
    FAllocator.FreeStack(It);
    It := Next;
    Next := It^.Next;
  end;
  Monotone^.Stack := nil;
end;

procedure TTriangulator.OnMonotoneUpdate(Monotone: PTriangulationMonotone);
var
  V: PTriangulationList;
begin
  V := Monotone^.PopUnprocessed;
  while V <> nil do begin
    // Debug
    AddTempPoint(Monotone, V^.P, V^.Up);

    OnVertex(Monotone, V);
    V := Monotone^.PopUnprocessed;
  end;
end;

procedure TTriangulator.OnMonotoneDone(Monotone: PTriangulationMonotone);
var
  V, VNext: PTriangulationList;
begin
  V := Monotone^.PopUnprocessed;
  while V <> nil do begin
    AddTempPoint(Monotone, V^.P, V^.Up);
    VNext := Monotone^.PopUnprocessed;
    if VNext = nil then begin
      AddTempPoint(Monotone, V^.P, not V^.Up);
    end;

    OnFinish(Monotone, V);

    V := VNext;
  end;
  CloseTemp(Monotone);
end;

procedure TTriangulator.AddPolygon(Arr: Pointer; Count: SizeUInt);
var
  I: LongInt;
  LastEdge, PrevEdge, CurEdge: PTriangulationEdge;
  LastPoint, FirstPoint, Current, Prev, Next: PTriangulationPoint;
  Points: PVec2f;
  PrevPrev: PTriangulationPoint;
begin
  Points := Arr;
  while (Count > 0) and (Points[0].X = Points[Count - 1].X) and (Points[0].Y = Points[Count - 1].Y) do
    Dec(Count);
  while (Count > 0) and (Points[Count - 2].X = Points[Count - 1].X) and (Points[Count - 2].Y = Points[Count - 1].Y) do
    Dec(Count);
  if Count < 3 then
    Exit;
  FirstPoint := FAllocator.NewPoint;
  FirstPoint^.X := Points[0].X;
  FirstPoint^.Y := Points[0].Y;
  FirstPoint^.Data := Points;
  LastPoint := FAllocator.NewPoint;
  LastPoint^.X := Points[Count - 1].X;
  LastPoint^.Y := Points[Count - 1].Y;
  LastPoint^.Data := Points + Count - 1;
  PrevPrev := nil;
  Prev := LastPoint;
  Current := FirstPoint;
  LastEdge := NewEdge(LastPoint, FirstPoint);
  PrevEdge := LastEdge;
  for I := 1 to Count - 2 do begin
    if (Current^.X = Points[I].X) and (Current^.Y = Points[I].Y) then
      continue;
    //if (Abs(Current^.X - Points[I].X) < 0.99) and
    //   (Abs(Current^.Y - Points[I].Y) < 0.99) then
    //  continue;
    //if (Abs(Current^.X - Points[I].X) < 2) and
    //   (Abs(Current^.Y - Points[I].Y) < 2) then
    //  continue;
    Next := FAllocator.NewPoint;
    Next^.X := Points[I].X;
    Next^.Y := Points[I].Y;
    Next^.Data := @Points[I];
    // TODO do the same for starting and endind points... >_<
    if (PrevPrev <> nil) and (PrevPrev^.X = Next^.X) and (PrevPrev^.Y = Next^.Y) then
      continue;
    PrevPrev := Prev;
    CurEdge := NewEdge(Current, Next);
    FEventQue.PushPoint(Current, Prev, Next, PrevEdge, CurEdge);
    Prev := Current;
    Current := Next;
    PrevEdge := CurEdge;
  end;
  // Last elements are tricky ones because we dont want to allocate them twice
  CurEdge := NewEdge(Current, LastPoint);
  FEventQue.PushPoint(Current, Prev, LastPoint, PrevEdge, CurEdge);
  FEventQue.PushPoint(LastPoint, Current, FirstPoint, CurEdge, LastEdge);
end;

procedure TTriangulator.TriangulateStart;
begin
  AddPolygon(FPoints, FCount);
  Ev := nil;
end;

function TTriangulator.TriangulateStep: Boolean;
var
  Edge: PTriangulationEdge;
  A, B, C: PTriangulationPoint;
begin
  //FBinarySearch.DumpChains;
  Ev := FEventQue.Pop;
  if Ev = nil then
    Exit(True);
  if Ev^._Type = EVENT_START then begin
    Writeln('START');
    FBinarySearch.StartChains(Ev);
  end else if Ev^._Type = EVENT_MIDDLE then begin
    Writeln('MIDDLE');
    FBinarySearch.ExtendChain(Ev);
  end else if Ev^._Type = EVENT_END then begin
    Writeln('FINISH');
    if not FBinarySearch.FinishChains(Ev) then
      Exit(False);
  end else if Ev^._Type = EVENT_CROSS then begin
    Writeln('CROSS');
    if not FBinarySearch.CrossChains(Ev) then
      Exit(False);
  end;
    if Ev <> nil then begin
      Write('EVENT ', Ev^._Type, ' P=', Ev^.P^.X:0:2, ',', Ev^.P^.Y:0:2, ' ',
            'E1=(', Ev^.E1^.L^.X:0:2, ',', Ev^.E1^.L^.Y:0:2, ',', Ev^.E1^.R^.X:0:2, ',', Ev^.E1^.R^.Y:0:2, ') ',
            'E2=(', Ev^.E2^.L^.X:0:2, ',', Ev^.E2^.L^.Y:0:2, ',', Ev^.E2^.R^.X:0:2, ',', Ev^.E2^.R^.Y:0:2, ') ');
      if (Ev^.E2^.L^.X = Ev^.E2^.R^.X) and (Ev^.E2^.L^.Y = Ev^.E2^.R^.Y) then
        Write('STRANGE');
      Writeln;
    end;
  Exit(True);
end;

function TTriangulator.Triangulate: Boolean;
begin
  TriangulateStart;
  repeat
    if not TriangulateStep then
      Exit(False);
    //if not FBinarySearch.CheckSorted then begin
    //  FBinarySearch.DumpChains;
    //  Exit(False);
    //end;
  until Ev = nil;
  Exit(True);
end;

end.
