border tracing

{$loadlib pumbaa.dll}

const
  DELAY = 2500; // Delay for drawing detected border points.

procedure TPABorder(var TPA: TPointArray);
var
  a: TPointArray;
  b: TBox;
  w, h, c, l, i, o, n, x, y, z: Integer;
  m: T2DIntegerArray;
  d, s: TPoint;
  f: Boolean;
begin
  l := High(TPA);
  if (l > 0) then
  begin
    s := TPA[0];
    b := pp_Box(TPA[0].X, TPA[0].Y, TPA[0].X, TPA[0].Y);
    for i := 1 to l do
    begin
      if (TPA[i].Y < s.Y) then
        s := TPA[i]
      else
        if (TPA[i].Y = s.Y) then
          if (TPA[i].X < s.X) then
            s := TPA[i];
      if (TPA[i].X < b.X1) then
        b.X1 := TPA[i].X
      else
        if (TPA[i].X > b.X2) then
          b.X2 := TPA[i].X;
      if (TPA[i].Y < b.Y1) then
        b.Y1 := TPA[i].Y
      else
        if (TPA[i].Y > b.Y2) then
          b.Y2 := TPA[i].Y;
    end;
    w := ((b.X2 - b.X1) + 1);
    h := ((b.Y2 - b.Y1) + 1);
    pp_Create(-1, w, h, m);
    for i := 0 to l do
      m[(TPA[i].X - b.X1)][(TPA[i].Y - b.Y1)] := 0;
    SetLength(a, 8);
    a[0] := Point(-1, -1);
    a[1] := Point(0, -1);
    a[2] := Point(1, -1);
    a[3] := Point(1, 0);
    a[4] := Point(1, 1);
    a[5] := Point(0, 1);
    a[6] := Point(-1, 1);
    a[7] := Point(-1, 0);
    c := 5;
    f := False;
    m[(s.X - b.X1)][(s.Y - b.Y1)] := 1;
    TPA[0] := s;
    z := 1;
    repeat
      if (c > 3) then
        c := (c - 4)
      else
        c := (c + 4);
      for i := 0 to 7 do
      begin
        if (c < 7) then
          c := (c + 1)
        else
          c := 0;
        x := ((s.X + a[c].X) - b.X1);
        y := ((s.Y + a[c].Y) - b.Y1);
        if ((x > -1) and (y > -1) and (x < w) and (y < h)) then
          if (m[x][y] > -1) then
          begin
            f := (m[x][y] > 1);
            if not f then
            begin
              m[x][y] := (m[x][y] + 1);
              if (m[x][y] = 1) then
              begin
                TPA[z].X := (x + b.X1);
                TPA[z].Y := (y + b.Y1);
                z := (z + 1);
              end;
              s.X := (x + b.X1);
              s.Y := (y + b.Y1);
            end;
            Break;
          end;
      end;
    until f;
    SetLength(TPA, z);
  end;
end;

// V== CODE FOR GENERATING RANDOM SHAPE ==V

procedure TPALine(var TPA:TPointArray; P1, P2: TPoint);
var
  dx,dy,step,I,H: Integer;
  rx,ry,x,y: Extended;
begin
  H := Length(TPA);
  if (p1.x = p2.x) and (p2.y = p1.y) then
  begin
    SetLength(TPA, H+1);
    TPA[H] := P1;
    Exit;
  end;

  dx := (P2.x - P1.x);
  dy := (P2.y - P1.y);
  if (Abs(dx) > Abs(dy)) then step := Abs(dx)
  else step := Abs(dy);
  SetLength(TPA, (H+step+1));

  rx := dx / step;
  ry := dy / step;
  x := P1.x;
  y := P1.y;

  TPA[H] := Point(P1.x, P1.y);
  for I:=1 to step do
  begin
    x := x + rx;
    y := y + ry;
    TPA[(H+i)] := Point(Round(x),Round(y));
  end;
end;

function lines(TPA:TPointArray; Distance:Integer): TPointArray;
var
  i,h,x,y,lx,hx,ly,hy:Integer;
  Matrix:Array of TBoolArray;
  Area: TBox;
  pt:TPoint;

begin
  Area := GetTPABounds(TPA);
  Area.X2 := (Area.X2 - Area.X1) + 1;  //Width
  Area.Y2 := (Area.Y2 - Area.Y1) + 1;  //Height
  H := High(TPA);

  SetLength(Matrix, Area.Y2);
  for i:=0 to (Area.Y2-1) do
    SetLength(Matrix[i], Area.X2);

  for i:=0 to H do
    Matrix[(TPA[i].y-Area.Y1)][(TPA[i].x-Area.X1)] := True;

  for i:=0 to H do
  begin
    pt.x := TPA[i].x-Area.X1;
    pt.y := TPA[i].y-Area.Y1;
    if Matrix[pt.y][pt.x] = True then
    begin
      Matrix[pt.y][pt.x] := False;
      lx := Max(pt.x - Distance, 0);
      hx := Min(pt.x + Distance, Area.X2-1);
      ly := Max(pt.y - Distance, 0);
      hy := Min(pt.y + Distance, Area.Y2-1);
      for x:=lx to hx do
        for y:=ly to hy do
          if Matrix[y][x] = True then
            TPALine(Result, Point((pt.x+Area.X1),(pt.y+Area.y1)), point(x+Area.x1,y+Area.y1));
    end;
  end;
  SetLength(Matrix, 0);
end;

function RandomTPA(Amount:Integer; MinX,MinY,MaxX,MaxY:Integer): TPointArray;
var i:Integer;
begin
  SetLength(Result, Amount);
  for i:=0 to Amount-1 do
    Result[i] := Point(RandomRange(MinX, MaxX), RandomRange(MinY, MaxY));
end;

procedure SetPixels(bmp: Integer; TPA: TPointArray; color: Integer);
var
  a, z, w, h: Integer;
begin
  z := High(TPA);
  if (z > -1) then
  begin
    GetBitmapSize(bmp, w, h);
    for a := 0 to z do
      if ((TPA[a].X >= 0) and (TPA[a].Y >= 0) and (TPA[a].X < w) and (TPA[a].Y < h)) then
        FastSetPixel(bmp, TPA[a].X, TPA[a].Y, color);
  end;
end;

function BuildShape: TPointArray;
var
  shape: TPointArray;
begin
  shape := RandomTPA(50, 50,50, 250,250);
  Result := lines(shape, 100);
end;

// ^== CODE FOR GENERATING RANDOM SHAPE ==^

procedure Test;
var
  TPA: TPointArray;
  bmp, t, h, i: Integer;
begin
  ClearDebug;
  bmp := CreateBitmap(500, 500);
  DisplayDebugImgWindow(500, 500);
  TPA := BuildShape;
  DrawTPABitmap(bmp, TPA, 5367616);
  DrawBitmapDebugImg(bmp);
  t := GetSystemTime;
  TPABorder(TPA);
  WriteLn('TPABorder took ' + IntToStr(GetSystemTime - t) + ' ms.');
  h := High(TPA);
  Wait(DELAY);
  for i := 0 to h do
  begin
    Wait(0);
    FastSetPixel(bmp, TPA[i].X, TPA[i].Y, 255);
    DrawBitmapDebugImg(bmp);
  end;
end;

begin
  Test;
end.