Среда программирования:
Lazarus
Статья по теме:
Определить точку пересечения двух отрезков. Решение состоит из нахождения векторного произведения function VM()
, определения факта пересечения 2 отрезков function LC()
, составления уравнений прямых procedure PtL()
и определения точки пересечения function LtP()
, собственно.
Код программы:
unit Unit1; {$mode objfpc}{$H+} interface uses Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls, ExtCtrls; type { TForm1 } TForm1 = class(TForm) Button1: TButton; Memo1: TMemo; //поле, где отображаются координаты точки пересечения PaintBox1: TPaintBox; procedure Button1Click(Sender: TObject); procedure PaintBox1MouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); //определяет координаты курсора procedure PtL(cx,cy,ex,ey:double;var ap, bp, cp:double); function LtP(a1,b1,c1,a2,b2,c2: double; var x,y:double):Boolean; function VM(ax,ay,bx,by:double): double; Function LC(x1,y1,x2,y2,x3,y3,x4,y4:integer): boolean; private { private declarations } public x1, y1 ,x2, y2, x3, y3, x4, y4 : integer; //точки,задающие 2 отрезка a, b, c, g, e, f :double; dx, dy, x, y:double; v1,v2,v3,v4: double; { public declarations } end; var Form1: TForm1; implementation {$R *.lfm} { TForm1 } function TForm1.VM(ax,ay,bx,by:double): double; //векторное произведение begin vm:= ax*by-bx*ay; end; Function TForm1.LC(x1,y1,x2,y2,x3,y3,x4,y4:integer): boolean; //проверка begin //пересечения v1:=vm(x4-x3,y4-y3,x1-x3,y1-y3); v2:=vm(x4-x3,y4-y3,x2-x3,y2-y3); v3:=vm(x2-x1,y2-y1,x3-x1,y3-y1); v4:=vm(x2-x1,y2-y1,x4-x1,y4-y1); if (v1*v2<0) and (v3*v4<0) then LC:= true else LC:= false end; //построение уравнения прямой procedure TForm1.PtL(cx,cy,ex,ey:double; var ap, bp, cp:double); begin ap:=ey-cy; bp:=cx-ex; cp:=-cx*(ey-cy)+cy*(ex-cx); end; //поиск точки пересечения Function TForm1.LtP(a1,b1,c1,a2,b2,c2: double; var x,y:double):Boolean; var d:double; begin d:=a1*b2-b1*a2; if LC(x1,y1,x2,y2,x3,y3,x4,y4) then begin LtP:=True; dx:=-c1*b2+b1*c2; dy:=-a1*c2+c1*a2; x:=dx/d; y:=dy/d; end else LtP:=False End; procedure TForm1.Button1Click(Sender: TObject); begin with Paintbox1.Canvas do begin //прорисовка отрезков Pen.Width:=2; Pen.Color:=clBlack; x1:=20; y1:=20; x2:=70; y2:=30; x3:=19; y3:=40; x4:=60; y4:=15; Line (x1, y1, x2, y2); Line (x3, y3, x4, y4); PtL( x1,y1,x2,y2,a,b,c); //строится уравнение прямой для каждого отрезка f:=a; e:=b; g:=c; PtL( x3,y3,x4,y4,a,b,c); if LtP(f,e,g,a,b,c,x,y) //проверка пересечения then begin Form1.Memo1.Clear; Form1.Memo1.Lines.Append(FloatToStr(x)); //вывод точки пересечения Form1.Memo1.Lines.Append(FloatToStr(y)); end else ShowMessage('no crossing');//если не пересекаются:вывод сообщения end; end; procedure TForm1.PaintBox1MouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin caption:= 'X:'+IntToStr(x) +' Y:'+ IntToStr(y); end; end.
Прикрепленный файл | Размер |
---|---|
CrossingPoint.rar | 1.77 Мб |