Cube Square Inscribing

Author

Eric W. Weisstein
November 1, 2004

This notebook downloaded from http://mathworld.wolfram.com/notebooks/ComputationalGeometry/CubeSquareInscribing.nb.

For more information, see Eric's MathWorld entry http://mathworld.wolfram.com/CubeSquareInscribing.html.

©2005 Wolfram Research, Inc. except for portions noted otherwise

Numerical Optimization

vars={{x1,y1,z1},{x2,y2,z2},{x3,y3,z3},{x4,y4,z4}};

expr=Plus@@(TriangleArea3D/@{Most[vars],Drop[vars,{2}]})

cons=And@@(0<#<1&/@Flatten[vars])&&
Equal@@Join[2#.#&/@Subtract@@@Partition[vars,2,1,1],
#.#&/@Subtract@@@Transpose[Partition[vars,2]]
]&&
TetrahedronVolume[vars]==0

(soln=Maximize[{expr,cons},Flatten[vars]])//Timing

...killed after 6 hours, 1.7 GB...

(nsoln=NMaximize[{expr,cons},Flatten[vars]])//Timing

(nsoln=NMaximize[{expr,cons},Flatten[vars],Method->SimulatedAnnealing])//Timing

vars/.nsoln[[2]]

Show[Graphics3D[
{
Map[Line,Join[
Table[{{i,j,0},{i,j,1}},{i,0,1},{j,0,1}],
Table[{{0,i,j},{1,i,j}},{i,0,1},{j,0,1}],
Table[{{j,0,i},{j,1,i}},{i,0,1},{j,0,1}]
],{2}],
Polygon[vars/.soln[[2]]],
PointSize[.02],
Point/@(vars/.soln[[2]])
}],Boxed->False]