DBR Delphi-Ecke

// Für die foldenden Routinen habe ich unter anderem ein
// SDK-Beispiel umgestrickt. Man kann damit abprüfen, ob sich ein
// Punkt innerhalb oder außerhalb eines Polygons befindet. Damit hat
// man zum Ersten eine gute Alternative für die Funktion
// "PtInRegion", welche GDI-Ressourcen beansprucht und bei komplexen
// Regionen das Programm sichtlich verlangsamen kann. Zum Zweiten
// kann man auch einfach nur gezeichnete Polygone (ohne Region)
// abprüfen. In der Variante 1 wird getestet, ob sich die Maus über
// einen vierzackigen Stern bewegt oder nicht.
// Siehe dazu auch Testen, ob sich ein Punkt in einer Ellipse befindet

// Getestet mit D4 unter WinME

// Variante 1:

var 
  r: TRect; 
 
function MakeRect(pts: array of TPoint): TRect; 
var 
  i, xmin, xmax, ymin, ymax: integer; 
begin 
  xmin := maxint; 
  ymin := maxint; 
  xmax := -maxint; 
  ymax := -maxint; 
  for i := 0 to high(pts) do begin 
    if pts[i].x < xmin then xmin := pts[i].x; 
    if pts[i].x > xmax then xmax := pts[i].x; 
    if pts[i].y < ymin then ymin := pts[i].y; 
    if pts[i].y > ymax then ymax := pts[i].y; 
  end; 
  SetRect(result, xmin, ymin, xmax, ymax); 
end; 
 
function ccw(p0, p1, p2: TPoint): integer; 
var 
  dx1, dx2, dy1, dy2: longint; 
begin 
  dx1 := p1.x - p0.x; dx2 := p2.x - p0.x; 
  dy1 := p1.y - p0.y; dy2 := p2.y - p0.y; 
  result := ord(dx1 * dy2 > dy1 * dx2) * 2 - 1; 
end; 
 
function Intersect(p1, p2, p3, p4: TPoint): boolean; 
begin 
  result := (((ccw(p1, p2, p3) * ccw(p1, p2, p4)) <= 0) 
    and ((ccw(p3, p4, p1) * ccw(p3, p4, p2) <= 0))); 
end; 
 
function PtInPolygon(pts: array of TPoint; ptTest: TPoint): boolean; 
var 
  i, wnumintsct: word; 
  pt: TPoint; 
begin 
  wnumintsct := 0; 
  if not PtInRect(r, ptTest) then begin 
    result := false; 
    exit; 
  end; 
  pt := ptTest; 
  pt.x := r.right + 50; 
  for i := 0 to high(pts) - 1 do begin 
    if Intersect(ptTest, pt, pts[i], pts[i + 1]) then inc(wnumintsct); 
  end; 
  if Intersect(ptTest, pt, pts[high(pts)], pts[0]) then inc(wnumintsct); 
  result := odd(wnumintsct); 
end; 
 
var 
  punkte: array[0..7] of TPoint; 
 
procedure TForm1.FormPaint(Sender: TObject); 
begin 
  canvas.polygon(punkte); 
end; 
 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  punkte[0] := point(100, 100); 
  punkte[1] := point(175, 75); 
  punkte[2] := point(200, 0); 
  punkte[3] := point(225, 75); 
  punkte[4] := point(300, 100); 
  punkte[5] := point(225, 125); 
  punkte[6] := point(200, 200); 
  punkte[7] := point(175, 125); 
  r := MakeRect(punkte); 
  label1.caption := ''; 
end; 
 
procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X, 
  Y: Integer); 
begin 
  if PtInPolygon(punkte, point(x, y)) then label1.caption := 'drin' 
  else label1.caption := 'draußen'; 
end;

// Variante 2:

// Bei dieser Variante werden die Funktionen
// function MakeRect(pts: array of TPoint): TRect;
// function ccw(p0, p1, p2: TPoint): integer;
// function Intersect(p1, p2, p3, p4: TPoint): boolean;
// function PtInPolygon(pts: array of TPoint;
// ptTest: TPoint): boolean;
// in einer einzigen Funktion vereinigt.

function PtInPoly(const Points: array of TPoint; X, Y: integer): Boolean; 
var 
  P1, P2: ^TPoint; 
  i, j, h, MDiff1, MDiff2: integer; 
begin 
  h := high(points); 
  result := false; 
  j := h; 
  for i := 0 to h do 
  begin 
    P1 := @Points[i]; 
    P2 := @Points[j]; 
    if (y < P2.y) then 
    begin 
      if (P1.y <= y) then 
      begin 
        MDiff2 := (y - P1.y) * (P2.x - P1.x); 
        MDiff1 := (x - P1.x) * (P2.y - P1.y); 
        if (MDiff2 > MDiff1) then 
          result := not result; 
      end; 
    end 
    else if (y < P1.y) then 
    begin 
      MDiff2 := (y - P1.y) * (P2.x - P1.x); 
      MDiff1 := (x - P1.x) * (P2.y - P1.y); 
      if (MDiff2 < MDiff1) then 
        result := not result; 
    end; 
    j := i; 
  end; 
end;

// Variante 3:

// anderes Herangehen:

function PtInPolygon(Points: array of TPoint; ptTest: TPoint): boolean; 
var 
  i, j: integer; 
  lg: integer; 
begin 
  Result := false; 
  lg := length(Points); 
  for i := 0 to pred(lg) do begin 
    j := succ(i) mod lg; 
    if ((((Points[i].y <= ptTest.y) and (ptTest.y < Points[j].y)) or 
      ((Points[j].y <= ptTest.y) and (ptTest.y < Points[i].y))) and 
      (ptTest.x < (Points[j].x - Points[i].x) * (ptTest.y - Points[i].y) / 
      (Points[j].y - Points[i].y) + Points[i].x)) then 
      Result := not Result; 
  end; 
end;

// Variante 4:

// Falls man nur Rechtecke/Quadrate (quasi Polygone mit 4 Ecken)
// abprüfen will, kann man natürlich die eben beschriebenen Routinen
// ebenfallse benutzen, man kann aber den Code auch wesentlich
// vereinfachen:

var 
  x1, x2, y1, y2: integer; 
  r: TRect; 
 
procedure TForm1.FormPaint(Sender: TObject); 
begin 
  canvas.rectangle(x1, y1, x2, y2); 
end; 
 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  x1 := 50; 
  y1 := 50; 
  x2 := 200; 
  y2 := 150; 
  r := rect(x1, y1, x2, y2); 
  label1.caption := ''; 
end; 
 
procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X, 
  Y: Integer); 
begin 
  if PtInRect(r, point(x, y)) then 
    label1.caption := 'drin' else label1.caption := 'draußen'; 
end;