unit dtriangulation_private;
//
//  Private part of the dtriangulation. Implements internal structures like
//  allocator, priority que etc.
//
//  Use it only if you understand how it works.
//

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

interface

const
  EVENT_START   = 0;
  EVENT_MIDDLE  = 1;
  EVENT_END     = 2;
  EVENT_CROSS   = 3;

type
PTriangulationEdge = ^TTriangulationEdge;

PTriangulationPoint = ^TTriangulationPoint;
TTriangulationPoint = record
  X, Y: Single;
  Data: Pointer;
  function LessThan(Other: PTriangulationPoint): Boolean;
  function GreaterThan(Other: PTriangulationPoint): Boolean;
end;

PTriangulationStack = ^TTriangulationStack;
TTriangulationStack = record
  P: PTriangulationPoint;
  Up: Boolean;
  Next: PTriangulationStack;
end;

PTriangulationList = PTriangulationStack;
TTriangulationList = TTriangulationStack;

PTriangulationMonotone = ^TTriangulationMonotone;
TTriangulationMonotone = record
  // Generated points of monotone polygons to be triangulated.
  // Use PopUnprocessed to pop
  Unprocessed: PTriangulationList;
  UnprocessedLast: PTriangulationList;
  // Should be used by final triangulation stage.
  Stack: PTriangulationStack;

  procedure PushUnprocessed(Item: PTriangulationList; P: PTriangulationPoint; Up: Boolean);
  function PopUnprocessed: PTriangulationList;
      // Returns nil if the Unprocessed list is empty.
      // Do not forget to free returned value.
end;

PTriangulationSegment = ^TTriangulationSegment;
TTriangulationSegment = record
      // Represents intermediate state of internal area between two edges.
  Up: PTriangulationEdge;
  Down: PTriangulationEdge;
  Monotone: PTriangulationMonotone;
  // Helper is the most right vertex to the left of sweep line such that
  // vertical segment connecting the vertex to Down lies inside polygon
  Helper: PTriangulationPoint;
  // Do we need to close HelperMonotone?
  HelperMerge: Boolean;
  // Only if HelperMerge is True
  HelperMonotone: PTriangulationMonotone;
end;

TTriangulationEdge = record
  L, R: PTriangulationPoint; // points in sorted order L < R
end;

PTriangulationEvent = ^TTriangulationEvent;
TTriangulationEvent = record
  _Type: Cardinal; // EVENT_* constants
  // EVENT_START: P=E1.L=E2.L < E1.R < E2.R
  // EVENT_MIDDLE: E1.L < E1.R=P=E2.L < E2.R
  // EVENT_END: E1.L < E2.L < E1.R=E2.R=P
  // EVENT_CROSS: P < E1.R, P < E2.R
  P: PTriangulationPoint;
  E1: PTriangulationEdge;
  E2: PTriangulationEdge;
  Next: PTriangulationEvent;
end;

PTriangulationAllocator = ^TTriangulationAllocator;
TTriangulationAllocator = object
      //  Implements effective memory allocation for specified types.
public
  procedure Init;
  procedure Done;
  function NewEvent: PTriangulationEvent;
  procedure FreeEvent(Event: PTriangulationEvent);
  function NewPoint: PTriangulationPoint;
  procedure FreePoint(P: PTriangulationPoint);
      //  In a single triangulation process points are allocated and never
      //  deallocated. Stack allocator is good choice for them.
  function NewEdge: PTriangulationEdge;
  procedure FreeEdge(E: PTriangulationEdge);
  function NewSegment: PTriangulationSegment;
  procedure FreeSegment(S: PTriangulationSegment);
  function NewStack: PTriangulationStack;
  procedure FreeStack(S: PTriangulationStack);
  function NewMonotone: PTriangulationMonotone;
  procedure FreeMonotone(M: PTriangulationMonotone);
end;

PTriangulationEventQue = ^TTriangulationEventQue;
TTriangulationEventQue = object
private
  FAllocator: PTriangulationAllocator;
  FPopped: PTriangulationEvent;
  FFirst: PTriangulationEvent;
