#1268. Только код. Определение места пересечения прямой с прямоугольником (Bounding Rect)

По "мотивам" - http://programmingmindstream.blogspot.ru/2016/09/1267.html

Всё те же "определители матрицы" и "векторные произведения"...

unit msLineF;

interface

uses
 System.Types,

 FMX.DUnit.msLog
 ;

type
 Pixel = Single;

 TmsPointF = record
 public
  P : TPointF;
  constructor Create(const aPoint: TPointF); overload;
  constructor Create(aX: Pixel; aY: Pixel); overload;
  procedure ToLog(aLog: TmsLog);
  class function Normalize(const aPt: TmsPointF): TmsPointF; static;
  function N: TmsPointF;
  function ToString: String;
  property X: Pixel
   read P.X
   write P.X;
  property Y: Pixel
   read P.Y
   write P.Y;
 end;//TmsPointF

 TmsLineF = record
 public
  A : TmsPointF;
  B : TmsPointF;
  procedure ToLog(aLog: TmsLog);
  function ToString: String;
  function Cross(const anOther: TmsLineF; out theCross: TmsPointF): Boolean;
  // - пересечение линий
  function SegmentsCross(const anOther: TmsLineF; out theCross: TmsPointF): Boolean;
  // - пересечение отрезков
  constructor Create(const aA: TmsPointF; const aB: TmsPointF); overload;
  constructor Create(const aA: TPointF; const aB: TPointF); overload;
  constructor Create(aAX, aAY: Pixel; aBX, aBY: Pixel); overload;
  function dX: Pixel;
  function dY: Pixel;
  function Length: Pixel;
  function ScalarMul(const anOther: TmsLineF): Pixel;
  function CosA(const anOther: TmsLineF): Single;
 end;//TmsLineF

 TmsLineFPair = record
 public
  L1 : TmsLineF;
  L2 : TmsLineF;
  constructor Create(const aL1: TmsLineF; const aL2: TmsLineF);
  procedure ToLog(aLog: TmsLog);
  function ToString: String;
  function Cross(out theCross: TmsPointF): Boolean;
  // - пересечение линий
  function SegmentsCross(out theCross: TmsPointF): Boolean;
  // - пересечение отрезков
 end;//TmsLineFPair

 TmsLineFPairs = array of TmsLineFPair;

 TmsRectF = record
 public
  R : TRectF;
  constructor Create(const aR: TRectF);
  function Cross(const anOther: TmsLineF; out theCross: TmsPointF): Boolean;
 end;//TmsRectF

implementation

uses
 System.SysUtils,
 Math,
 FMX.DUnit.msAppLog
 ;

// TmsPointF

constructor TmsPointF.Create(const aPoint: TPointF);
begin
 P := aPoint;
end;

constructor TmsPointF.Create(aX: Pixel; aY: Pixel);
begin
 Create(TPointF.Create(aX, aY));
end;

procedure TmsPointF.ToLog(aLog: TmsLog);
var
 l_N : TmsPointF;
begin
 l_N := Self.N;
 aLog.ToLog('X:');
 aLog.ToLog(FloatToStr(l_N.P.X));
 aLog.ToLog('Y:');
 aLog.ToLog(FloatToStr(l_N.P.Y));
end;

class function TmsPointF.Normalize(const aPt: TmsPointF): TmsPointF;
begin
 Result := aPt;
end;

function TmsPointF.N: TmsPointF;
begin
 Result := Normalize(Self);
end;

function TmsPointF.ToString: String;
var
 l_P : TmsPointF;
begin
 l_P := Self.N;
 Result := FloatToStr(l_P.X) + '_' + FloatToStr(l_P.Y);
end;

// TmsLineF

procedure TmsLineF.ToLog(aLog: TmsLog);
begin
 aLog.ToLog('dump line:');
 aLog.ToLog('A:');
 A.ToLog(aLog);
 aLog.ToLog('B:');
 B.ToLog(aLog);
end;

function TmsLineF.ToString: String;
begin
 Result := A.ToString + '_' + B.ToString;
end;

function DoCross(const Self: TmsLineF; const anOther: TmsLineF; out theCross: TmsPointF): Boolean;
var
 dXdY : Pixel;
 dYdX : Pixel;
 dYdY : Pixel;
begin//DoCross
 Result := false;
 Assert(not IsZero(Self.dY));

 // - теперь тут можно будет вставить ЛЮБОЙ ДРУГОЙ алгоритм и посмотреть - "что будет"

 dXdY := Self.dX * anOther.dY;
 dYdX := Self.dY * anOther.dX;
 dYdY := Self.dY * anOther.dY;

 if IsZero(dXdY - dYdX) then
 // - условие параллельности прямых
 begin
