Janilabo

Untitled

Sep 13th, 2013
63
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
Pascal 3.82 KB | None | 0 0
  1. procedure ConvexHull(var TPA: TPointArray);
  2. var
  3.   p, Lower: TPointArray;
  4.   LH, H, I, UH, c, j, idx, x, y: Integer;
  5.   area: TBox;
  6.   m: array of TBoolArray;
  7.   b: Boolean;
  8. begin
  9.   h := High(TPA);
  10.   if (h > 0) then
  11.   begin
  12.     area := GetTPABounds(TPA);
  13.     SetLength(m, ((area.X2 - area.X1) + 1));
  14.     for i := 0 to (area.X2 - area.X1) do
  15.       SetLength(m[i], ((area.Y2 - area.Y1) + 1));
  16.     C := 0;
  17.     for i := 0 to h do
  18.     begin
  19.       x := (TPA[i].X - area.X1);
  20.       y := (TPA[i].Y - area.Y1);
  21.       if m[x][y] then
  22.         Continue;
  23.       m[x][y] := True;
  24.       Inc(C);
  25.     end;
  26.     SetLength(p, C);
  27.     idx := 0;
  28.     b := False;
  29.     for y := area.Y1 to area.Y2 do
  30.     begin
  31.       for x := area.X1 to area.X2 do
  32.         if m[(x - area.X1)][(y - area.Y1)] then
  33.         begin
  34.           p[idx] := Point(x, y);
  35.           Inc(idx);
  36.           b := (idx >= C);
  37.           if b then
  38.             Break;
  39.         end;
  40.       if b then
  41.         Break;
  42.     end;
  43.     h := High(p);
  44.     if (h > 0) then
  45.     begin
  46.       UH := 2;
  47.       SetLength(TPA, (h + 1));
  48.       TPA[0] := p[0];
  49.       TPA[1] := p[1];
  50.       for i := 2 to h do
  51.       begin
  52.         TPA[UH] := p[i];
  53.         Inc(UH);
  54.         while ((UH > 2) and not (((TPA[(UH - 2)].x * TPA[(UH - 1)].y + TPA[(UH - 3)].x * TPA[(UH - 2)].y + TPA[(UH - 1)].x * TPA[(UH - 3)].y) - (TPA[(UH - 2)].x * TPA[(UH - 3)].y + TPA[(UH - 1)].x * TPA[(UH - 2)].y + TPA[(UH - 3)].x * TPA[(UH - 1)].y)) < 0)) do
  55.         begin
  56.           Dec(UH);
  57.           TPA[(UH - 1)] := TPA[UH];
  58.         end;
  59.       end;
  60.       LH := 2;
  61.       SetLength(Lower, (h + 1));
  62.       Lower[0] := p[h];
  63.       Lower[1] := p[(h - 1)];
  64.       for i := 2 to h do
  65.       begin
  66.         Lower[LH] := p[(h - i)];
  67.         Inc(LH);
  68.         while ((LH > 2) and not (((Lower[(LH - 2)].x * Lower[(LH - 1)].y + Lower[(LH - 3)].x * Lower[(LH - 2)].y + Lower[(LH - 1)].x * Lower[(LH - 3)].y) - (Lower[(LH - 2)].x * Lower[(LH - 3)].y + Lower[(LH - 1)].x * Lower[(LH - 2)].y + Lower[(LH - 3)].x * Lower[(LH - 1)].y)) < 0)) do
  69.         begin
  70.           Dec(LH);
  71.           Lower[(LH - 1)] := Lower[LH];
  72.         end;
  73.       end;
  74.       Dec(LH);
  75.       SetLength(TPA, (UH + LH));
  76.       for i := UH to ((UH + LH) - 1) do
  77.         TPA[i] := Lower[(i - UH)];
  78.     end;
  79.   end;
  80. end;
  81.  
  82. function SamePoints(P1, P2:TPoint):Boolean;
  83. begin
  84.   Result := False;
  85.   if ((P1.x = P2.x) and (P1.y = P2.y)) then
  86.     Result := True;
  87. end;
  88.  
  89. { Given a TPA - This function will connect each point, from first to last }
  90. function ConnectPts(Pts:TPointArray):TPointArray;
  91. var
  92.   i,j,h,l,rl,a: Integer;
  93.   f,t:TPoint;
  94.   AdivL: Extended;
  95. begin
  96.   h := high(pts);
  97.   for i:=0 to h do
  98.   begin
  99.     j := i+1;
  100.     if i=h then
  101.       j:=0;
  102.     f := pts[i];
  103.     t := pts[j];
  104.     rl := length(Result);
  105.     if not(SamePoints(f, t)) then
  106.     begin
  107.       l := Max(Round(Abs(f.X - t.X)), Round(Abs(f.Y - t.Y)));
  108.       SetLength(Result, rl+l+1);
  109.       for a := 0 to l do begin
  110.         AdivL := a / Extended(l);
  111.         Result[rl+a] := Point(f.X + Round((t.X - f.X) * AdivL), f.Y + Round((t.Y - f.Y) * AdivL));
  112.       end;
  113.     end
  114.     else
  115.     begin
  116.       SetLength(Result,rl + 1);
  117.       Result[rl] := f
  118.     end;
  119.   end;
  120. end;
  121.  
  122. function RandomTPA(Amount:Integer; MinX,MinY,MaxX,MaxY:Integer): TPointArray;
  123. var i:Integer;
  124. begin
  125.   SetLength(Result, Amount+1);
  126.   for i:=0 to Amount do
  127.   begin
  128.     Result[i] := Point(RandomRange(MinX, MaxX), RandomRange(MinY, MaxY));
  129.   end;
  130. end;
  131.  
  132. //******* Plot a few shapes using this algorithm *******//
  133. var
  134.   TPA,CTPA: TPointArray;
  135.   bmp: Integer;
  136. begin
  137.   bmp := CreateBitmap(700, 700);
  138.  
  139.   TPA := TPAFromCircle(350, 350, 150);
  140.   CTPA := CopyTPA(TPA);
  141.   ConvexHull(CTPA);
  142.  
  143.   DrawTPABitmap(bmp, TPA, 357435);
  144.   DrawTPABitmap(bmp, CTPA, 255);
  145.  
  146.   DisplayDebugImgWindow(700,700);
  147.   DrawBitmapDebugImg(bmp);
  148.   FreeBitmap(bmp);
  149. end.
Advertisement
Add Comment
Please, Sign In to add comment