public
  procedure Init(Allocator: PTriangulationAllocator);
  procedure Done;
  procedure Push(EventType: Cardinal;
                 P: PTriangulationPoint;
                 E1, E2: PTriangulationEdge);
      //  Pushs event to the que. It will be automaticly sorted.
  procedure PushPoint(P, P1, P2: PTriangulationPoint;
                      E1, E2: PTriangulationEdge);
      //  Pushs point to the que. Event type will be auto choosen.
  function Pop: PTriangulationEvent;
      //  Pops next event from the que. Returned event structure will be
      //  deallocated with next call to Pop.
end;

TOnMonotoneUpdate = procedure (Monotone: PTriangulationMonotone) of object;
TOnMonotoneDone = procedure (Monotone: PTriangulationMonotone) of object;

PTriangulationBinarySearch = ^TTriangulationBinarySearch;
TTriangulationBinarySearch = object
      // Holds and maintaince edges crossing by sweepline.
      // Generates sequence of vertices in Unprocessed list.
public // TODO make private
  FAllocator: PTriangulationAllocator;
  FSegments: array of PTriangulationSegment;
  FOnMonotoneUpdate: TOnMonotoneUpdate;
  FOnMonotoneDone: TOnMonotoneDone;
  FQue: PTriangulationEventQue;
public
  procedure Init(Allocator: PTriangulationAllocator);
  procedure Done;
  function FindIndex(X, Y: Single): LongInt;
      // Returns index I that is the following condition is True:
      //    FChains[I - 1] < (X, Y) < FChains[I]
      // (here we assume that (X, Y) is on the sweep line).
      // Returns 0 if there are not chains.
  function FindChainIndex(E1, E2: PTriangulationEdge): LongInt;
      // Returns -1 if the specified Chain was not found.
  procedure CloseMonotone(Monotone: PTriangulationMonotone;
                         Point: PTriangulationPoint;
                         Up: Boolean);
  procedure StartChains(Ev: PTriangulationEvent);
  function FinishChains(Ev: PTriangulationEvent): Boolean;
      // Returns True on success.
      // Returns False on internal error.
  function ExtendChain(Ev: PTriangulationEvent): Boolean;
      // Returns True if up is non-filled.
      // Returns False if down is non-filled.
  function CrossChains(Ev: PTriangulationEvent): Boolean;

  procedure CheckIntersections(E1, E2: PTriangulationEdge; I1, I2: LongInt);
  procedure CheckIntersectionsUp(E: PTriangulationEdge; Index: LongInt);
  procedure CheckIntersectionsDown(E: PTriangulationEdge; Index: LongInt);

  function CheckSorted: Boolean;
  procedure DumpEdge(E: PTriangulationEdge);
  procedure DumpChain(S: PTriangulationSegment);
  procedure DumpChains;

  property OnMonotoneUpdate: TOnMonotoneUpdate read FOnMonotoneUpdate write FOnMonotoneUpdate;
  property OnMonotoneDone: TOnMonotoneDone read FOnMonotoneDone write FOnMonotoneDone;
end;

implementation

function TTriangulationPoint.LessThan(Other: PTriangulationPoint): Boolean;
begin
  Result := (X < Other^.X) or ((X = Other^.X) and (Y < Other^.Y));
end;

function TTriangulationPoint.GreaterThan(Other: PTriangulationPoint): Boolean;
begin
  Result := (X > Other^.X) or ((X = Other^.X) and (Y > Other^.Y));
end;

function Cross2f(AX, AY, BX, BY: Single): Single; inline;
begin
  Exit(AX * BY - AY * BX);
end;

function Intersects(E1, E2: PTriangulationEdge; out P: TTriangulationPoint): Boolean;
var
  RS, T, U: Single;
