Optimize the Length of the Crease of a Folded Piece of Paper

w=8.5;lgt=11.75;
yp={{0,0},{0,w},{lgt,w},{lgt,0},{0,0}};
paper={Lighter[Yellow,.6],Polygon[yp]};
lines={Table[{Thickness[.001],Blue,Line[{{i,0},{i,w}}]},{i,lgt-1,0,-.5}]};
margin={Red,Line[{{0,w-1},{lgt,w-1}}]};

Manipulate[
kp=3.6375;
s=(1/68)(289.0-4 (xx^2));
If[xx<kp,
       α=ArcTan[(xx/s)];
      x1=xx+lgt*Cos[α];
      y1=w-lgt*Sin[α];
      y2=w-s-lgt*Cot[((π-α)/2)];
      If[α==0,h=4.25,h=w-(lgt-xx)*Tan[α]-y2];
      c=(47/68)(Sqrt[289+4 (u^2)]);
     yp={{0,0},{0,w},{lgt,w},{lgt,0},{0,0}};
     wp={{0,w-s},{0,0},{lgt,0},{lgt,y2},{0,w-s}};
     ly={{0,w-s},{xx,w},{x1,y1},{lgt,y2},{0,w-s}};
     dg={{0,w-s},{0,0},{lgt,0},{lgt,y2}};
     b1={{0,w-s},{0,w},{lgt,w},{lgt,y2+h},{x1,y1},{lgt,y2}};
     b2={{0,w-s},{xx,w},{x1,y1}};
     cr={{0,w-s},{lgt,y2}}
,
     If[xx<w,α=ArcTan[(xx/s)];z=w*Csc[α],z=w];
     c=(1/2)(Sqrt[(((((w^2)+(u^2)))^3)/((w^2) (u^2)))]);
     yp={{0,0},{0,w},{lgt,w},{lgt,0},{0,0}};
     wp={{0,w-s},{0,0},{z,0}};
     ly={{0,w-s},{xx,w},{z,0}};
     dg={{0,w-s},{0,0},{z,0}};
     b1={{0,w-s},{0,w},{lgt,w},{lgt,0},{z,0}};
     b2={{0,w-s},{xx,w},{z,0}};
     cr={{0,w-s},{z,0}}
  ];

Grid[{{
  Plot[Piecewise[{{(47/68)(Sqrt[289+4(u^2)]),u<kp},{(1/2) (Sqrt[(((((w^2)+(u^2)))^3)/((w^2) (u^2)))]), u≥kp}}],
{u,0,8.5},PlotRange->{9,13},PlotStyle->Black,AxesOrigin->{0,9},ImageSize->.7{400,350},
AxesLabel->{x,"crease length"},Axes->True,Epilog->{{PointSize[.02],Point[{xx,c/.u->xx}]},AxesOrigin->{0,9},{Green,Thickness[.01],Line[{{0,0},{0,c/. u->xx}}]},{Blue,Thickness[.015],Line[{{0,9},{xx,9}}]}}],
Spacer[3],
Graphics[{
		paper,lines,margin,
		{White,Polygon[wp]},
		{Lighter[Yellow,0.6],Polygon[ly]},
		{Dashing[.01],Thin,Black,Line[dg]},
		{LightBrown,Thickness[.005],Line[b1]},
		{LightBrown,Thickness[.005],Line[b2]},
		{Blue,Thickness[.004],Line[{{0,w},{xx,w}}]},
		{PointSize[.015],Point[{xx,w}]},
		{Green,Thickness[.005],Line[cr]}
                },
		AspectRatio->Automatic,PlotRange->{{0,10},{0,9}},
		ImageSize->.55{550,425},PlotRangePadding->1.7,
		PlotLabel->Row[{Style["x",Italic]," = ",NumberForm[N[xx],{4,2}],
                  "\ncrease length = ",NumberForm[N[c/.u->xx],{5,2}] }]
            ]
}}
],
{{xx,2,"distance x"},0,w,Appearance->"Labeled"},SaveDefinitions->True,TrackedSymbols->True]

A sheet of legal paper is 8.5 by 11.75 inches long. The lower-left corner is brought to a point x inches from the upper-left corner and folded to form a crease. This Demonstration shows a graph of the crease length as a function of x and a diagram of the folded paper. By moving the slider, you can estimate the length of the shortest and longest possible crease. The exact shortest possible crease (((51 (Sqrt[3 ]))/8)≈11.04) and the exact longest possible crease ((47/68)(Sqrt[(47/2)(47-9(Sqrt[13]))])≈12.78) may be determined by using Mathematica or traditional calculus techniques.

Contributed by:  John A. Boerger