//  Self.ToLog(TmsAppLog.Instance);
//  anOther.ToLog(TmsAppLog.Instance);
  theCross.X := -1;
  theCross.Y := -1;
  Exit;
 end;//IsZero(dXdY - dYdX)

 Assert(not IsZero(dXdY - dYdX));

 theCross.Y := (
                 dXdY * Self.A.Y -
                 dYdX * anOther.A.Y +
                 dYdY * (anOther.A.X - Self.A.X)
               )
                /
               (dXdY - dYdX);

 theCross.X := Self.A.X +
               Self.dX * (theCross.Y - Self.A.Y)
                /
               Self.dY;
 Result := true;
end;//DoCross

function TmsLineF.Cross(const anOther: TmsLineF; out theCross: TmsPointF): Boolean;
(*var
 l_Angle : Single;*)
begin
 Result := false;
 theCross := TmsPointF.Create(High(Integer), High(Integer));
 if IsZero(Self.Length) then
 begin
  theCross.X := 0;
  if IsZero(anOther.Length) then
   theCross.Y := 0;
  Exit;
 end//IsZero(Self.Length)
 else
 if IsZero(anOther.Length) then
 begin
  theCross.Y := 0;
  Exit;
 end;//IsZero(anOther.Length)

 // Дальше нужно проверить параллельность прямых