begin
  Result := False;
  //if (E1^.R^.X = E2^.R^.X) and (E1^.R^.Y = E2^.R^.Y) then begin
  //  P := E1^.R^;
  //  Exit(True);
  //end;
  //if (E1^.L^.X = E2^.L^.X) and (E1^.L^.Y = E2^.L^.Y) then begin
  //  P := E1^.L^;
  //  Exit(True);
  //end;
  RS := Cross2f(E1^.R^.X - E1^.L^.X,
                E1^.R^.Y - E1^.L^.Y,
                E2^.R^.X - E2^.L^.X,
                E2^.R^.Y - E2^.L^.Y);
  if Abs(RS) < 0.000001 then
    Exit(False);
  T := Cross2f(E2^.L^.X - E1^.L^.X,
               E2^.L^.Y - E1^.L^.Y,
               E2^.R^.X - E2^.L^.X,
               E2^.R^.Y - E2^.L^.Y) / RS;
  if (T < 0) or (T >= 1) then
    Exit(False);
  U := Cross2f(E2^.L^.X - E1^.L^.X,
               E2^.L^.Y - E1^.L^.Y,
               E1^.R^.X - E1^.L^.X,
               E1^.R^.Y - E1^.L^.Y) / RS;
  if (U < 0) or (U >= 1) then
    Exit(False);
  P.X := E1^.L^.X + T * (E1^.R^.X - E1^.L^.X);
  P.Y := E1^.L^.Y + T * (E1^.R^.Y - E1^.L^.Y);
  Exit(True);
end;

procedure TTriangulationMonotone.PushUnprocessed(Item: PTriangulationList; P: PTriangulationPoint; Up: Boolean);
begin
  Item^.P := P;
  Item^.Up := Up;
  Item^.Next := nil;
  if UnprocessedLast <> nil then begin
    UnprocessedLast^.Next := Item;
  end else
    Unprocessed := Item;
  UnprocessedLast := Item;
end;

function TTriangulationMonotone.PopUnprocessed: PTriangulationList;
begin
  Result := Unprocessed;
  if Unprocessed <> nil then begin
    Unprocessed := Unprocessed^.Next;
    if Unprocessed = nil then
      UnprocessedLast := nil;
  end;
end;

procedure TTriangulationAllocator.Init;
begin
end;

procedure TTriangulationAllocator.Done;
begin
end;

function TTriangulationAllocator.NewEvent: PTriangulationEvent;
begin
  Result := GetMem(SizeOf(TTriangulationEvent));
end;

procedure TTriangulationAllocator.FreeEvent(Event: PTriangulationEvent);
begin
  FreeMem(Event);
end;

function TTriangulationAllocator.NewPoint: PTriangulationPoint;
begin
  Result := GetMem(SizeOf(TTriangulationPoint));
end;

procedure TTriangulationAllocator.FreePoint(P: PTriangulationPoint);
begin
  FreeMem(P);
end;

function TTriangulationAllocator.NewEdge: PTriangulationEdge;
begin
  Result := GetMem(SizeOf(TTriangulationEdge));
end;

procedure TTriangulationAllocator.FreeEdge(E: PTriangulationEdge);
begin
  FreeMem(E);
end;

function TTriangulationAllocator.NewSegment: PTriangulationSegment;
begin
  Result := GetMem(SizeOf(TTriangulationSegment));
end;

procedure TTriangulationAllocator.FreeSegment(S: PTriangulationSegment);
begin
  FreeMem(S);
end;

function TTriangulationAllocator.NewStack: PTriangulationStack;
begin
  Result := GetMem(SizeOf(TTriangulationStack));
end;

procedure TTriangulationAllocator.FreeStack(S: PTriangulationStack);
begin
  FreeMem(S);
end;

function TTriangulationAllocator.NewMonotone: PTriangulationMonotone;
begin
  Result := GetMem(SizeOf(TTriangulationMonotone));
end;

procedure TTriangulationAllocator.FreeMonotone(M: PTriangulationMonotone);
begin
  FreeMem(M);
end;

procedure TTriangulationEventQue.Init(Allocator: PTriangulationAllocator);
begin
  FAllocator := Allocator;
  FPopped := nil;
  FFirst := nil;
end;

procedure TTriangulationEventQue.Done;
begin
  // TODO deallocate all events
end;

procedure TTriangulationEventQue.Push(EventType: Cardinal;
               P: PTriangulationPoint;
               E1, E2: PTriangulationEdge);
var
  Event: PTriangulationEvent;
begin
  // Events with no point can never be compared to other points and can never
  // be returned by the priority que -- so they are effectivly non-existent
  // events.
  if P = nil then
    Exit;

  Event := FAllocator^.NewEvent;
  Event^._Type := EventType;
  Event^.P := P;
  Event^.E1 := E1;
  Event^.E2 := E2;
  Event^.Next := FFirst;
  FFirst := Event;
