sc

{$loadlib pumbaa.dll}

procedure pp_TPAControlSegment(var TPA: TPointArray; kind: TControlKind; segment: TPointArray; accuracy: Extended);
var
  w, h, k, l, i, j, x, y, v, c, t, n: Integer;
  o: TPoint;
  b, s, g: TBox;
  m, q: T2DBoolArray;
  f, p: TPointArray;
  z: TBoxArray;
  a: Extended;
begin
  t := 0;
  k := High(TPA);
  l := High(segment);
  if ((k > -1) and (l > -1) and (accuracy > 0) and not (accuracy > 100)) then
  begin
    s := pp_TPABounds(segment);
    b := pp_TPABounds(TPA);
    w := (b.X2 - b.X1);
    h := (b.Y2 - b.Y1);
    g := b;
    pp_BoxStretch(g, (s.X2 - s.X1), smRight);
    pp_BoxStretch(g, (s.Y2 - s.Y1), smDown);
    z := pp_BoxPositions(s, g);
    v := High(z);
    if (v > -1) then
    begin
      n := Ceil(pp_Percentage((accuracy * 100), (l + 1)));
      WriteLn('N: ' + IntToStr(n));
      p := pp_Clone(segment);
      o := pp_GetOffset(Point(s.X1, s.Y1), Point(0, 0));
      pp_TPAOffset(p, o);
      o := pp_GetOffset(Point(z[0].X1, z[0].Y1), Point(0, 0));
      pp_TBAOffset(z, o);
      m := pp_Create(False, ((b.X2 - b.X1) + 1), ((b.Y2 - b.Y1) + 1));
      for i := 0 to k do
        m[(TPA[i].X - b.X1)][(TPA[i].Y - b.Y1)] := True;
      SetLength(f, (l + 1));
      q := pp_Create(False, ((b.X2 - b.X1) + 1), ((b.Y2 - b.Y1) + 1));
      for i := 0 to v do
      begin
        c := 0;
        for j := 0 to l do
        begin
          x := (p[j].X + z[i].X1);
          y := (p[j].Y + z[i].Y1);
          if ((x < w) and (y < h)) then
            if m[x][y] then
            begin
              f[c].X := x;
              f[c].Y := y;
              c := (c + 1);
            end;
        end;
        if not (c < n) then
        begin
          c := (c - 1);
          for j := 0 to c do
            q[f[j].X][f[j].Y] := True;
        end;
      end;
      case kind of
        ckExtract:
        for i := 0 to k do
          if q[(TPA[i].X - b.X1)][(TPA[i].Y - b.Y1)] then
          begin
            TPA[t] := TPA[i];
            t := (t + 1);
          end;
        ckFilter:
        for i := 0 to k do
          if not q[(TPA[i].X - b.X1)][(TPA[i].Y - b.Y1)] then
          begin
            TPA[t] := TPA[i];
            t := (t + 1);
          end;
      end;
    end;
  end;
  SetLength(TPA, t);
end;

procedure DebugBitmap(bmp: Integer);
var
  w, h: Integer;
begin
  GetBitmapSize(bmp, w, h);
  DisplayDebugImgWindow(w, h);
  DrawBitmapDebugImg(bmp);
end;

var
  segment, TPA: TPointArray;
  b: TBox;
  o: TPoint;
  bmp, w, h: Integer;

begin
  segment := [Point(5, 2), Point(5, 2), Point(1, 6), Point(4, 3), Point(4, 1)];
  TPA := pp_TPAFromBox(IntToBox(10, 10, 20, 20));
  b := pp_TPABounds(TPA);
  pp_TPADimensions(TPA, w, h);
  pp_TPAControlSegment(TPA, ckExtract, segment, 0.9);
  bmp := CreateBitmap((w + (b.X1 * 2)), (h + (b.Y1 * 2)));
  DrawTPABitmap(bmp, TPA, 255);
  DrawTPABitmap(bmp, segment, 16777215);
  DebugBitmap(bmp);
  FreeBitmap(bmp);
end.