(* l_Angle := ArcCos(Self.CosA(anOther));
 if IsZero(l_Angle) OR SameValue(l_Angle, pi) OR SameValue(l_Angle, 2 * pi) then
 begin
  theCross.X := -1;
  theCross.Y := -1;
  Exit;
 end;//IsZero(ArcCos(Self.CosA(anOther)))*)

 if IsZero(Self.dY) then
 begin
  if IsZero(anOther.dX) then
  begin
   Result := true;
   theCross.X := anOther.A.X;
   theCross.Y := Self.A.Y;
   Exit;
  end//IsZero(anOther.dX)
  else
  begin
   if IsZero(anOther.dY) then
   begin
    Result := false;
    Exit;
   end//IsZero(anOther.dY)
   else
   begin
    Result := DoCross(anOther, Self, theCross);
    Exit;
   end;//IsZero(anOther.dY)
  end;//IsZero(anOther.dX)
 end//IsZero(Self.dY)
 else
 if IsZero(anOther.dY) then
 begin
  if IsZero(Self.dX) then
  begin
   Result := true;
   theCross.X := Self.A.X;
   theCross.Y := anOther.A.Y;
   Exit;
  end;//IsZero(Self.dX)
 end;//IsZero(anOther.dY)

 // Дальше можно по идее применять Мишин алгоритм:

 Result := DoCross(Self, anOther, theCross);
end;

function TmsLineF.SegmentsCross(const anOther: TmsLineF; out theCross: TmsPointF): Boolean;

 function Btwn(aValue, aB1, aB2: Pixel): Boolean;
 var
  l_Min : Pixel;
  l_Max : Pixel;
 begin//Btwn
  l_Min := Min(aB1, aB2);
  l_Max := Max(aB1, aB2);
  Result := ((aValue >= l_Min) OR SameValue(aValue, l_Min)) and
            ((aValue <= l_Max) OR SameValue(aValue, l_Max));
 end;//Btwn

begin
 Result := Cross(anOther, theCross);
 if Result then
 begin
  Result := Btwn(theCross.X, Self.A.X, Self.B.X) and
            Btwn(theCross.X, anOther.A.X, anOther.B.X) and
            Btwn(theCross.Y, Self.A.Y, Self.B.Y) and
            Btwn(theCross.Y, anOther.A.Y, anOther.B.Y);
 end;//Result
end;

constructor TmsLineF.Create(const aA: TmsPointF; const aB: TmsPointF);
begin
 A := aA;
 B := aB;
end;

constructor TmsLineF.Create(const aA: TPointF; const aB: TPointF);
begin
 Create(TmsPointF.Create(aA.X, aA.Y), TmsPointF.Create(aB.X, aB.Y));
end;


constructor TmsLineF.Create(aAX, aAY: Pixel; aBX, aBY: Pixel);
begin
 Create(TmsPointF.Create(aAX, aAY), TmsPointF.Create(aBX, aBY));
end;

function TmsLineF.dX: Pixel;
begin
 Result := (B.X - A.X);
end;

function TmsLineF.dY: Pixel;
begin
 Result := (B.Y - A.Y);
end;

function TmsLineF.Length: Pixel;
begin
 Result := Sqrt(dX * dX + dY * dY);
end;

function TmsLineF.ScalarMul(const anOther: TmsLineF): Pixel;
begin
 Result := Self.dX * anOther.dX + Self.dY * anOther.dY;
end;

function TmsLineF.CosA(const anOther: TmsLineF): Single;
begin
 Result := Self.ScalarMul(anOther) / (Self.Length * anOther.Length);
end;

// TmsLineFPair

constructor TmsLineFPair.Create(const aL1: TmsLineF; const aL2: TmsLineF);
begin
 L1 := aL1;
 L2 := aL2;
end;

procedure TmsLineFPair.ToLog(aLog: TmsLog);
begin
 aLog.ToLog('L1:');
 L1.ToLog(aLog);
 aLog.ToLog('L2:');
 L2.ToLog(aLog);
end;

function TmsLineFPair.ToString: String;
begin
 Result := L1.ToString + '_' + L2.ToString;
end;

function TmsLineFPair.Cross(out theCross: TmsPointF): Boolean;
begin
 Result := L1.Cross(L2, theCross);
end;

function TmsLineFPair.SegmentsCross(out theCross: TmsPointF): Boolean;
begin
 Result := L1.SegmentsCross(L2, theCross);
end;

// TmsRectF

constructor TmsRectF.Create(const aR: TRectF);
begin
 R := aR;
end;

function TmsRectF.Cross(const anOther: TmsLineF; out theCross: TmsPointF): Boolean;
var
 l_R : array [0..3] of TmsLineF;
 l_L : TmsLineF;
begin
 Result := true;

 l_R[0] := TmsLineF.Create(TPointF.Create(R.Left, R.Top), TPointF.Create(R.Right, R.Top));
 l_R[1] := TmsLineF.Create(TPointF.Create(R.Right, R.Top), TPointF.Create(R.Right, R.Bottom));
 l_R[2] := TmsLineF.Create(TPointF.Create(R.Left, R.Bottom), TPointF.Create(R.Right, R.Bottom));
 l_R[3] := TmsLineF.Create(TPointF.Create(R.Left, R.Top), TPointF.Create(R.Left, R.Bottom));

 for l_L in l_R do
  if l_L.SegmentsCross(anOther, theCross) then
   Exit;

 Result := false;
end;

end.

Пример использования:

unit msConnector;

interface

uses
 System.Types,
 msInterfaces,
 msLine,
 msLineWithArrow,
 Data.DBXJSONReflect
 ;

type
 TmsConnector = class(TmsLineWithArrow{TmsLine})
 strict private
  [JSONMarshalled(False)]
  f_LeftShape : ImsShape;
  [JSONMarshalled(False)]
  f_RightShape : ImsShape;
  f_UIDLeft : TmsShapeUID;
  f_UIDRight : TmsShapeUID;
 private
  function pm_GetLeftShape: ImsShape;
  property LeftShape : ImsShape
   read pm_GetLeftShape;
  function pm_GetRightShape: ImsShape;
  property RightShape : ImsShape
   read pm_GetRightShape;
 protected
  constructor CreateInner(const aShapeClass : ImsShapeClass; const aCtx: TmsMakeShapeContext); override;
  procedure SetStartPoint(const aStartPoint: TPointF); override;
  function pm_GetStartPoint: TPointF; override;
  function pm_GetFinishPoint: TPointF; override;
  function HitTest(const aPoint: TPointF; out theShape: ImsShape): Boolean; override;
  procedure MoveBy(const aCtx: TmsMoveContext); override;
  function EndTo(const aCtx: TmsEndShapeContext): Boolean; override;
  class function BoundByContext(const aCtx: TmsMakeShapeContext): ImsShape;
 public
  class function IsConnectorLike: Boolean; override;
 end;//TmsConnector

implementation

uses
  msLineF,
  msTotalShapesList
  ;

// TmsConnector

class function TmsConnector.BoundByContext(const aCtx: TmsMakeShapeContext): ImsShape;
begin
 Result := aCtx.rShapesController.ShapeByPt(aCtx.rStartPoint);
 if (Result <> nil) then
  if Result.ShapeClass.IsLineLike then
  // - линии не будем привязывать к линиям
   Result := nil;
end;

constructor TmsConnector.CreateInner(const aShapeClass : ImsShapeClass; const aCtx: TmsMakeShapeContext);
begin
 inherited;
 if (aCtx.rShapesController <> nil) then
 begin
  f_LeftShape := BoundByContext(aCtx);
  if (f_LeftShape <> nil) then
   f_UIDLeft := f_LeftShape.UID;
 end;//aCtx.rShapesController <> nil
end;

function TmsConnector.pm_GetLeftShape: ImsShape;
begin
 if (f_LeftShape = nil) then
  if not f_UIDLeft.IsNull then
   f_LeftShape := TmsTotalShapesList.ShapeByUID(f_UIDLeft);
 Result := f_LeftShape;
end;

function TmsConnector.pm_GetRightShape: ImsShape;
begin
 if (f_RightShape = nil) then
  if not f_UIDRight.IsNull then
   f_RightShape := TmsTotalShapesList.ShapeByUID(f_UIDRight);
 Result := f_RightShape;
end;

procedure TmsConnector.SetStartPoint(const aStartPoint: TPointF);
begin
 inherited;
end;

function TmsConnector.pm_GetStartPoint: TPointF;
var
 l_A : TPointF;
 l_B : TPointF;
 l_R : TmsPointF;
begin
 if (LeftShape <> nil) then
 begin
  l_A := LeftShape.StartPoint;
  if (RightShape <> nil) then
   l_B := RightShape.StartPoint
  else
   l_B := inherited pm_GetFinishPoint;
  if TmsRectF.Create(LeftShape.DrawBounds).Cross(TmsLineF.Create(l_A, l_B), l_R) then
   Result := l_R.P
  else
   Result := l_A;
 end//LeftShape <> nil
 else
  Result := inherited;
end;

function TmsConnector.pm_GetFinishPoint: TPointF;
var
 l_A : TPointF;
 l_B : TPointF;
 l_R : TmsPointF;
begin
(* if (inherited pm_GetStartPoint = inherited pm_GetFinishPoint) then
 begin
  Result := inherited pm_GetStartPoint;
  Exit;
 end;//inherited pm_GetStartPoint = inherited pm_GetFinishPoint*)
 if (RightShape <> nil) then
 begin
  l_B := RightShape.StartPoint;
  if (LeftShape <> nil) then
   l_A := LeftShape.StartPoint
  else
   l_A := inherited pm_GetStartPoint;
  if TmsRectF.Create(RightShape.DrawBounds).Cross(TmsLineF.Create(l_A, l_B), l_R) then
   Result := l_R.P
  else
   Result := l_B;
 end//RightShape <> nil
 else
 if (LeftShape = nil) then
  // - если нет ОБОИХ границ, то мы - "линия"
  Result := inherited
 else
  Result := pm_GetStartPoint;
  // - если есть только левая граница, то мы - "точка"
end;

function TmsConnector.HitTest(const aPoint: TPointF; out theShape: ImsShape): Boolean;
begin
 Result := true;
 if (LeftShape <> nil) AND LeftShape.HitTest(aPoint, theShape) then
  Exit;
 if (RightShape <> nil) AND RightShape.HitTest(aPoint, theShape) then
  Exit;
 Result := inherited;
end;

procedure TmsConnector.MoveBy(const aCtx: TmsMoveContext);
(*var
 l_Shape : ImsShape;*)
begin
(* if (aCtx.rShapesController <> nil) then
 begin
  if (RightShape = nil) then
  begin
   if SamePoint(Self.FinishPoint, aCtx.rStartPoint) then
   begin
    RightShape := aCtx.rShapesController.ShapeByPt(Self.FinishPoint + aCtx.rDelta);
    if Self.EQ(RightShape) then
     RightShape := nil;
   end;//SamePoint(Self.FinishPoint, aCtx.rStartPoint)
  end;//RightShape = nil
 end;//aCtx.rShapesController <> nil

 if (LeftShape <> nil) AND SamePoint(aCtx.rStartPoint, Self.StartPoint) then
 begin
  LeftShape.MoveBy(aCtx);
  Exit;
 end;//LeftShape <> nil

 if (RightShape <> nil) AND RightShape.HitTest(aCtx.rStartPoint + aCtx.rDelta, l_Shape) then
 begin
  RightShape.MoveBy(aCtx);
  Exit;
 end;//RightShape <> nil*)
 inherited;
end;

function TmsConnector.EndTo(const aCtx: TmsEndShapeContext): Boolean;
begin
 if (aCtx.rShapesController <> nil) then
 begin
  f_RightShape := BoundByContext(aCtx);
  if (f_RightShape <> nil) then
   f_UIDRight := f_RightShape.UID;
 end;//aCtx.rShapesController <> nil
 Result := inherited;
end;

class function TmsConnector.IsConnectorLike: Boolean;
begin
 Result := true;
end;

end.