end;

procedure TTriangulationEventQue.PushPoint(P, P1, P2: PTriangulationPoint;
                                           E1, E2: PTriangulationEdge);
begin
  if P1^.GreaterThan(P) then begin
    if P2^.GreaterThan(P) then begin
      Push(EVENT_START, P, E1, E2);
    end else begin
      Push(EVENT_MIDDLE, P, E2, E1);
    end;
  end else begin
    if P2^.GreaterThan(P) then begin
      Push(EVENT_MIDDLE, P, E1, E2);
    end else begin
      Push(EVENT_END, P, E1, E2);
    end;
  end;
end;

function TTriangulationEventQue.Pop: PTriangulationEvent;
var
  Prev, It: PTriangulationEvent;
  PrevMin, ItMin: PTriangulationEvent;
begin
  if FPopped <> nil then
    FAllocator^.FreeEvent(FPopped);

  Prev := nil;
  It := FFirst;
  PrevMin := nil;
  ItMin := FFirst;
  while It <> nil do begin
    //if It^.P^.LessThan(ItMin^.P) then begin
    if ItMin^.P^.GreaterThan(It^.P) then begin
      //Writeln(Round(It^.P^.X), ',', Round(It^.P^.Y), '<', Round(ItMin^.P^.X), ',', Round(ItMin^.P^.Y));
      ItMin := It;
      PrevMin := Prev;
    end else begin
      ; //Writeln(Round(It^.P^.X), ',', Round(It^.P^.Y), '>', Round(ItMin^.P^.X), ',', Round(ItMin^.P^.Y));
    end;
    Prev := It;
    It := It^.Next;
  end;

  Result := ItMin;
  FPopped := Result;
  if Result <> nil then begin
    if PrevMin = nil then begin
      FFirst := Result^.Next;
    end else
      PrevMin^.Next := Result^.Next;
  end;
end;

procedure TTriangulationBinarySearch.Init(Allocator: PTriangulationAllocator);
begin
  FAllocator := Allocator;
end;

procedure TTriangulationBinarySearch.Done;
begin
end;

function IsUp(Edge: PTriangulationEdge; X, Y: Single): Boolean;
var
  NX, NY: Single;
begin
  // Counterclockwise normal
  NX := Edge^.R^.Y - Edge^.L^.Y;
  NY := Edge^.L^.X - Edge^.R^.X;
  Result := (X - Edge^.L^.X) * NX + (Y - Edge^.L^.Y) * NY > 0;
end;

function SortedEdges(A, B: PTriangulationEdge): Boolean;
begin
  Result := (not IsUp(A, B^.L^.X, B^.L^.Y)) or (not IsUp(A, B^.R^.X, B^.R^.Y));
end;

procedure ResortEdges(A, B: PTriangulationEdge;
                      out E1, E2: PTriangulationEdge);
begin
  if IsUp(A, B^.L^.X, B^.L^.Y) then begin
    E1 := B;
    E2 := A;
  end else begin
    E1 := A;
    E2 := B;
  end;
end;

procedure ResortEdgesR(A, B: PTriangulationEdge;
                       out E1, E2: PTriangulationEdge);
begin
  if IsUp(A, B^.R^.X, B^.R^.Y) then begin
    E1 := B;
    E2 := A;
  end else begin
    E1 := A;
    E2 := B;
  end;
end;

function TTriangulationBinarySearch.FindIndex(X, Y: Single): LongInt;
var
  I: LongInt;
begin
  if Length(FSegments) = 0 then
    Exit(0);
  for I := 0 to High(FSegments) do begin
    if IsUp(FSegments[I]^.Up, X, Y) then
      Exit(2 * I);
    if IsUp(FSegments[I]^.Down, X, Y) then
      Exit(2 * I + 1);
  end;
  Exit(Length(FSegments) * 2);
end;

function TTriangulationBinarySearch.FindChainIndex(E1, E2: PTriangulationEdge): LongInt;
var
  I: LongInt;
begin
  for I := 0 to High(FSegments) do begin
    if FSegments[I]^.Up = E1 then
      Exit(2 * I);
    if FSegments[I]^.Down = E1 then
      Exit(2 * I + 1);
  end;
  for I := 0 to High(FSegments) do begin
    if FSegments[I]^.Up = E2 then
      Exit(2 * I + 1);
    if FSegments[I]^.Down = E2 then
      Exit(2 * I);
  end;
  // Something is going wrong :(((((((
  Exit(-1);
