Drawing on Autopilot: Automated Plane (Geometry) Illustrations from The American Mathematical Monthly
April 4, 2019 — Dan McDonald , Lead Developer, Synthetic Geometry Project
Version 12 of the Wolfram Language introduces the functions GeometricScene, RandomInstance and FindGeometricConjectures for representing, drawing and reasoning about problems in plane geometry. In particular, abstract scene descriptions can be automatically supplied with coordinate values to produce diagrams satisfying the conditions of the scene. Let’s apply this functionality to some of the articles and problems about geometry appearing in the issues of The American Mathematical Monthly from February and March of 2019.
Solving Newton’s Equation Geometrically
First consider the article “Newton Quadrilaterals, the Associated Cubic Equations, and Their Rational Solutions,” by Mowaffaq Hajja and Jonathan Sondow, appearing in the February 2019 issue.
Newton posed the following problem in his 1720 algebra textbook Universal Arithmetick: given a quadrilateral with side lengths , , and inscribed in a circle of diameter , solve for given , and . His solution was Newton’s equation:
✕
newtonEq=(d^3(a^2+b^2+c^2)d2a b c==0)∧(d>0); 
Let’s solve Newton’s equation for the following random values of , and :
✕
abcRules=Thread[{a,b,c}> RandomReal[10,3]] 
We could use Solve to find directly:
✕
Solve[newtonEq/.abcRules,d] 
We could also employ RandomInstance and GeometricScene to solve for using the original geometric construction. First we draw the scene, only using the values of , and (the symbol appears, but is not assigned a value initially; the first argument of GeometricScene contains the list of symbolic points and, optionally, the list of symbolic quantities, each of which can be given a fixed value via a rule assignment, if desired):
✕
newtonScene=RandomInstance[GeometricScene[ {{"A","B","C","D"},Append[abcRules,d]}, { Polygon[{"A","B","C","D"}], CircleThrough[{"A","B","C","D"},Midpoint[{"A","D"}]], EuclideanDistance["A","B"]==a, EuclideanDistance["B","C"]==b, EuclideanDistance["C","D"]==c, EuclideanDistance["D","A"]==d } ]] 
Now we extract the value of in this scene, and see that it equals our solution found directly:
✕
Replace[d,newtonScene["Quantities"]] 
The presentday authors prove the converse of Newton’s original statement: given positive numbers , , and satisfying Newton’s equation, there exists a quadrilateral with side lengths , , and inscribed in a circle of diameter .
We find an instance of such values for , , and :
✕
abcdRules=First@FindInstance[{a,b,c}==RandomReal[10,3]∧newtonEq,{a,b,c,d},Reals] 
Indeed, we can draw the scene:
✕
newtonScene=RandomInstance[GeometricScene[ {{"A","B","C","D"},abcdRules}, { Polygon[{"A","B","C","D"}], CircleThrough[{"A","B","C","D"},Midpoint[{"A","D"}]], EuclideanDistance["A","B"]==a, EuclideanDistance["B","C"]==b, EuclideanDistance["C","D"]==c, EuclideanDistance["D","A"]==d } ]] 
Illustrating a Geometric Problem and Conjecturing Its Conclusion
Next we consider Problem 12092 from the February 2019 Problems and Solutions section, proposed by Michael Diao and Andrew Wu.
Let be a triangle, and let be a point in the plane of the triangle satisfying . Let and be diametrically opposite on the circumcircles of and , respectively. Let be the point of concurrency of lines and . Prove that and are perpendicular.
Illustrate the hypotheses:
✕
pic=RandomInstance[GeometricScene[ {a,b,c,p,q,r,x}, { p∈Triangle[{a,b,c}], PlanarAngle[{b,a,p}]==PlanarAngle[{c,a,p}], TriangleCenter[Triangle[{a,b,p}],"Circumcenter"]==Midpoint[{p,q}], TriangleCenter[Triangle[{a,c,p}],"Circumcenter"]==Midpoint[{p,r}], GeometricAssertion[{Line[{b,r}],Line[{c,q}]},{"Concurrent",x}], Style[{Line[{x,p}],Line[{b,c}]},Red] } ]] 
Use FindGeometricConjectures to find facts about this particular scene instance, including the conclusion to our problem:
✕
FindGeometricConjectures[pic,GeometricAssertion[_,"Perpendicular"]] 
Finding Evidence in Support of Geometric Inequalities
Finally, we consider Problem 12098 from the March 2019 Problems and Solutions section, proposed by Leonard Giugiuc and Kadir Altintas.
Suppose that the centroid of a triangle with semiperimeter and inradius lies on its incircle. Prove , and determine conditions for equality.
Generate three separate instances of the scene:
✕
pics=RandomInstance[GeometricScene[ {{"A","B","C","D"},{s,r}}, { tri==Triangle[{"A","B","C"}], TriangleMeasurement[tri,"Semiperimeter"]==s, TriangleMeasurement[tri,"Inradius"]==r, "D"==TriangleCenter[tri,"Centroid"], "D"∈TriangleConstruct[tri,"Incircle"] } ],3] 
Verify that the inequality holds in each instance:
✕
Grid[ReplaceAll[{s,r,s>=3Sqrt[6]r},Prepend[Through[pics["Quantities"]],{}]],Frame>All] 
Verify that the inequality holds in general for triangles having side lengths , using the formulas for semiperimeter , inradius and distance from incenter to centroid :

