Janilabo

Untitled

Jul 20th, 2013
64
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
Pascal 6.16 KB | None | 0 0
  1. procedure TPAEdge(var TPA: TPointArray);
  2. var
  3.   v, x, y, h, r: Integer;
  4.   B: array of TBoolArray;
  5.   bx: TBox;
  6. begin;
  7.   h := High(TPA);
  8.   if (h > 3) then
  9.   begin
  10.     bx := IntToBox(TPA[0].X, TPA[0].Y, TPA[0].X, TPA[0].Y);
  11.     if (h > 0) then
  12.     for v := 1 to h do
  13.     begin
  14.       if (TPA[v].X < bx.X1) then
  15.         bx.X1 := TPA[v].X
  16.       else
  17.         if (TPA[v].X > bx.X2) then
  18.           bx.X2 := TPA[v].X;
  19.       if (TPA[v].Y < bx.Y1) then
  20.         bx.Y1 := TPA[v].Y
  21.       else
  22.         if (TPA[v].Y > bx.Y2) then
  23.           bx.Y2 := TPA[v].Y;
  24.     end;
  25.     bx := IntToBox((bx.X1 - 1), (bx.Y1 - 1), (bx.X2 + 1), (bx.Y2 + 1));
  26.     SetLength(B, ((bx.X2 - bx.X1) + 1));
  27.     for v := 0 to (bx.X2 - bx.X1) do
  28.       SetLength(B[v], ((bx.Y2 - bx.Y1) + 1));
  29.     for v := 0 to h do
  30.       if not B[(TPA[v].X - bx.X1)][(TPA[v].Y - bx.Y1)] then
  31.         B[(TPA[v].X - bx.X1)][(TPA[v].Y - bx.Y1)] := True;
  32.     for y := 1 to ((bx.Y2 - bx.Y1) - 1) do
  33.       for x := 1 to ((bx.X2 - bx.X1) - 1) do
  34.         if B[x][y] then
  35.           if not (B[(x - 1)][y] and B[x][(y - 1)] and B[(x + 1)][y] and B[x][(y + 1)]) then
  36.           begin
  37.             TPA[r].X := (x + bx.X1);
  38.             TPA[r].Y := (y + bx.Y1);
  39.             Inc(r);
  40.           end;
  41.     SetLength(TPA, r);
  42.     SetLength(B, 0);
  43.   end;
  44. end;
  45.  
  46. {------------------------------------------------------------------------------]
  47.  Check if a point is within a polygon/shape by the given outline points (poly)
  48.  The points must be in order, as if you would draw a line trough each point.
  49. [------------------------------------------------------------------------------}
  50. function InPoly(pt:TPoint; poly:TPointArray): Boolean;
  51. var
  52.   N,I, xint: Integer;
  53.   p1,p2: TPoint;
  54.   e: TPointArray;
  55. begin
  56.   N := Length(poly);
  57.   Result := False;
  58.   if N>2 then
  59.   begin
  60.     p1 := poly[0];
  61.     for I:=0 to N do
  62.     begin
  63.       p2 := poly[I mod N];
  64.       if (pt.y > min(p1.y,p2.y))  and
  65.          (pt.y <= max(p1.y,p2.y)) and
  66.          (pt.x <= max(p1.x,p2.x)) then
  67.       begin
  68.         if (p1.y <> p2.y) then
  69.           xint := (pt.y - p1.y) * (p2.x - p1.x) div (p2.y - p1.y) + p1.x;
  70.         if (p1.x = p2.x) or (pt.x < xint) then
  71.           Result := Not(Result);
  72.       end;
  73.       p1 := p2;
  74.     end;
  75.   end;
  76. end;
  77.  
  78. //******* DIRTY EXAMPLE BELLOW: *******//
  79. procedure SetPixels(bmp: Integer; TPA: TPointArray; color: Integer);
  80. var
  81.   a, z, w, h: Integer;
  82. begin
  83.   z := High(TPA);
  84.   if (z > -1) then
  85.   begin
  86.     GetBitmapSize(bmp, w, h);
  87.     for a := 0 to z do
  88.       if ((TPA[a].X >= 0) and (TPA[a].Y >= 0) and (TPA[a].X < w) and (TPA[a].Y < h)) then
  89.         FastSetPixel(bmp, TPA[a].X, TPA[a].Y, color);
  90.   end;
  91. end;
  92.  
  93. procedure SetPixelsMP(bmp: Integer; TPA: TPointArray; color: Integer);
  94. var
  95.   a, z, w, h: Integer;
  96. begin
  97.   z := High(TPA);
  98.   if (z > -1) then
  99.   begin
  100.     GetBitmapSize(bmp, w, h);
  101.     for a := 0 to z do
  102.       if ((TPA[a].X > 0) and (TPA[a].Y > 0) and (TPA[a].X < w-1) and (TPA[a].Y < h-1)) then
  103.       begin
  104.         FastSetPixel(bmp, TPA[a].X-1, TPA[a].Y, color);
  105.         FastSetPixel(bmp, TPA[a].X+1, TPA[a].Y, color);
  106.         FastSetPixel(bmp, TPA[a].X, TPA[a].Y+1, color);
  107.         FastSetPixel(bmp, TPA[a].X, TPA[a].Y-1, color);
  108.       end;
  109.   end;
  110. end;
  111.  
  112. function FillShape(Shape:TPointArray): TPointArray;
  113. var
  114.   TBA: TBox;
  115.   x,y: Integer;
  116.   e: TPointArray;
  117.   s: Boolean;
  118. begin
  119.   TBA:=GetTPABounds(Shape);
  120.   e := CopyTPA(Shape);
  121.   TPAEdge(e);
  122.   for x := TBA.x1 to TBA.x2 do
  123.     for y := TBA.y1 to TBA.y2 do
  124.     begin
  125.       s := PointInTPA(Point(x, y), e);
  126.       if not s then
  127.         if InPoly(Point(x,y), Shape) then
  128.         begin
  129.           SetLength(Result, Length(Result)+1);
  130.           Result[High(Result)] := Point(x,y);
  131.         end;
  132.     end;
  133.   SetLength(e, 0);
  134. end;
  135.  
  136. function Xagon(Sides:Integer;C,S:TPoint): TPointArray;
  137. var
  138.   ptx,pty,dx,dy,i: Integer;
  139.   rads:Extended;
  140. begin
  141.   SetLength(Result,Sides+1);
  142.   ptx := S.x;
  143.   pty := S.y;
  144.   rads := Radians(360/sides);
  145.   for i:=0 to Sides do
  146.   begin
  147.     dx := ptx - c.x;
  148.     dy := pty - c.y;
  149.     ptx := Round((dy * Sin(rads)) + (dx * Cos(rads)) + c.x);
  150.     pty := Round((dy * Cos(rads)) - (dx * Sin(rads)) + c.y);
  151.     Result[i] := Point(ptx,pty);
  152.   end;
  153. end;
  154.  
  155. //******* Plot a few shapes using this algorithm *******//
  156. var
  157.   Shape, TPA: TPointArray;
  158.   bmp: Integer;
  159.   ShowExample,ShowPoints: Integer;
  160. begin
  161.   //Dynamic shapes from Example 6 and down:
  162.   ShowExample := 1; //1 - 9
  163.   ShowPoints := 0;  //0 or 1
  164.  
  165.   Case ShowExample of
  166.   0: Shape := [Point(50, 50), Point(51, 50), Point(50, 51), Point(51, 51)];
  167.   1: // Manual: Arrow like shape //
  168.      Shape := [Point(70,90),Point(185,90),Point(185,116), Point(70,116), //Square +
  169.                Point(70,140),Point(35,105),Point(70,70)];                //Triangle
  170.  
  171.   2: // Manual: Triangle //
  172.      Shape := [Point(50,50),Point(0,100),Point(100,150)];
  173.  
  174.   3: // Manual: Raped pentagon //
  175.      Shape := [Point(10,25),Point(35,5),Point(82,22),Point(50,90),Point(4,60)];
  176.  
  177.   4: // Manual: Octagon //
  178.      Shape := [Point(100,30), Point(155,50),  //Top-Right
  179.                Point(180,110),Point(155,160), //Right-Bottom
  180.                Point(100,180),Point(45,160),  //Bottom-Left
  181.                Point(20,100), Point(45,50)];  //Left-Top
  182.  
  183.   5: // Manual: S-Shape //
  184.      Shape := [Point(135,50),Point(123,70),Point(103,58),Point(85,70),Point(85,85),
  185.                 Point(122,105),Point(132,125),Point(120,155),Point(78,164),Point(55,147),
  186.                 Point(64,128),Point(80,140),Point(100,140),Point(96,116),Point(62,98),
  187.                 Point(60,55),Point(111,35)];
  188.  
  189.   6: // Xagon: 15 corners //
  190.      Shape := Xagon(15, Point(100,100), Point(60,100));
  191.  
  192.   7: // Xagon: 9 corners //
  193.      Shape := Xagon(9, Point(100,100), Point(60,50));
  194.  
  195.   8: // Xagon: 5 corners AKA Pentagon //
  196.      Shape := Xagon(5, Point(100,100), Point(75,50));
  197.  
  198.   9: // Xagon: 3 corners AKA Triangle //
  199.      Shape := Xagon(3, Point(100,100), Point(48,48));
  200.   end;
  201.  
  202.   bmp := CreateBitmap(200, 200);
  203.   TPA := FillShape(Shape);
  204.   //TPAEdge(TPA);
  205.   SetPixels(bmp, TPA, 357435);
  206.   if ShowPoints=1 then
  207.     SetPixelsMP(bmp, Shape, 16777215);
  208.   DisplayDebugImgWindow(200, 200);
  209.   DrawBitmapDebugImg(bmp);
  210.   FreeBitmap(bmp);
  211. end.
Advertisement
Add Comment
Please, Sign In to add comment