end;

procedure TTriangulationBinarySearch.CloseMonotone(
                       Monotone: PTriangulationMonotone;
                       Point: PTriangulationPoint;
                       Up: Boolean);
begin
  Monotone^.PushUnprocessed(FAllocator^.NewStack, Point, Up);
  //FOnMonotoneUpdate(Monotone);
  FOnMonotoneDone(Monotone);
  FAllocator^.FreeMonotone(Monotone);
end;

procedure TTriangulationBinarySearch.StartChains(Ev: PTriangulationEvent);
var
  I, J: LongInt;
  E1, E2: PTriangulationEdge;
  M: PTriangulationSegment;
  Temp: PTriangulationMonotone;
begin
  ResortEdgesR(Ev^.E1, Ev^.E2, E1, E2);
  I := FindIndex(Ev^.P^.X, Ev^.P^.Y);
    Writeln(stderr, 'Index = ', I);
    Write('    E1=');
    DumpEdge(E1);
    Write('    E2=');
    DumpEdge(E2);
    DumpChains;
  //Writeln('FOUND INDEX ', I);
  Ev^.E1 := E1;
  Ev^.E2 := E2;
  SetLength(FSegments, Length(FSegments) + 1);
  for J := High(FSegments) downto I div 2 + 1 do begin
    FSegments[J] := FSegments[J - 1];
  end;
  M := FAllocator^.NewSegment;
  FSegments[I div 2] := M;
  M^.Monotone := FAllocator^.NewMonotone;
  M^.Monotone^.Unprocessed := nil;
  M^.Monotone^.UnprocessedLast := nil;
  M^.Monotone^.Stack := nil;
  if I mod 2 = 0 then begin
    M^.Up := E1;
    M^.Down := E2;
    M^.Monotone^.PushUnprocessed(FAllocator^.NewStack, Ev^.P, True);
  end else begin
    // SPLIT
    M^.Up := FSegments[I div 2 + 1]^.Up;
    M^.Down := E1;

    // AddDiagonal
    if FSegments[I div 2 + 1]^.Helper = FSegments[I div 2 + 1]^.Down^.L then begin
      Writeln('DIAGONAL');
      Writeln('DIAGONAL');
      Writeln('DIAGONAL');
      Writeln('DIAGONAL');
      Temp := M^.Monotone;
      M^.Monotone := FSegments[I div 2 + 1]^.Monotone;
      FSegments[I div 2 + 1]^.Monotone := Temp;
      M^.Monotone^.PushUnprocessed(FAllocator^.NewStack, Ev^.P, False);
      FSegments[I div 2 + 1]^.Monotone^.PushUnprocessed(FAllocator^.NewStack, FSegments[I div 2 + 1]^.Helper, True);
      FSegments[I div 2 + 1]^.Monotone^.PushUnprocessed(FAllocator^.NewStack, Ev^.P, True);
      FOnMonotoneUpdate(M^.Monotone);
      FOnMonotoneUpdate(FSegments[I div 2 + 1]^.Monotone);
    end else begin
      if FSegments[I div 2 + 1]^.HelperMerge then begin
        M^.Monotone := FSegments[I div 2 + 1]^.HelperMonotone;
        M^.Monotone^.PushUnprocessed(FAllocator^.NewStack, Ev^.P, False);
        FSegments[I div 2 + 1]^.Monotone^.PushUnprocessed(FAllocator^.NewStack, Ev^.P, True);
      end else begin
        Writeln('WE ARE HERE');
        Writeln('WE ARE HERE');
        Writeln('WE ARE HERE');
        Writeln('WE ARE HERE');
        {Temp := M^.Monotone;
        M^.Monotone := FSegments[I div 2 + 1]^.Monotone;
        FSegments[I div 2 + 1]^.Monotone := Temp;
        M^.Monotone^.PushUnprocessed(FAllocator^.NewStack, Ev^.P, False);
        FSegments[I div 2 + 1]^.Monotone^.PushUnprocessed(FAllocator^.NewStack, FSegments[I div 2 + 1]^.Helper, True);
        FSegments[I div 2 + 1]^.Monotone^.PushUnprocessed(FAllocator^.NewStack, Ev^.P, True);}
        M^.Monotone^.PushUnprocessed(FAllocator^.NewStack, FSegments[I div 2 + 1]^.Helper, False);
        M^.Monotone^.PushUnprocessed(FAllocator^.NewStack, Ev^.P, False);
        FSegments[I div 2 + 1]^.Monotone^.PushUnprocessed(FAllocator^.NewStack, Ev^.P, True);
      end;
      FOnMonotoneUpdate(M^.Monotone);
      FOnMonotoneUpdate(FSegments[I div 2 + 1]^.Monotone);
    end;

    FSegments[I div 2 + 1]^.Up := E2;
    FSegments[I div 2 + 1]^.Helper := Ev^.P;
    FSegments[I div 2 + 1]^.HelperMerge := False;
    FSegments[I div 2 + 1]^.HelperMonotone := nil;
  end;
  M^.Helper := Ev^.P;
  M^.HelperMerge := False;
  M^.HelperMonotone := nil;

  CheckIntersections(E1, E2, I - 1, I + 2);
