Очень большой цикл, как оптимизировать?

[Marsel737]

Всем доброго времени суток. Вот такая вот процедура для определения площади двух пересекающихся фигур, сначала я проверяю пересекаются ли они и если пересекаются начинаю определять площадь и закрашивать ту часть площадь которой определяю. Работает очень долго, потому что площадь может доходить до 1000000, получается два цикла от 1 до 1000000

procedure TfrmMain.GetFigureSquare;
var
  I, J, K: integer;
  LinLength: integer;
  Crossing: boolean;
  CycleBreak: boolean;
begin
  FigSquare := 0;
  LinLength := 0;
  Crossing := false;
  CycleBreak := false;
  if (CoordK.X < CoordB.X) and ((CoordB.Y > CoordK.Y) or
    (CoordA.Y < CoordL.Y)) then
  begin
    Application.MessageBox(PChar('Фигуры не замкнуты'), PChar('Информация'),
      MB_OK + MB_ICONINFORMATION);
    edtFigSquare.Clear;
    Exit;
  end;
  
  { Проверка на пересечение фигур }
  for J := CoordA.Y + 1 to CoordB.Y - 2 do
  begin
    if CycleBreak then
      Break;
    for I := CoordA.X + 1 to CoordB.X - 2 do
    begin
      if imgCanvas.Canvas.Pixels[I, J] = clRed then
      begin
        Crossing := true;
        CycleBreak := true;
        Break;
      end;
    end;
  end;
  
  { Подсчёт пикселей }
  if Crossing then
  begin
    for J := CoordA.Y + 1 to CoordB.Y - 2 do
    begin
      FigSquare := FigSquare + LinLength;
      LinLength := 0;
      { Это можно пропустить
      if imgCanvas.Canvas.Pixels[CoordA.X + 1, J] = clRed then
      begin
        begin
          for K := J + 4 to CoordB.Y - 2 do
          begin
            if imgCanvas.Canvas.Pixels[CoordA.X + 1, K] = clRed then
            begin
              //
            end;
          end;  
        end;
        edtFigSquare.Text := IntToStr(FigSquare);
        Exit;
      end;
      }
      for I := CoordA.X + 1 to CoordB.X - 2 do
      begin
        Inc(LinLength);
        if imgCanvas.Canvas.Pixels[I, J] = clRed then
        begin
          Crossing := true;
          Break;
        end;
        imgCanvas.Canvas.Pixels[I, J] := $006BEB65;
      end;
    end;
    edtFigSquare.Text := IntToStr(FigSquare);
  end else
  begin
    Application.MessageBox(PChar('Фигуры не замкнуты'), PChar('Информация'),
      MB_OK + MB_ICONINFORMATION);
    edtFigSquare.Clear;
  end;
end;

Когда делаю так, вылазит ошибка First chance exception at $75C3B727. Exception class EStackOverflow with message 'Stack overflow'. Process LabWork.exe (2976)

procedure TfrmMain.GetFigureSquare;
const
  Max = 1000000;
var
  I, J, K: integer;
  LinLength: integer;
  PointCount: integer;
  Crossing: boolean;
  CycleBreak: boolean;
  Points: array[1..Max] of TPoint;
begin
  FigSquare := 0;
  LinLength := 0;
  PointCount := 0;
  Crossing := false;
  CycleBreak := false;
  if (CoordK.X < CoordB.X) and ((CoordB.Y > CoordK.Y) or
    (CoordA.Y < CoordL.Y)) then
  begin
    Application.MessageBox(PChar('Фигуры не замкнуты'), PChar('Информация'),
      MB_OK + MB_ICONINFORMATION);
    edtFigSquare.Clear;
    Exit;
  end;
  
  for J := CoordA.Y + 1 to CoordB.Y - 2 do
  begin
    FigSquare := FigSquare + LinLength;
    LinLength := 0;
    for I := CoordA.X + 1 to CoordB.X - 2 do
    begin
      Inc(LinLength);
      if imgCanvas.Canvas.Pixels[I, J] = clRed then
      begin
        Crossing := true;
        Break;
      end;
      Inc(PointCount);
      Points[PointCount] := Point(I, J);
    end;
  end;
  edtFigSquare.Text := IntToStr(FigSquare);
  for I := 1 to PointCount do
  begin
    imgCanvas.Canvas.Pixels[Points[I].X, Points[I].Y] := $006BEB65;
  end;
end;

[BOBAH13]

Расчеты выносятся в дочерние потоки.

[Marsel737]

Пнт, а конкретно по коду как оптимизировать? Почему во втором случае происходит переполнение стека?

[Stilet]

Извиняюсь, а что за условия задачи? Как фигуры заданы, ибо определять попиксельно это все равно что на гусеницах по брущатке камни считать.