Schnittpunkte beliebiger Polygone mit einem beliebigem Achsen-parallelem Rechteck

[ohkay]

danke für eure hilfe ich habe eine elegante lösung gefunden dank euch

Delphi-Quellcode:

procedure Schnittpunkt(x1,y1,x2,y2,x3,y3,x4,y4:integer;var xs,ys:integer; var ok:boolean);
  var
      d:integer; t1,t2:real;
 function det (a,b,c,d:integer):integer;
  begin
      det:=a*d-b*c;
  end;
  begin
      d:= det(x2-x1,x3-x4,y2-y1,y3-y4);
      ok:= false;
      if d<>0 then
      begin
          t1:=det(x3-x1,x3-x4,y3-y1,y3-y4)/d;
          t2:=det(x2-x1,x3-x1,y2-y1,y3-y1)/d;
          if (t1>=0) and (t1<=1) and (t2>=0) and (t2<=1) then

          begin
              xs:=x1+round(t1*(x2-x1));
              ys:=y1+round(t1*(y2-y1));
              ok:=true;
          end;
      end;
  end;

//die anwendung der funktion für mein problem
{procedure TForm1.Button3Click(Sender: TObject);                                 //schnittpunkte anzeigen
 var
    i:integer;
    xs,ys:integer;
    ok:boolean;

  begin
      xp[n+1]:=xp[1];
      yp[n+1]:=yp[1];
      for i := 1 to n do
      begin
      image1.Canvas.Pen.Color:=clred;
          Schnittpunkt(xp[i],yp[i],xp[i+1],yp[i+1],xmin,ymin,xmax,ymin,xs,ys,ok);  //schnitpunkte oben
          if ok  then
          begin
              image1.Canvas.Rectangle(xs-3,ys-3,xs+3,ys+3)
          end;
          Schnittpunkt(xp[i],yp[i],xp[i+1],yp[i+1],xmax,ymin,xmax,ymax,xs,ys,ok);  //schnitpunkte rechts
          if ok  then
          begin
              image1.Canvas.Rectangle(xs-3,ys-3,xs+3,ys+3)
          end;
          Schnittpunkt(xp[i],yp[i],xp[i+1],yp[i+1],xmax,ymax,xmin,ymax,xs,ys,ok);   //schnitpunkte unten
          if ok  then
          begin
              image1.Canvas.Rectangle(xs-3,ys-3,xs+3,ys+3)
          end;
          Schnittpunkt(xp[i],yp[i],xp[i+1],yp[i+1],xmin,ymax,xmin,ymin,xs,ys,ok);   //schnitpunkte links
          if ok  then
          begin
              image1.Canvas.Rectangle(xs-3,ys-3,xs+3,ys+3)
          end;
      end;
  end;}
end.

das wars schon, ich hoffe es hilft auch mal anderen
dank noch mal an alle




mfg martin

[Bummi]

Funktioniert einwandfrei Martin, ich hätte noch eine Version mit einer leicht geänderten Schreibweise

Delphi-Quellcode:

Function Schnittpunkt(v1, b1, v2, b2: TPoint; var ResultPoint: TPoint): Boolean;

  function det(a, b, c, d: Integer): Integer;
  begin
    Result := a * d - b * c;
  end;

var
  d: Integer;
  t1, t2: Double;
begin
  d := det(b1.X - v1.X, v2.X - b2.X, b1.Y - v1.Y, v2.Y - b2.Y);
  if d <> 0 then
  begin
    t1 := det(v2.X - v1.X, v2.X - b2.X, v2.Y - v1.Y, v2.Y - b2.Y) / d;
    t2 := det(b1.X - v1.X, v2.X - v1.X, b1.Y - v1.Y, v2.Y - v1.Y) / d;
    Result := (t1 >= 0) and (t1 <= 1) and (t2 >= 0) and (t2 <= 1);
    if Result then
    begin
      ResultPoint.X := v1.X + round(t1 * (b1.X - v1.X));
      ResultPoint.Y := v1.Y + round(t1 * (b1.Y - v1.Y));
    end;
  end;
end;

procedure TForm2.FormMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if Tag = 0 then
  begin
    P1.X := X;
    P1.Y := Y;
  end
  else
  begin
    p3.X := X;
    p3.Y := Y;
  end;
end;

procedure TForm2.FormMouseMove(Sender: TObject; Shift: TShiftState;
  X, Y: Integer);
begin
  if ssLeft in Shift then
  begin
    if Tag = 0 then
    begin
      p2.X := X;
      p2.Y := Y;
    end
    else
    begin
      p4.X := X;
      p4.Y := Y;
    end;
  end;
  invalidate;
end;

procedure TForm2.FormMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if Tag = 0 then
    Tag := 1
  else
    Tag := 0;

end;

procedure TForm2.FormPaint(Sender: TObject);
var
  sp: TPoint;
begin
  Canvas.MoveTo(P1.X, P1.Y);
  Canvas.LineTo(p2.X, p2.Y);
  Canvas.MoveTo(p3.X, p3.Y);
  Canvas.LineTo(p4.X, p4.Y);
  if Schnittpunkt(P1, p2, p3, p4, sp) then
  begin
    Canvas.Ellipse(sp.X - 5, sp.Y - 5, sp.X + 5, sp.Y + 5);
  end;
end;