end;

function TTriangulationBinarySearch.FinishChains(Ev: PTriangulationEvent): Boolean;
var
  I, J: LongInt;
  M1, M2: PTriangulationSegment;
  E1, E2: PTriangulationEdge;
begin
  ResortEdges(Ev^.E1, Ev^.E2, E1, E2);
  I := FindChainIndex(E1, E2);
  if I = -1 then begin
    Writeln(stderr, 'Failed FinishChains');
    Write('    E1=');
    DumpEdge(E1);
    Write('    E2=');
    DumpEdge(E2);
    DumpChains;
    Exit(False);
  end;

  M1 := FSegments[I div 2];
  if I mod 2 = 0 then begin
    // END
    if M1^.HelperMerge then
      CloseMonotone(M1^.HelperMonotone, Ev^.P, False);
    CloseMonotone(M1^.Monotone, Ev^.P, False);
  end else begin
    // MERGE
    if I div 2 + 1 > High(FSegments) then begin
      Writeln('FATAL ERROR: MERGE MODE OUT OF RANGE I=', I);
      Write('    E1=');
      DumpEdge(E1);
      Write('    E2=');
      DumpEdge(E2);
      DumpChains;
      Exit(False);
    end;
    M2 := FSegments[I div 2 + 1];
    if M1^.HelperMerge then begin
      CloseMonotone(M1^.Monotone, Ev^.P, False);
      M1^.Monotone := M1^.HelperMonotone;
    end;
    if M2^.HelperMerge then begin
      CloseMonotone(M2^.HelperMonotone, Ev^.P, True);
    end;
    M1^.Monotone^.PushUnprocessed(FAllocator^.NewStack, Ev^.P, False);
    M2^.Monotone^.PushUnprocessed(FAllocator^.NewStack, Ev^.P, True);
    FOnMonotoneUpdate(M1^.Monotone);
    FOnMonotoneUpdate(M2^.Monotone);
    M2^.Up := M1^.Up;
    M2^.Helper := Ev^.P;
    M2^.HelperMerge := True;
    M2^.HelperMonotone := M1^.Monotone;
  end;
  FAllocator^.FreeSegment(M1);
  for J := I div 2 to High(FSegments) - 1 do
    FSegments[J] := FSegments[J + 1];
  SetLength(FSegments, Length(FSegments) - 1);
  Exit(True);
end;

function TTriangulationBinarySearch.ExtendChain(Ev: PTriangulationEvent): Boolean;
var
  I, J: LongInt;
  M: PTriangulationSegment;
