unit U_Geometry4_mX47; //http://www.delphiforfun.org/programs/Library/geometry1.htm {Copyright © 2002-2008, Gary Darby, www.DelphiForFun.org This program may be used or modified for any non-commercial purpose so long as this original notice remains in place. All other rights are reserved } {Test some routines from UGeometry to compute geometric properties of lines and polygons: 1. Intersect - reports whether two line segments intersect. 2. PointPerpendicularLine - defines the point of intersection on a given line of a line through a given point and intersecting the given line at a 90 degree angle. 3. AngledLineFromLine - computes other end of a line segment drawn from a given point of a given length and a given angle to another line segment (or its extension). 4. Point In Polygon - determines where a given point is in relation to a given polygon. Works by extending a line from the point to "infinity" and counting the number of times that the line intersects a polygon edge. (Odd count=inside, even count=outside) 5. InflatePolygon - changes size of a polygon by a given amount, also uses Polygonarea function to determine which way the polygon was built (afffect whether edges must move right or left from original position. Version 4 adds: 6. Line Translation and Rotation - Illistrates the basic operations of moving (translating) the line to new left end (P1) coordinates and rotating the right end of a line (P2) about the left end. 7. Circle intersection - Find and draws the intersection points of 2 intersecting circles. 8, Point-Circle Tangents - Calulates and draws the tangent lines from a given circle to a given exterior point. 9, Circle-Circle Exterior Tangents - Illustrates the algorithm for determing the points of tangency for the exterior tangent lines between two circles. Note: Image1 is canvas NOT Form1 } interface {uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls, StdCtrls, ComCtrls, Spin, Shellapi, UGeometry;} type TTdrawmode=(startingline, endingline , resetmode ); TTWorkMode=(aNone, Sizing, Drag, Drawdot); TForm1 = TForm; var Image1: TImage; Label2: TLabel; ResultLbl: TLabel; PageControl1: TPageControl; IntersectSheet: TTabSheet; PerpSheet: TTabSheet; ClearBtn: TButton; aMemo1: TMemo; aMemo2: TMemo; AngleSheet: TTabSheet; DistEdt: TSpinEdit; Memo3: TMemo; RightLeftBox: TRadioGroup; Label1: TLabel; Label3: TLabel; AngleEdt: TSpinEdit; AdjustBox: TCheckBox; PointInPolySheet: TTabSheet; Memo4: TMemo; AlignGrp: TRadioGroup; StaticText1: TStaticText; AlignGrpIL: TRadioGroup; InflateSheet: TTabSheet; Memo5: TMemo; Label4: TLabel; InflateBy: TSpinEdit; Label5: TLabel; AreaLbl: TLabel; TangentPC: TTabSheet; LineManip: TTabSheet; Memo6: TMemo; SpinEdit2: TSpinEdit; Label6: TLabel; Label7: TLabel; Label8: TLabel; TranslateBtn: TButton; RotateBtn: TButton; SpinEdit1: TSpinEdit; SpinEdit3: TSpinEdit; Label9: TLabel; Label10: TLabel; Memo7: TMemo; Memo8: TMemo; CircleCircleIntersectSheet: TTabSheet; Memo9: TMemo; CCIntersectBtn: TButton; Memo10: TMemo; PointTanBtn: TButton; TabSheet1: TTabSheet; Memo11: TMemo; CircCircTanBtn: TButton; procedure FormActivate(Sender: TObject); procedure Image1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); procedure Image1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure Image1MouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure ClearBtnClick(Sender: TObject); procedure AlignGrpClick(Sender: TObject); procedure StaticText1Click(Sender: TObject); procedure InflateByChange(Sender: TObject); procedure TranslateBtnClick(Sender: TObject); procedure RotateBtnClick(Sender: TObject); procedure CCIntersectBtnClick(Sender: TObject); procedure PointTanBtnClick(Sender: TObject); procedure CircCircTanBtnClick(Sender: TObject); //public var L1,L2,L3:Tline; dragval:integer; moved:boolean; startPoint:TPoint; pointColor:TColor; Points:array of TPoint; nbrpoints:integer; {# of points in the polygon} alignval:integer; {grid alignment for polygon points} workingon:integer; working:TTWorkMode; nbrdefined:integer; circles:array[1..2] of TCircle; procedure reset; procedure EraseLine(L:TLine); Procedure DrawIntersecting; procedure drawpoint(p:TPoint; Pcolor:TColor); procedure drawline(L:TLine); Procedure drawpoly(const points:array of TPoint; const color:TColor; const erase:boolean); function IsInCircle(x,y:integer):integer; procedure drawcircle(const C:TCircle; const pencolor:TColor); procedure erasecircle(C:TCircle); //end; var Form1: TForm1; implementation //{$R *.DFM} //uses math; {**************** FormActivate ****************} procedure FormActivate(Sender: TObject); begin randomize; form1.doublebuffered:=true; pagecontrol1.activepage:= TangentPC; reset; end; {*********** reset *******} procedure reset; begin dragval:=0; nbrpoints:=0; moved:=false; nbrdefined:=0; working:=anone; workingon:=0; if pagecontrol1.activepage=IntersectSheet then aligngrpclick(aligngrpIL) else if (pagecontrol1.activepage=PointInPolySheet) then aligngrpclick(aligngrp) else alignval:=1; image1.canvas.fillrect(image1.clientrect); resultlbl.caption:=''; arealbl.caption:=''; end; {************** DrawPoint ***********} procedure drawpoint(p:TPoint;PColor:TColor); var save:TColor; begin with image1, image1.canvas do begin save:=brush.Color; brush.Color:=PColor; ellipse(p.x-3,p.y-3, p.x+3,p.y+3); brush.Color:=save; end; end; {************** DrawLine ***********} procedure drawLine(L:TLine); begin with image1, image1.canvas, L do begin moveto(p1.x,p1.y); lineto(p2.x,p2.y); drawpoint(l.p1,clgreen); drawpoint(l.p2,clred); end; end; {************** EraseLine ***********} procedure EraseLine(L:TLine); var save:TColor; begin with image1, image1.canvas, L do begin save:=brush.color; brush.color:=clwhite; pen.color:=clwhite; moveto(p1.x,p1.y); lineto(p2.x,p2.y); drawpoint(l.p1,clwhite); drawpoint(l.p2,clwhite); pen.color:=clblack; brush.color:=save; end; end; {************* DrawCircle *********} procedure drawcircle(const C:TCircle; const pencolor:TColor); begin with c, image1.canvas do begin pen.color:=penColor; brush.style:=bsClear; ellipse(cx-r,cy-r,cx+r,cy+r); brush.Color:=clred; ellipse(cx-4,cy-4,cx+4,cy+4); brush.color:=clwhite; end; end; {************ EraseCircle ********} procedure erasecircle(C:TCircle); begin with C, Image1.canvas do begin pen.color:=clwhite; brush.Color:=clwhite; ellipse(cx-r,cy-r,cx+r,cy+r); end; end; {***************** DrawPoly *************} procedure drawpoly(const points:array of TPoint; const color:TColor; const erase:boolean); var i:integer; begin with image1.canvas do begin If erase then fillrect(image1.clientrect); pen.color:=color; polyline(Points); with points[high(points)] do moveto(x,y); with points[0] do lineto(x,y); {close the drawing} end; for i:=0 to high(points) do drawpoint(points[i],clgreen); end; {************** DrawIntersecting *********} procedure Drawintersecting; var r,pb:boolean; IP:TPoint; s:string; begin with image1, image1.canvas do begin fillrect(clientrect); case dragval of 1,2: begin moveto(l1.p1.x, l1.p1.y); lineto(l1.p2.x, L1.p2.y); drawpoint(l1.p1,clgreen); drawpoint(l1.p2,clred); end; 3: begin moveto(l1.p1.x, l1.p1.y); lineto(l1.p2.x, L1.p2.y); drawpoint(l1.p1,clgreen); drawpoint(l1.p2,clred); moveto(L2.p1.x, L2.p1.y); lineto(L2.p2.x, L2.p2.y); drawpoint(l2.p1,clgreen); drawpoint(l2.p2,clred); r:= intersect(l1,l2,pb,IP) ; s:='('+inttostr(ip.x)+','+inttostr(ip.Y)+') '; if r and pb then s:=s+'Intersection point on border' else if r then s:=s+'Lines cross' else s:='No intersect'; resultLbl.caption:=s; end; end; end; end; {************** IsInCircle **********} function IsInCircle(x,y:integer):integer; var i:integer; begin result:=0; for i:=1 to nbrdefined do with circles[i] do begin if intdist(point(cx,cy),point(x,y))1 then begin p.x:=round(p.x / alignval)*alignval; p.y:=round(p.y / alignval)*alignval; mouse.cursorpos:=image1.clienttoscreen(p); end; end else if (activepage=PerpSheet) or (activepage=AngleSheet) then begin //fix //if ((activepage=PerpSheet) or (activepage=AngleSheet)) and (dragval=1) then begin case dragval of 0: begin {1st point} L1.p1:=point(x,y); dragval:=1; pointcolor:=clgreen; end; 1,2: begin L2.p1:=point(x,y); dragval:=2; pointcolor:=clred; end; end; {case} end else if (activepage=pointinPolySheet) or (activepage=InflateSheet) then begin {For Polygon inflation, start a new polygon on next click after polygon was closed} if (activepage=InflateSheet) and (dragval=3) then dragval:=0; aligngrpclick(aligngrp); p:=point(x,y); if alignval>1 then begin p.x:=round(p.x / alignval)*alignval; p.y:=round(p.y / alignval)*alignval; mouse.cursorpos:=image1.clienttoscreen(p); end; case dragval of 0: {start a polygon} begin setlength(points,2); points[0]:=point(p.x,p.y); nbrpoints:=2; dragval:=1; end; 1: {continue or close a polygon} begin inc(nbrpoints); setlength(points,nbrpoints); points[nbrpoints-1]:=p; if intdist(points[0],p)<7 then begin dec2(nbrpoints,2); setlength(points,nbrpoints); {points[nbrpoints]:=points[1];} dragval:=2; drawpoly(points,clblack,true); end; end; end; {case} end else if pagecontrol1.activepage=linemanip then begin if dragval=0 then begin reset; L1.p1:=point(x,y); dragval:=1; pointcolor:=clgreen; end; end else if pagecontrol1.activepage=TangentPC then begin workingon:=Isincircle(x,y); if (workingon=0) then begin if (nbrdefined<2) then begin working:=sizing; inc(nbrdefined); workingon:=nbrdefined; end end else with circles[workingon] do begin if intdist(point(cx,cy),point(x,y))<5 then working:=drag else working:=sizing; end; with circles[workingon] do begin cx:=x; cy:=y; if working=sizing then r:=4; //fix with mouse do setcursorpos(cursorpos.x+4,cursorpos.Y); end; drawcircle(circles[workingon],clblack); end; end; end; (* {*************** PaintBox1MouseMove **************} procedure TForm1.PaintBox1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); begin if working <>none then with paintbox1, canvas, circle[workingon] do begin erasecircle(workingon); if working=sizing then r:=radius(cx,cy,x,y) else begin cx:=x; cy:=y; end; drawcircle(workingon); case workingon of 1: begin if nbrdefined>1 then maketangents(1,2); if nbrdefined>2 then maketangents(1,3); end; 2:begin maketangents(1,2); if nbrdefined>2 then maketangents(2,3); end; 3: begin maketangents(1,2); maketangents(2,3); end; end; end; paintbox1.invalidate; end; {************* PaintBoxMouseUp ****************} procedure TForm1.PaintBox1MouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); var p:TPoint; begin working:=none; end; end; end; {If activepage= } end; *) {******************** Image1MouseMove **********************} procedure Image1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); var p:TPoint; begin p:=point(x,y); if alignval>1 then begin p.x:=round(p.x / alignval)*alignval; p.y:=round(p.y / alignval)*alignval; end; label2.caption:='X:'+inttostr(p.x)+' Y:'+inttostr(p.y); {if ssleft in shift then} begin with pagecontrol1 do begin if ((activepage=PerpSheet) or (activepage=AngleSheet)) and (dragval=1) then begin //fix label2.caption:='X:'+inttostr(x)+' Y:'+inttostr(y); if not moved then begin{first time just draw the start point} drawpoint(startpoint,pointcolor); moved:=true; end; L1.p2:=point(x,y); image1.canvas.fillrect(image1.clientrect); {erase the image} drawline(L1); end else if (activepage=Linemanip) and (dragval=2) then begin label2.caption:='X:'+inttostr(x)+' Y:'+inttostr(y)+ ', dv='+inttostr(dragval); if not moved then begin {first time just draw the start point} drawpoint(startpoint,pointcolor); moved:=true; end; L1.p2:=point(x,y); image1.canvas.fillrect(image1.clientrect); {erase the image} drawline(L1); end; end; end; if pagecontrol1.activepage=IntersectSheet then begin label2.caption:='X:'+inttostr(p.x)+' Y:'+inttostr(p.y); if (dragval>0) and (not moved) then {first time just draw the start point} begin drawpoint(startpoint,pointcolor); moved:=true; end; case dragval of 1:L1.p2:=point(x,y); 3:L2.p2:=point(x,y); end; If dragval>0 then drawintersecting; end; {-------- mouse move - PointInPoly} if (pagecontrol1.activepage=pointinpolySheet) or (pagecontrol1.activepage=InflateSheet) then begin if (dragval=1) and (nbrpoints>=2) then begin try points[nbrpoints-1]:=p; drawpoly(points,clBlack,true); except writeln('PointinpolySheet Exception '+ExceptionToString(ExceptionType,ExceptionParam)); end end; //writeln('debug: activepage=pointinpolySheet') end else if pagecontrol1.activepage=TangentPC then begin if working <> anone then with circles[workingon] do begin erasecircle(circles[workingon]); if working=sizing then r:=intdist(point(cx,cy),point(x,y)) else begin cx:=x; cy:=y; end; drawcircle(circles[workingon],clBlack); end; end; end; {***************** Image1MouseUp **************} procedure Image1MouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); var a:extended; p:TPoint; n:PPResult; s:string; aV:integer; //check Points2:array of TPoint; Area, area2:integer; clockwise:boolean; begin if pagecontrol1.activepage=IntersectSheet then begin p:=point(x,y); if alignval>1 then begin p.x:=round(p.x / alignval)*alignval; p.y:=round(p.y / alignval)*alignval; mouse.cursorpos:=image1.clienttoscreen(p); end; case dragval of 0: begin L1.p1:=point(x,y); dragval:=1; pointcolor:=clgreen; end; 1: {Draw first line} begin L1.p2:=point(p.x,p.y); drawline(L1); dragval:=2; end; 2: begin {start drawing second line} L2.p1:=point(p.x,p.y); dragval:=3; moved:=false; pointcolor:=clred; end; 3: begin L2.p2:=point(p.x,p.y); DrawIntersecting; dragval:=0; end; end; end else if pagecontrol1.activepage=PerpSheet then begin if dragval=2 then begin l2.p1:=point(x,y);{assume user wants the perp start point to be mouseup point} L2:=pointperpendicularLine(L1,L2.p1); drawline(l2); end; writeln('debug: activepage=PerpSheet') end else if pagecontrol1.activepage=AngleSheet then begin if dragval=2 then dragval:=3 {end of initial base line} else if dragval=3 then begin l2.p1:=point(x,y); {assume user wants the angle start point to be mouseup point} a:=angleEdt.value/180*Pi; {default, increase angle (counter clockwise)} if rightleftbox.itemindex=0 then a:=-a; {right reduces andgle} if adjustbox.checked then begin {drop perp from pt to line first} L2:=pointperpendicularLine(L1,L2.p1); l2.p1:=l2.p2; {and make that the new line start point} end; L2:=AngledLineFromLine(L1,L2.P1,distedt.value,a); drawline(l2); end; end else If pagecontrol1.activepage = PointInPolySheet then begin {find out if this point is inside or outside of polygon} If dragval=2 then dragval:=3 {Ignore the 1st mouse up after closing poly} else if dragval=3 then begin if (nbrpoints>2) then begin p:=point(x,y); if alignval>1 then begin p.x:=round(p.x / alignval)*alignval; p.y:=round(p.y / alignval)*alignval; mouse.cursorpos:=image1.clienttoscreen(p); end; n:=pointinpoly(p, points); drawpoly(points,clBlack,true); drawpoint(p,clgreen); case n of PPoutside:s:='Point is outside of polygon'; PPInside: s:='Point is inside polygon'; PPVertex: s:='Point is on a vertex'; PPEdge: s:='Point is on an edge, not at vertex'; PPError: s:='Cannot determine where the heck that point is'; end; resultLbl.caption:=s; end; end; end else If pagecontrol1.activepage=InflateSheet then begin If (dragval=2) or (sender = InflateBy) then begin if sender = Image1 then dragval:=3; if (nbrpoints>2) then begin p:=point(x,y); av:=inflateby.value; setlength(points2,nbrpoints); //InflatePolygon(const points:array of Tpoint;var points2:array of TPoint;var area:Int //;const screenCoordinates:bool; const inflateby : Int); //InflatePolygon(points,points2,area, {screencoordinates} true, av); fix area2:=Polygonarea(points2, {screencoordinates}true, clockwise); Arealbl.caption:= 'Area: Original '+inttostr(area) + ', New '+inttostr(area2); drawpoly(points,rgb(255,221,221),{erase first=} true); {draw the previous polygon} drawpoly(points2,clBlack,false); {draw the new polygon} end; end; end else if Pagecontrol1.activepage=Linemanip then begin l1.p2:=point(x,y); inc(dragval); if dragval>2 then dragval:=0; //;;else dragval:=0;; drawline(L1); end else if pagecontrol1.ActivePage=TangentPC then begin working:=anone; end; end; {***************** ClearBtnClick ************} procedure ClearBtnClick(Sender: TObject); begin reset; end; {*********************** AlignGrpBtnClick ***********} procedure AlignGrpClick(Sender: TObject); begin if sender<>nil then begin //With sender as TRadioGroup do With TRadioGroup(sender) do case itemindex of 0: alignval:=1; 1: alignval:=5; 2: alignval:=10; end; end else alignval:=1; end; {************ InflatebyChange *********} procedure InflateByChange(Sender: TObject); begin Image1MouseUp(InflateBy,mbleft,[],0,0); end; {************** TranslateBtnClick *************8} procedure TranslateBtnClick(Sender: TObject); begin eraseline(L1); TranslateLeftTo(L1,point(spinedit1.Value, spinedit2.value)); Drawline(L1); end; {************ RotatebtnClick ***********} procedure RotateBtnClick(Sender: TObject); begin memo7.clear; eraseline(L1); with L1 do begin p1.y:=-p1.y; {adjust y values so up ==> increasing Y} p2.y:=-p2.y; RotateRightEndTo(L1, degtorad(spinedit3.value)); p1.y:=-p1.y; {readjust to screen coordinates (up=decreasing Y) } p2.y:=-p2.y; end; DrawLine(L1); end; function LineI(const p1,p2:TPoint):Tline; {Make a Tline record from two points} begin result.p1:=p1; result.p2:=p2; end; function LineR(const p1,p2:TRealPoint):TRealline; {Make a Tline record from two points} begin result.p1:=p1; result.p2:=p2; end; {***************** CCIntersectBtnClick *************} procedure CCIntersectBtnClick(Sender: TObject); {Circle-Circle intersections} var i:integer; Ip1,Ip2,tmp:TPoint; begin reset; nbrdefined := 2; (*for i:= 1 to 2 do {define 2 random circles resonably sized and spaced} with circles[i], image1 do begin cx:= random(width div 2)+ width div 3; cy:= random(width div 2)+ width div 3; r:=random(width div 3) + 20; drawcircle(circles[i],clBlack); end; // *) for i:= 1 to 2 do begin {define 2 random circles resonably sized and spaced} //with circles[i], image1 do begin circles[i].cx:= random(image1.width div 2)+ image1.width div 3; circles[i].cy:= random(image1.width div 2)+ image1.width div 3; circles[i].r:=random(image1.width div 3) + 20; drawcircle(circles[i],clBlack); end; // *) (* {debug} reset; with circle[1] do begin cx:=130; cy:= 130; r:=130; end; with circle[2] do begin cx:=170; cy:= 200; r:=100; end; drawcircle(circle[1]); drawcircle(circle[2]); *) memo10.lines.add(format('C1: (%d, %d) Radius= %d, C2:(%d, %d),Radius= %d', [circles[1].cx, circles[1].cy, circles[1].r, circles[2].cx, circles[2].cy, circles[2].r])); for i:=1 to 2 do with circles[i] do cy:=-cy; if circlecircleintersect(circles[1],circles[2],Ip1,Ip2) then begin ip1.y:=-ip1.y; ip2.y:=-ip2.y; for i:=1 to 2 do with circles[i] do cy:=-cy; //tmp:= point(circles[1].cx,circles[1].cy); //drawline(Ip1); drawline(lineI(point(circles[1].cx,circles[1].cy),Ip1)); //drawline(Ip1); drawline(lineI(point(circles[1].cx,circles[1].cy),Ip2)); memo10.lines.add (format('Intersections at (%d,%d) and (%d,%d)', [Ip1.x, Ip1.Y, Ip2.x, Ip2.Y])); end else memo10.lines.add('No intersection');; memo10.Lines.add('------------------------'); end; procedure StaticText1Click(Sender: TObject); begin //ShellExecute(Handle, 'open', 'http://www.delphiforfun.org/', //nil, nil, SW_SHOWNORMAL) ; openWeb('http://www.delphiforfun.org/'); end; function CircleI(const cx,cy,R:integer):TCircle; {Make a TCircle record using passed center and radius} begin result.cx:=cx; result.cy:=cy; result.r:=r; end; function CircleR(const cx,cy,R:extended):TRealCircle; {Make a TCircle record using passed center and radius} begin result.cx:=cx; result.cy:=cy; result.r:=r; end; {**************** PointTanbtnClick ****************} procedure PointTanBtnClick(Sender: TObject); {Tangent from exterior point to circle} var d:integer; p,pc, m, Ip1, Ip2:TPoint; L,L1,L2,l3:TLine; C1,C2:TCircle; begin reset; nbrdefined := 1; with circles[1], image1, image1.canvas do begin cx:= random(width div 2)+ width div 3; cy:= random(width div 2)+ width div 3; r:=random(width div 3) + 20; drawcircle(circles[1],clBlack); textout(cx-8,cy-8,'C'); pc:=point(cx,cy); repeat p.X:=random(width); p.y:=random(height); d:=intdist(p,pc) until d>r+10; L:=lineI(pc,p); drawline(L); textout(p.x-8,p.y-8,'P'); image1.update; sleep(1000); {To find the points of tangency:} {1. find the midpoint,M, of line L} {2. define the circle, C1, centered on M through the endpoints of L} {3 define the circle, C2, centerd on the original circlem Circle[1]} {4. Find the intersection point of C1 and C2, call them IP1 and IP2} {5. Define the tangent lines, L2, L3, from the point P through IP1 and IP2} {1} M:=point((cx+p.x) div 2, (cy+p.Y) div 2); {2} C1:=CircleI(m.x, m.y, d div 2); textout(m.x,m.y,'M'); Drawcircle(C1, Clred); {3} C2:=Circles[1]; {4} if circleCircleIntersect(C1,C2,Ip1,Ip2) then begin image1.update; sleep(1000); L1:=lineI(P,Ip1); L2:=LineI(P,Ip2); //if PointCircleTangentLines(Circles[1],P, L1,L2) then //begin {PointCircleTangentLines function code embedded here to allow display of intermediate results} pen.color:=clgreen; pen.width:=2; Drawline(L1); textout(L1.p2.x,l1.p2.y-12,'IP1'); {Extend the l1 tangent line by 50 pixels} l3:=l1; extendline(L3,50); l3.p1:=l1.p2; drawline(l3); pen.width:=1; Drawline(lineI(pc,ip1)); image1.update; sleep(500); pen.width:=2; Drawline(L2); textout(L2.p2.x,l2.p2.y+12,'IP2'); {Extend the L2 tangent line by 50 pixels} l3:=l2; extendline(L3,50); l3.p1:=l2.p2; drawline(l3); pen.width:=1; Drawline(lineI(pc,ip2)); end; end; end; procedure screenDrawLine(L:TLine); {Invert Y axis values for drawing on screen} begin with L do drawline(lineI(point(p1.x,-p1.y),point(p2.x,-p2.y))); end; {*************** CircCircTanBtnClick *****************} procedure CircCircTanBtnClick(Sender: TObject); {Draw two random circles and their exterior tangents} (* procedure screenDrawLine(L:TLine); {Invert Y axis values for drawing on screen} begin with L do drawline(line(point(p1.x,-p1.y),point(p2.x,-p2.y))); end; *) var c1,c2,c3:TCircle; pc:TPoint; d:extended; L1,L2,Pl1,Pl2,TL1,TL2, extline:TLine; loops:integer; begin reset; with c1, image1 do repeat cx:= random(width div 2)+ width div 3; cy:= random(width div 2)+ width div 3; r:=random(width div 3) + 20; pc:=point(cx,cy); with c2 do begin loops:=0; repeat cx:= random(width div 2)+ width div 3; cy:= random(width div 2)+ width div 3; r:=random(width div 3) + 20; d:=intdist(point(cx,cy),pc); inc(loops); until (d>c2.r+c1.r) or (loops>100); end; until d>c1.r+c2.r; (* {debug} c1:=circle(100,100,100); c2:=circle(300,100,50); *) If CircleCircleExtTangentLines(C1,C2,C3,L1,L2,Pl1,Pl2,TL1,Tl2) then begin with image1, image1.canvas do begin drawcircle(c1,clGreen); with c1 do textout(cx+8,cy+8,'C1'); drawcircle(c2,clRed); with c2 do textout(cx+8,cy+8,'C2'); drawcircle(C3,clyellow); drawline(L1); drawline(L2); pen.color:=cllime; DrawLine(pl1); pen.color:=clblue; {extend the tangent line a little for visual effect} extline:=TL1; extendline(Extline,50); {make the line just the extension do that tangency point still shows up} extline.p1:=tl1.p2; DrawLine(TL1); Drawline(Extline); {do the 2nd tangent line} pen.color:=cllime; drawline(Pl2); pen.color:=clblue; {extend the tangent line a little for visual effect} extline:=TL2; extendline(Extline,50); {make the line just the extension do that tangency point still shows up} extline.p1:=tl2.p2; DrawLine(TL2); Drawline(Extline); end; end; end; procedure loadGeometerForm; begin Form1:= TForm1.create(self); with form1 do begin Left := 183 Top := 77 Width := 996 Height := 700 Anchors := [akLeft, akTop, akRight, akBottom] Caption := 'A Little Computational Geometry V4.0 maXbox4' Color := clBtnFace Font.Charset := DEFAULT_CHARSET Font.Color := clWindowText Font.Height := -13 Font.Name := 'MS Sans Serif' Font.Style := [] Icon.LoadFromResourceName(HInstance,'ZHISTOGRAM'); //ZCUBE OldCreateOrder := False Position := poScreenCenter //OnActivate := @FormActivate ; PixelsPerInch := 120 //TextHeight := 16 Show;//*) //end; Image1:= TImage.create(form1) with image1 do begin parent:= form1; Left := 552 Top := 56 Width := 401 Height := 409 OnMouseDown := @Image1MouseDown; OnMouseMove := @Image1MouseMove; OnMouseUp := @Image1MouseUp; end; Label2:= TLabel.create(form1) with label2 do begin //X,Y monitor parent:= form1 Left := 555 Top := 16 Width := 3 Height := 16 end; //object ResultLbl: TLabel ResultLbl:= TLabel.create(form1) with ResultLbl do begin parent:= form1 Left := 552 Top := 480 Width := 401 Height := 89 AutoSize := False Caption := 'Results: ' Font.Charset := DEFAULT_CHARSET Font.Color := clWindowText Font.Height := -19 Font.Name := 'MS Sans Serif' Font.Style := [fsBold] ParentFont := False WordWrap := True end ; //object AreaLbl: TLabel areaLbl:= TLabel.create(form1) with areaLbl do begin parent:= form1 Left := 704 //704 Top := 16 //16 Width := 31 Height := 16 Caption := 'Area:' Font.Charset := DEFAULT_CHARSET Font.Color := clWindowText Font.Height := -13 Font.Name := 'Arial' Font.Style := [] ParentFont := False end; PageControl1:= TPageControl.create(form1) with pagecontrol1 do begin parent:= form1 Left := 32 Top := 32 Width := 505 Height := 577 ActivePage := PerpSheet Font.Charset := DEFAULT_CHARSET Font.Color := clWindowText Font.Height := -13 Font.Name := 'Arial' Font.Style := [] ; //TCustomTabControl(pagecontrol1).MultiLine := True ParentFont := False TabOrder := 0 OnChange := @ClearBtnClick ; IntersectSheet:= TTabSheet.create(form1) with IntersectSheet do begin parent:= pagecontrol1 pagecontrol:= pagecontrol1; Caption := '1. Intersecting lines' ImageIndex := 1 aMemo1:= TMemo.create(form1) with amemo1 do begin parent:= intersectsheet; Left := 16 Top := 8 Width := 353 Height := 209 Color := 14548991 Lines.add( 'Click define start drawing a line, click ' +'again to dend the line. Repeat to draw a ' +'second line. ' +''+CRLF+ CRLF+ 'Aend points alignment may be aligned ' +'on 5 or 10 pixel boundaries by using the ' +'"Point alignment" box.' +' '+CRLF+ 'Program will report whether lines ' +'intersect. (Easy for humans, not so ' +'easy for programs.)' +'') TabOrder := 0 end; AlignGrpIL:= TRadioGroup.create(form1) with aligngrpil do begin parent:= intersectsheet; Left := 32 Top := 240 Width := 185 Height := 81 Caption := 'Point alignment' ItemIndex := 0 Items.add ('1 pixel') items.add('5 pixel boundaries') items.add('10 pixel boundaries') ItemIndex := 1 TabOrder := 1 OnClick := @AlignGrpClick; end; end; //IntersectSheet PerpSheet:= TTabSheet.create(form1) with perpsheet do begin parent:= pagecontrol1; pagecontrol:= pagecontrol1; Caption := '2. Perpendicular from point to line' ImageIndex := 2 aMemo2:= TMemo.create(form1) with amemo2 do begin parent:= perpsheet; Left := 24 Top := 16 Width := 305 Height := 145 Color := 14548991 Lines.add( 'Click to start drawing a baseline, click ' +'again to dend the line, then click ' +'at some points not on the line. ' +''+CRLF +'Program will draw lines from the ' +'clicked points and perpendicular to ' +'the original base line. ' +' ') TabOrder := 0 end; end; AngleSheet:= TTabSheet.create(form1) with anglesheet do begin parent:= pagecontrol1 pagecontrol:= pagecontrol1 Caption := '3. Angle from point on line for distance' ImageIndex := 2 Label1:= TLabel.create(form1) with label1 do begin parent:= anglesheet; Left := 16 Top := 272 Width := 63 Height := 16 Caption := 'Line length' end; Label3:= TLabel.create(form1) with label3 do begin parent:= anglesheet; Left := 16 Top := 304 Width := 117 Height := 16 Caption := 'Line angle (degrees)' end; DistEdt:= TSpinEdit.create(form1) with distedt do begin parent:= anglesheet; Left := 152 Top := 272 Width := 57 Height := 26 MaxValue := 200 MinValue := 0 TabOrder := 0 Value := 25 end; Memo3:= TMemo.create(form1) with memo3 do begin parent:= anglesheet; Left := 16 Top := 0 Width := 289 Height := 217 Color := 14548991 Lines.add( 'Click to define the start point of a ' +'baseline, cliick again to dend the line. Then ' +'click any location on or near the line. ' +'' +CRLF+CRLF +'This procedure generates a line of the ' +'specified length at the specified angle to ' +'the reference line and on the specified ' +'side. ' +''+CRLF+CRLF +'The "side" of the line, right or left is as ' +'viewed by a observer walking the reference ' +'line from the initial point. ') TabOrder := 1 end; RightLeftBox:= TRadioGroup.create(form1) with rightleftbox do begin parent:= anglesheet; Left := 16 Top := 224 Width := 249 Height := 41 Caption := 'Which side of line?' Columns := 2 ItemIndex := 0 Items.add('Right') items.add('Left') ItemIndex := 0 TabOrder := 2 end; //object AngleEdt: TSpinEdit angleEdt:= TSpinEdit.create(form1) with angleedt do begin parent:= anglesheet; Left := 152 Top := 304 Width := 57 Height := 26 MaxValue := 180 MinValue := 0 TabOrder := 3 Value := 45 end; AdjustBox:= TCheckBox.create(form1) with adjustbox do begin parent:= anglesheet; Left := 24 Top := 336 Width := 201 Height := 17 Caption := 'Adjust 1st point to lie on liine' Checked := True State := cbChecked TabOrder := 4 end; end; PointInPolySheet:= TTabSheet.create(form1) with PointInPolySheet do begin parent:= pagecontrol1 pagecontrol:= pagecontrol1 Caption := '4. Point In Polygon' ImageIndex := 3 Memo4:= TMemo.create(form1) with memo4 do begin parent:= pointinpolysheet Left := 8 Top := 24 Width := 361 Height := 257 Color := 14548991 Lines.add( 'Click to start a polygon and click at each ' +'corner. Polygon will be automatically ' +'closed when you click near the starting ' +'point.' +'' +'Then click additional points and displayed ' +'message will tell you if you are inside the ' +'polygon, outside the polygon, on a vertex, ' +'or on the border but not on a vertex. ' +' ' +'Algorithm works by extending a line from ' +'the point to infinity and counting the number ' +'of polygon edges that are intersected. ' +'Odd count :=inside, even count := outside! ') TabOrder := 0 end; AlignGrp:= TRadioGroup.create(form1) with aligngrp do begin parent:= pointinpolysheet; Left := 16 Top := 328 Width := 185 Height := 81 Caption := 'Point alignment' ItemIndex := 0 Items.add ('1 pixel') items.add('5 pixel boundaries') items.add('10 pixel boundaries'); ItemIndex := 1 TabOrder := 1 OnClick := @AlignGrpClick end; end; //object InflateSheet: TTabSheet InflateSheet:= TTabSheet.create(form1) with InflateSheet do begin parent:= pagecontrol1 pagecontrol:= pagecontrol1 Caption := '5. Inflate Polygon' ImageIndex := 4 Label4:= TLabel.create(form1) with label4 do begin parent:= inflatesheet; Left := 48 Top := 390 Width := 65 Height := 20 Caption := 'Inflate by' Font.Charset := DEFAULT_CHARSET Font.Color := clWindowText Font.Height := -16 Font.Name := 'MS Sans Serif' Font.Style := [] ParentFont := False end; Label5:= TLabel.create(form1) with label5 do begin parent:= inflatesheet; Left := 168 Top := 390 Width := 39 Height := 20 Caption := 'pixels' Font.Charset := DEFAULT_CHARSET Font.Color := clWindowText Font.Height := -16 Font.Name := 'MS Sans Serif' Font.Style := [] ParentFont := False end; Memo5:= TMemo.create(form1) with memo5 do begin parent:= inflatesheet; Left := 8 Top := 8 Width := 281 Height := 361 Color := 14548991 Lines.add( 'Click the image area at right to start a ' +'polygon and click at each corner. Polygon ' +'will be automatically closed when you click ' +'near the starting point.' +'' +'When the polygon is closed, it will be' +'inflated (or deflated) by the pixel value' +'given below. Negative values will reduce the' +'polygon size. The value given is the ' +'perpendular pixel distance from each existing ' +'edge to the new edge. Clicking the up/down ' +'arrows on the value below will redraw the ' +'polygon inflated by the new value.' +'' +'Algorithm works by finding points at the ' +'perpendicular distance from each aend of each ' +'edge. This defines slope and intercept of a ' +'new edge line (but probably not intersecting). ' +'We then extend each adjacent pair of lines if ' +'necessay to find the intersection point which ' +'defines a new vertex for the inflated polygon. ') TabOrder := 0 end; InflateBy:= TSpinEdit.create(form1) with inflateby do begin parent:= inflatesheet; Left := 120 Top := 387 Width := 41 Height := 26 EditorEnabled := False MaxValue := 50 MinValue := -50 TabOrder := 1 Value := 10 OnChange := @InflateByChange end; end; //object LineManip: TTabSheet LineManip:= TTabSheet.create(form1) with LineManip do begin parent:= pagecontrol1 pagecontrol:= pagecontrol1 Caption := '6. Line Translate/Rotate' ImageIndex := 6 Label6:= TLabel.create(form1) with label6 do begin parent:= linemanip; Left := 24 Top := 208 Width := 134 Height := 16 Caption := 'Translate start point to:' end; Label7:= TLabel.create(form1) with label7 do begin parent:= linemanip; Left := 24 Top := 232 Width := 16 Height := 24 Caption := 'X' Font.Charset := DEFAULT_CHARSET Font.Color := clWindowText Font.Height := -19 Font.Name := 'MS Sans Serif' Font.Style := [fsBold] ParentFont := False end; Label8:= TLabel.create(form1) with label8 do begin parent:= linemanip; Left := 104 Top := 232 Width := 14 Height := 24 Caption := 'Y' Font.Charset := DEFAULT_CHARSET Font.Color := clWindowText Font.Height := -19 Font.Name := 'MS Sans Serif' Font.Style := [fsBold] ParentFont := False end; Label9:= TLabel.create(form1) with label9 do begin parent:= linemanip; Left := 24 Top := 280 Width := 155 Height := 16 Caption := 'Rotate about start point to:' end; Label10:= TLabel.create(form1) with label10 do begin parent:= linemanip; Left := 112 Top := 304 Width := 46 Height := 16 Caption := 'degrees' end; Memo6:= TMemo.create(form1) with memo6 do begin parent:= linemanip; Left := 56 Top := 8 Width := 289 Height := 185 Color := 14548991 Lines.add( 'Click to start a line. Move the mouse and click ' +'again to aend the line. ' +''+CRLF +'Buttons below wil translate or rotate the line,' +''+CRLF +'These routines to translate and rotates lines are ' +'required for the Circle-Circle intersection ' +'operations.') TabOrder := 0 end; SpinEdit2:= TSpinEdit.create(form1) with spinedit2 do begin parent:= linemanip; Left := 120 Top := 232 Width := 49 Height := 26 MaxValue := 0 MinValue := 0 TabOrder := 1 Value := 100 end; TranslateBtn:= TButton.create(form1) with translatebtn do begin parent:= linemanip; Left := 192 Top := 232 Width := 65 Height := 25 Caption := 'Go' TabOrder := 2 OnClick := @TranslateBtnClick end; rotateBtn:= TButton.create(form1) with rotatebtn do begin parent:= linemanip; Left := 192 Top := 304 Width := 65 Height := 25 Caption := 'Go' TabOrder := 3 OnClick := @RotateBtnClick end; SpinEdit1:= TSpinEdit.create(form1) with spinedit1 do begin parent:= linemanip; Left := 48 Top := 232 Width := 49 Height := 26 MaxValue := 0 MinValue := 0 TabOrder := 4 Value := 100 end ; SpinEdit3:= TSpinEdit.create(form1) with spinedit3 do begin parent:= linemanip; Left := 56 Top := 304 Width := 49 Height := 26 MaxValue := 360 MinValue := -360 TabOrder := 5 Value := 45 end; Memo7:= TMemo.create(form1) with memo7 do begin parent:= linemanip; Left := 8 Top := 352 Width := 281 Height := 97 Lines.add('line Line Translate/Rotate') TabOrder := 6 end; end; //object CircleCircleIntersectSheet: TTabSheet CircleCircleIntersectSheet:= TTabSheet.create(form1) with CircleCircleIntersectSheet do begin parent:= pagecontrol1 pagecontrol:= pagecontrol1 Caption := '7. Circle-Circle Intersection ' ImageIndex := 7 Memo9:= TMemo.create(form1) with memo9 do begin parent:= CircleCircleIntersectSheet; Left := 16 Top := 16 Width := 433 Height := 185 Color := 14548991 Lines.add(+CRLF+ 'Click the button below to generate 2 random circles and draw lin' + +'es from ' +'center of the fiirst circle to the interesction points with the ' + +'second (if they ' +'intersect). Circle-Circle intersection operations are require' + +'d when ' +'calculating tangent lines for circles.' +''+CRLF+CRLF +'The algorithm requires translating and rotating the line connect' + +'ing the ' +'cirlce centers to (0,0) origin and 0 degree angle. Realtively s' + +'imple ' +'equations then allow the intersection point coordinates to be ca' + +'lculated, ' +'after which the lines from the origin to the intersection points' + +' can be ' +'rotated and translated back to the original origin and orientati' + +'on. ') TabOrder := 0 end; CCIntersectBtn:= TButton.create(form1) with ccintersectbtn do begin parent:= CircleCircleIntersectSheet; Left := 16 Top := 224 Width := 225 Height := 25 Caption := 'Generate && test 2 random circles ' TabOrder := 1 OnClick := @CCIntersectBtnClick end; Memo10:= TMemo.create(form1) with memo10 do begin parent:= CircleCircleIntersectSheet; Left := 8 Top := 272 Width := 449 Height := 201 Lines.add( 'this is memo10') ScrollBars := ssVertical TabOrder := 2 end; end; //object TangentPC: TTabSheet TangentPC:= TTabSheet.create(form1) with TangentPC do begin parent:= pagecontrol1 pagecontrol:= pagecontrol1 Caption := '8. Point-Circle Tangent' ImageIndex := 5 Memo8:= TMemo.create(form1) with memo8 do begin parent:= tangentpc Left := 24 Top := 16 Width := 401 Height := 321 Color := 14548991 Lines.add( 'Click the button below to draw a random circle and a random ' +'external point;' +''+CRLF+CRLF +'The algorithm is:' +''+CRLF+CRLF +'1. Define the line,L, from the point, P, to the circle center.' +'2. Find the midpoint, M, of line L}' +'3. Define the circle, C1, centered on M through the endpoints o' + +'f L.'+CRLF +'4, Define the circle, C2, to be the original circle with center' + +' a C.' +'5. Find the intersection points of C1 and C2, call them IP1 and' + +' ' +'IP2'+CRLF +'6. Define the tangent lines from P through IP1 and IP2' +'' +'Notice that angles (C,I P1,P) and (C,IP2,P) are inscribed angle' + +'s of ' +'C2 and are therefore right angles. This makes points IP1 and IP' + +'2 ' +'points of tangency by definition.' +'') TabOrder := 0 end; PointTanBtn:= TButton.create(form1) with pointtanbtn do begin parent:= tangentpc; Left := 32 Top := 392 Width := 369 Height := 25 Caption := 'Generate tangent lines for random circle and external point' TabOrder := 1 OnClick := @PointTanBtnClick end; end; TabSheet1:= TTabSheet.create(form1) with tabsheet1 do begin parent:= tangentpc; pagecontrol:= pagecontrol1 Caption := '9. Circle - Circle Tangent Lines' ImageIndex := 8 Memo11:= TMemo.create(form1) with memo11 do begin parent:= tabsheet1 Left := 24 Top := 16 Width := 401 Height := 305 Color := 14548991 Lines.add( 'Click the button below to draw 2 random circles for which the th' + +'e 2 ' +'exterior lines tangent to both circles will be calculated.' +''+CRLF +'The algorithm is: '+CRLF +''+'1. Name the given circles C1 and C2 with radii R1 and R2 such th' + +'at ' +'R1>:=R2.'+CRLF+CRLF +'2. Define a circle , C3, centered on C1 with a radius equal R1-R' + +'2. ' +'(Yellow on the diagram)' +'3..Use the Point-Circle algorithm presented on another sheet to ' + +'find' +'the lines, L1 and L2, through the center of C2 and and tangent t' + 'o ' +'C3. (Also drawn in yellow.)' +CRLF+CRLF +'3. Define the lines, PL1 and PL2, through the center of C2 and ' +'perpendicular to L1 and L2. (Green lines.)' +'4. Translate L1 a distance R2 along PL1 and L2 and distance R2 ' +'along PL2 to create the two exteroir tangent lines. (Blue lines' + '.)' +'' +'') TabOrder := 0 end; CircCircTanBtn:= TButton.create(form1) with circcirctanbtn do begin parent:= tabsheet1; Left := 32 Top := 344 Width := 385 Height := 25 Caption := 'Create 2 random circles and their exterior tangent lines. ' TabOrder := 1 OnClick := @CircCircTanBtnClick end; end; end; //pagecontrol1 ClearBtn:= TButton.create(form1) with clearbtn do begin parent:= form1 Left := 550 Top := 584 Width := 175 Height := 25 Caption := '&Clear' TabOrder := 1 OnClick := @ClearBtnClick end; StaticText1:= TStaticText.create(form1) with statictext1 do begin parent:= form1; Left := 0 Top := 635 Width := 978 Height := 20 Cursor := crHandPoint Align := alBottom Alignment := taCenter Caption := 'Copyright '#169' 2002 -2008-2020, Gary Darby, maXbox4 www.DelphiForFun.org' Font.Charset := DEFAULT_CHARSET Font.Color := clBlue Font.Height := -13 Font.Name := 'MS Sans Serif' Font.Style := [fsBold, fsUnderline] ParentFont := False TabOrder := 2 OnClick := @StaticText1Click; end; end; //form1 FormActivate(self); arealbl.Caption := '_____Area: ' end; begin //€main //test if not ('B' in StrToCharSet(DIGISET)) then writeln('key:= #0'); if not ('9' in StrToCharSet(DIGISET)) then writeln('key:= #0'); loadGeometerForm; //arealbl.Caption := 'Area:' End. //Ref: http://www.delphiforfun.org/programs/Library/geometry1.htm //http://www.ayton.id.au/gary/it/Delphi/D_maths.htm