Since the minimum value of , taken over all side lengths , and satisfying the given constraints, is (realized with side lengths , and ), the inequality holds in general.
Find three instances where equality holds:
✕
eqPics=RandomInstance[GeometricScene[ {{"A","B","C","D"},{s,r}}, { tri==Triangle[{"A","B","C"}], TriangleMeasurement[tri,"Semiperimeter"]==s, TriangleMeasurement[tri,"Inradius"]==r, "D"==TriangleCenter[tri,"Centroid"], "D"∈TriangleConstruct[tri,"Incircle"], s==3Sqrt[6]r } ],3] 
These triangles all look suspiciously similar. To confirm our suspicions, we order the side lengths of each triangle as and then compute and :
✕
Grid[Prepend[Table[Round[Rest[#]/First[#],.01]&@Sort[EuclideanDistance@@@Subsets[{"A","B","C"},{2}]/.Join[pic["Points"],pic["Quantities"]]],{pic,eqPics}],{b/a,c/a}],Frame>All] 
Indeed, all triangles seem to be isosceles triangles. To prove this holds in general, we find all possible values of and for the triangle having coordinates , and to satisfy the stated properties:
✕
xyVals=With[{tri={{1,0},{1,0},{x,y}}}, Reduce[TriangleCenter[tri,"Centroid"]∈TriangleConstruct[tri,"Incircle"]∧TriangleMeasurement[tri,"Semiperimeter"]==3Sqrt[6]TriangleMeasurement[tri,"Inradius"], {x,y}]/.{Or>List,And>List,Equal>Last} ] 
Visualize these triangles:
✕
Graphics[Join[{Opacity[.4],RandomColor[],Triangle[{{1,0},{1,0},#}]}&/@xyVals,{Line[{{1,0},{1,0}}]},Point/@xyVals]] 
Verify that the triangles satisfying the equality are all isosceles triangles, proving our claim in general:
✕
#*2/First[#]&/@(Sort[ArcLength/@TriangleConstruct[{{1,0},{1,0},#},{"OppositeSide",All}]]&/@xyVals) 
Hence we have demonstrated that the inequality holds in general, with equality for a single class of similar triangles. Isosceleasypeasy!
Download this post as a Wolfram Notebook.
Mathematica 12 significantly extends the reach of Mathematica and introduces many innovations that give all Mathematica users new levels of power and effectiveness. 
2 Comments
That’s amazing! When will Mathematica 12 for Mac be released? In days? weeks? months?
Hi Michael. I’d lean towards the days/weeks end of the spectrum. We’re very close!