begin
  I := FindChainIndex(Ev^.E1, Ev^.E2);
  if I = -1 then
    Exit(False); // very bad :(((

  M := FSegments[I div 2];
  if I mod 2 = 0 then begin
    //if M^.HelperMerge then begin
    //  CloseMonotone(M^.Monotone, Ev^.P, False);
    //  M^.Monotone := M^.HelperMonotone;
    //end;
    if M^.HelperMerge then
      CloseMonotone(M^.HelperMonotone, Ev^.P, False);
    M^.Helper := Ev^.P;
    M^.HelperMerge := False;
    M^.HelperMonotone := nil;
    M^.Up := Ev^.E2;
    M^.Monotone^.PushUnprocessed(FAllocator^.NewStack, Ev^.P, True);
    FOnMonotoneUpdate(M^.Monotone);
  end else begin
    if M^.HelperMerge then begin
      CloseMonotone(M^.Monotone, Ev^.P, False);
      M^.Monotone := M^.HelperMonotone;
    end;
    //if M^.HelperMerge then
    //  CloseMonotone(M^.HelperMonotone, Ev^.P, False);
    M^.Down := Ev^.E2;
    M^.Helper := Ev^.P;
    M^.HelperMerge := False;
    M^.HelperMonotone := nil;
    M^.Monotone^.PushUnprocessed(FAllocator^.NewStack, Ev^.P, False);
    FOnMonotoneUpdate(M^.Monotone);
  end;

  CheckIntersectionsUp(Ev^.E2, I - 1);
  CheckIntersectionsDown(Ev^.E2, I + 1);

  Exit(I mod 2 = 0);
end;

function TTriangulationBinarySearch.CrossChains(Ev: PTriangulationEvent): Boolean;
var
  I, J: LongInt;
  M1, M2: PTriangulationSegment;
  E1, E2: PTriangulationEdge;
  Temp: PTriangulationEdge;
begin
  ResortEdges(Ev^.E1, Ev^.E2, E1, E2);
  I := FindChainIndex(E1, E2);
  if I = -1 then begin
    Writeln(stderr, 'Failed FinishChains');
    Write('    E1=');
    DumpEdge(E1);
    Write('    E2=');
    DumpEdge(E2);
    DumpChains;
    Exit(False);
  end;

  M1 := FSegments[I div 2];
  if I mod 2 = 0 then begin
    // END
    if M1^.HelperMerge then
      CloseMonotone(M1^.HelperMonotone, Ev^.P, False);
    CloseMonotone(M1^.Monotone, Ev^.P, False);
    // SWAP
    Temp := M1^.Up;
    M1^.Up := M1^.Down;
    M1^.Down := Temp;
    M1^.Helper := Ev^.P;
    M1^.HelperMerge := False;
    // TODO is it correct?
    M1^.Up^.L := Ev^.P;
    M1^.Down^.L := Ev^.P;

    M1^.Monotone := FAllocator^.NewMonotone;
    M1^.Monotone^.Unprocessed := nil;
    M1^.Monotone^.UnprocessedLast := nil;
    M1^.Monotone^.Stack := nil;
    M1^.Monotone^.PushUnprocessed(FAllocator^.NewStack, Ev^.P, True);
  end else begin
    // MERGE
    if I div 2 + 1 > High(FSegments) then begin
      Writeln('FATAL ERROR: MERGE MODE OUT OF RANGE I=', I);
      Write('    E1=');
      DumpEdge(E1);
      Write('    E2=');
      DumpEdge(E2);
      DumpChains;
      Exit(False);
    end;
    M2 := FSegments[I div 2 + 1];
    if M1^.HelperMerge then begin
      CloseMonotone(M1^.Monotone, Ev^.P, False);
      M1^.Monotone := M1^.HelperMonotone;
      //CloseMonotone(M1^.HelperMonotone, Ev^.P, False);
    end;
    if M2^.HelperMerge then begin
      CloseMonotone(M2^.HelperMonotone, Ev^.P, True);
      //CloseMonotone(M2^.Monotone, Ev^.P, True);
      //M2^.Monotone := M2^.HelperMonotone;
    end;
    M1^.Monotone^.PushUnprocessed(FAllocator^.NewStack, Ev^.P, False);
    M2^.Monotone^.PushUnprocessed(FAllocator^.NewStack, Ev^.P, True);
    FOnMonotoneUpdate(M1^.Monotone);
    FOnMonotoneUpdate(M2^.Monotone);
    Temp := M2^.Up;
    M2^.Up := M1^.Down;
    M1^.Down := Temp;
    // TODO is it correct?
    M1^.Down^.L := Ev^.P;
    M2^.Up^.L := Ev^.P;

    M1^.Helper := Ev^.P;
    M1^.HelperMerge := False;
    M2^.HelperMonotone := nil;
    M2^.Helper := Ev^.P;
    M2^.HelperMerge := False;
    M2^.HelperMonotone := nil;
  end;
  Exit(True);
