给定Feuerbach点，反构作三角形？
math.stackexchange.com/questions/5011258/given-an-arbitrary-tria ... e-always-reconstruct
给定三角形顶点坐标，计算Feuerbach点的代码：
- AreaOfTriangle[p_,q_,r_]:=\[Sqrt](#(#-EuclideanDistance[p,q])(#-EuclideanDistance[q,r])(#-EuclideanDistance[p,r]))&[1/2 (EuclideanDistance[p,q]+EuclideanDistance[q,r]+EuclideanDistance[p,r])]/.Complex[a_,b_]/;Max[Abs@a,Abs@b]<10^-4->0;PerpendicularPointOnLine[pt_,pt1_,pt2_]:=Block[{x,y},If[EuclideanDistance[pt1,pt2]<10^-5,{},{x,y}/.NSolve[{(pt2[[1]]-pt1[[1]])(y-pt1[[2]])==(pt2[[2]]-pt1[[2]])(x-pt1[[1]]),(pt2[[2]]-pt1[[2]])(y-pt[[2]])==(pt1[[1]]-pt2[[1]])(x-pt[[1]])},{x,y}][[1]]]];
- IntersectionOfLines[p1_,p2_,p3_,p4_]:=Block[{x,y},Which[#==={},{},Not[And@@(NumericQ/@({x,y}/.#[[1]]))],{},True,{x,y}/.#[[1]]]&[Quiet[NSolve[{(y-p1[[2]])(p2[[1]]-p1[[1]])==(p2[[2]]-p1[[2]])(x-p1[[1]]),(y-p3[[2]])(p4[[1]]-p3[[1]])==(p4[[2]]-p3[[2]])(x-p3[[1]])},{x,y}]]]];PointOnBisector[a_,v_,b_]:=If[Norm[Normalize[RotationTransform[#,{0,0}][b-v]]-Normalize[a-v]]<10^-10,Normalize[RotationTransform[#/2,{0,0}][b-v]]+v,Normalize[RotationTransform[#/2,{0,0}][a-v]]+v]&[VectorAngle[b-v,a-v]];ExCircleData[p1_,p2_,p3_]:=Module[{h,k,cen,rad},h=PointOnBisector[p3,p1,p2];k=PointOnBisector[p2,p3,p3+(p3-p1)];cen=IntersectionOfLines[p3,k,p1,h];
- rad=EuclideanDistance[cen,PerpendicularPointOnLine[cen,p1,p2]];{cen,rad}];ThroughAPointPerpendicularToALine[pt_,p1_,p2_,p3_,p4_]:=Block[{x,y},If[#=!={}&&And@@(NumericQ/@({x,y}/.#[[1]])),{x,y}/.#[[1]],{}]&[Quiet[NSolve[{(y-pt[[2]])(p2[[2]]-p1[[2]])==(p1[[1]]-p2[[1]])(x-pt[[1]]),(y-p3[[2]])(p4[[1]]-p3[[1]])==(p4[[2]]-p3[[2]])(x-p3[[1]])},{x,y}]]]];IntersectionWithCircle[p1_,p2_,cen_,rad_]:=Block[{x,y},Which[#==={},{},Not[And@@(NumericQ/@({x,y}/.#[[1]]))],{},Not@FreeQ[#,Complex],{},True,{x,y}/.#[[1]]]&[Quiet[NSolve[{(y-p1[[2]])(p2[[1]]-p1[[1]])==(p2[[2]]-p1[[2]])(x-p1[[1]]),(x-cen[[1]])^2+(y-cen[[2]])^2==rad^2},{x,y}]/.{Complex[a_,b_]/;Max[Abs@a,Abs@b]<10^-4->0,Complex[a_,b_]/;Abs[b]<10^-4:>a,Complex[a_,b_]/;Abs[a]<10^-4:>a}]]];InscribedCircleData[pA_,pB_,pC_]:=Module[{AB,BC,AC,a,b,c,s,pP,pQ,AP,BQ,p,q,ps1,qs1,ps,qs,pqs,incenter,inradius},AB=pB-pA;BC=pC-pB;AC=pC-pA;a=Sqrt[BC.BC];b=Sqrt[AC.AC];c=Sqrt[AB.AB];AP=pB+p BC-pA;BQ=pA+q AC-pB;ps1=Solve[(AP.AB)b==(AP.AC)c,p];qs1=Solve[(BQ.BC)c==(BQ.(-AB))a,q];If[ps1=!={{}}&&qs1=!={{}},ps=ps1[[1,1]];qs=qs1[[1,1]];pP=pB+p BC/.ps;pQ=pA+q AC/.qs;pqs=Solve[pA+p (pP-pA)==pB+q (pQ-pB),{p,q}][[1]];incenter=pA+p (pP-pA)/.pqs;s=1/2 (a+b+c);inradius=Sqrt[((s-a) (s-b) (s-c))/s]; {incenter,inradius},{}]];ThreePointCircleData[{x1_,y1_},{x2_,y2_},{x3_,y3_}]:=Module[{a=Det[{{x1,y1,1},{x2,y2,1},{x3,y3,1}}],d=-Det[{{x1^2+y1^2,y1,1},{x2^2+y2^2,y2,1},{x3^2+y3^2,y3,1}}],e=Det[{{x1^2+y1^2,x1,1},{x2^2+y2^2,x2,1},{x3^2+y3^2,x3,1}}],f=-Det[{{x1^2+y1^2,x1,y1},{x2^2+y2^2,x2,y2},{x3^2+y3^2,x3,y3}}]},If[a==0||(d^2+e^2)/(4 a^2)-f/a<=0,{},{{-(d/(2 a)),-(e/(2 a))},Sqrt[(d^2+e^2)/(4 a^2)-f/a]}]];IntersectionOfCircles[cen1_,rad1_,cen2_,rad2_]:=Block[{x,y},Which[#==={},{},Not[And@@(NumericQ/@Flatten[{x,y}/.#])],{},Not@FreeQ[#,Complex],{},True,{x,y}/.#[[1]]]&[Quiet[NSolve[{(x-cen1[[1]])^2+(y-cen1[[2]])^2==rad1^2,(x-cen2[[1]])^2+(y-cen2[[2]])^2==rad2^2},{x,y}]]]]
绘图代码：
- ShowGraphics[{p1_,p2_,p3_}]:=Module[{NonDegenerateTriangle,ecd1,cen1,rad1,i1,p113,p112,ecd2,cen2,rad2,i2,p223,p221,ecd3,cen3,rad3,i3,p313,p323,icd,m12,m13,m23,p123,p213,p312,npc,cint,h,m1h,m2h,m3h,reduce=If[MatchQ[#,Line[{_,{}}]],{},#]&},NonDegenerateTriangle=AreaOfTriangle[p1,p2,p3]>10^-4;m12=Mean[{p1,p2}];m13=Mean[{p1,p3}];m23=Mean[{p2,p3}];If[NonDegenerateTriangle,p123=PerpendicularPointOnLine[p1,p2,p3];p213=PerpendicularPointOnLine[p2,p1,p3];p312=PerpendicularPointOnLine[p3,p1,p2];h=IntersectionOfLines[p1,p123,p2,p213];npc={{0,0},1};ecd1=ExCircleData[p1,p2,p3];cen1=ecd1[[1]];rad1=ecd1[[2]];i1=IntersectionOfCircles[npc[[1]],npc[[2]],cen1,rad1];p113=ThroughAPointPerpendicularToALine[cen1,cen1,p1,p3,p1];p112=ThroughAPointPerpendicularToALine[cen1,cen1,p1,p2,p1];ecd2=ExCircleData[p2,p1,p3];cen2=ecd2[[1]];rad2=ecd2[[2]];i2=IntersectionOfCircles[npc[[1]],npc[[2]],cen2,rad2];p223=ThroughAPointPerpendicularToALine[cen2,cen2,p2,p3,p2];p221=ThroughAPointPerpendicularToALine[cen2,cen2,p2,p1,p2];ecd3=ExCircleData[p3,p1,p2];cen3=ecd3[[1]];rad3=ecd3[[2]];i3=IntersectionOfCircles[npc[[1]],npc[[2]],cen3,rad3];p313=ThroughAPointPerpendicularToALine[cen3,cen3,p3,p1,p3];p323=ThroughAPointPerpendicularToALine[cen3,cen3,p3,p2,p3];icd=InscribedCircleData[p1,p2,p3];cint=IntersectionOfCircles[npc[[1]],npc[[2]],icd[[1]],icd[[2]]];h=IntersectionOfLines[p1,p123,p2,p213];m1h=If[h=!={},Mean[{p1,h}],{}];m2h=If[h=!={},Mean[{p2,h}],{}];m3h=If[h=!={},Mean[{p3,h}],{}]];Graphics[{AbsolutePointSize[3],Sequence[RGBColor[1,.26,0],DeleteCases[Flatten[{Line[{p1,#}]&/@{p113,p112},Line[{p2,#}]&/@{p223,p221},Line[{p3,#}]&/@{p313,p323}}],Line[{a__}]/;MemberQ[{a},{}]]],RGBColor[.88,.63,.23],Line[{p1,p2,p3,p1}],Sequence[RGBColor[1,.26,0],reduce@Line[{p3,p113}],reduce@Line[{p2,p112}],reduce@Line[{p1,p221}],reduce@Line[{p3,p223}],reduce@Line[{p1,p313}],reduce@Line[{p2,p323}],RGBColor[.45,.7,.55],Circle[Sequence@@ecd1],Circle[Sequence@@ecd2],Circle[Sequence@@ecd3],Circle[Sequence@@icd],RGBColor[.25,.43,.82],Circle@@npc,Sequence[RGBColor[1,.26,0],Point[DeleteCases[{i1,i2,i3,cint},{}]]]]}]]
由三边中点反构作三角形的代码：
- AnticomplementaryTriangle[{a_,b_,c_}]:={-a+b+c,a-b+c,a+b-c}
以单位圆上的随机点$F_A,F_B,F_C$为Feuerbach点，反构作三角形的代码：
- Block[{z1=Exp[I RandomReal[2Pi]],z2=Exp[I RandomReal[2Pi]],z3=Exp[I RandomReal[2Pi]]},roots=x/.NSolve[Chop[Simplify[(2 p^2 q s-4 p^2 r^2+p q^2 r+4 p r s+2 q r^2/. {p->SymmetricPolynomial[1,{z0,z1,z2,z3}],q->SymmetricPolynomial[2,{z0,z1,z2,z3}],r->SymmetricPolynomial[3,{z0,z1,z2,z3}],s->SymmetricPolynomial[4,{z0,z1,z2,z3}]}/.z0->((1-I x)/(1+I x))/(z1 z2 z3))(1+I x)^4]],x,Reals];Print[roots];Table[ShowGraphics[AnticomplementaryTriangle[ReIm[y]/.NSolve[-((2 r^2)/(p q+2 r))+(4 q r y)/(p q+2 r)-(2 q y^2)/p+y^3==0/.{p->SymmetricPolynomial[1,{((1-I x)/(1+I x))/(z1 z2 z3),z1,z2,z3}],q->SymmetricPolynomial[2,{((1-I x)/(1+I x))/(z1 z2 z3),z1,z2,z3}],r->SymmetricPolynomial[3,{((1-I x)/(1+I x))/(z1 z2 z3),z1,z2,z3}]},y]]],{x,roots}]]
|