end;

procedure TTriangulationBinarySearch.CheckIntersections(E1, E2: PTriangulationEdge; I1, I2: LongInt);
begin
  CheckIntersectionsUp(E1, I1);
  CheckIntersectionsUp(E2, I1);
  CheckIntersectionsDown(E1, I2);
  CheckIntersectionsDown(E2, I2);
end;

procedure TTriangulationBinarySearch.CheckIntersectionsUp(E: PTriangulationEdge; Index: LongInt);
var
  Point: TTriangulationPoint;
  P: PTriangulationPoint;
  J: LongInt;
begin
  J := Index;
  while J >= 0 do begin
    if J mod 2 = 0 then begin
      if Intersects(E, FSegments[J div 2]^.Up, Point) then begin
        Writeln('INTERSECTION');
        P := FAllocator^.NewPoint;
        P^ := Point;
        FQue^.Push(EVENT_CROSS, P, FSegments[J div 2]^.Up, E);
        //break;
      end;
    end else begin
      if Intersects(E, FSegments[J div 2]^.Down, Point) then begin
        Writeln('INTERSECTION');
        P := FAllocator^.NewPoint;
        P^ := Point;
        FQue^.Push(EVENT_CROSS, P, FSegments[J div 2]^.Down, E);
        //break;
      end;
    end;
    Dec(J);
  end;
end;

procedure TTriangulationBinarySearch.CheckIntersectionsDown(E: PTriangulationEdge; Index: LongInt);
var
  Point: TTriangulationPoint;
  P: PTriangulationPoint;
  J: LongInt;
begin
  J := Index;
  while J < 2 * Length(FSegments) do begin
    if J mod 2 = 0 then begin
      if Intersects(E, FSegments[J div 2]^.Up, Point) then begin
        Writeln('INTERSECTION');
        P := FAllocator^.NewPoint;
        P^ := Point;
        FQue^.Push(EVENT_CROSS, P, E, FSegments[J div 2]^.Up);
        //break;
      end;
    end else begin
      if Intersects(E, FSegments[J div 2]^.Down, Point) then begin
        Writeln('INTERSECTION');
        P := FAllocator^.NewPoint;
        P^ := Point;
        FQue^.Push(EVENT_CROSS, P, E, FSegments[J div 2]^.Down);
        //break;
      end;
    end;
    Inc(J);
  end;
end;

function TTriangulationBinarySearch.CheckSorted: Boolean;
var
  I: LongInt;
begin
  for I := 0 to High(FSegments) do begin
    if not SortedEdges(FSegments[I]^.Up, FSegments[I]^.Down) then
      Exit(False)
  end;
  for I := 0 to High(FSegments) - 1 do begin
    if not SortedEdges(FSegments[I]^.Down, FSegments[I + 1]^.Up) then
      Exit(False)
  end;
  Exit(True);
end;

procedure TTriangulationBinarySearch.DumpEdge(E: PTriangulationEdge);
begin
  Writeln(E^.L^.X:0:2, ', ', E^.L^.Y:0:2, ', ', E^.R^.X:0:2, ', ', E^.R^.Y:0:2);
end;

procedure TTriangulationBinarySearch.DumpChain(S: PTriangulationSegment);
begin
  Writeln('    ',
          'Up=(', S^.Up^.L^.X:0:2, ', ', S^.Up^.L^.Y:0:2, ', ', S^.Up^.R^.X:0:2, ', ', S^.Up^.R^.Y:0:2, ') ',
          'Down=(', S^.Down^.L^.X:0:2, ', ', S^.Down^.L^.Y:0:2, ', ', S^.Down^.R^.X:0:2, ', ', S^.Down^.R^.Y:0:2, ') '
         );
end;

procedure TTriangulationBinarySearch.DumpChains;
var
  I: LongInt;
  S: PTriangulationSegment;
begin
  Writeln('CURRENT CHAINS:');
  for I := 0 to High(FSegments) do begin
    S := FSegments[I];
    DumpChain(S);
  end;
end;

end.
