Moving Sofa Problem

Author

Eric W. Weisstein
July 10, 2003

This notebook downloaded from http://mathworld.wolfram.com/notebooks/RecreationalMath/MovingSofaProblem.nb.

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

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

Lower Limit

N[2/Pi+Pi/2]

Gerver

eqns={
A(Cos[θ]-Cos[ϕ])-2B Sin[ϕ]+(θ-ϕ-1)Cos[θ]-Sin[θ]+Cos[ϕ]+Sin[ϕ]==0,
A(3Sin[θ]+Sin[ϕ])-2B Cos[ϕ]+3(θ-ϕ-1)Sin[θ]+3Cos[θ]-Sin[ϕ]+Cos[ϕ]==0,
A Cos[ϕ]-(Sin[ϕ]+1/2-1/2Cos[ϕ]+B Sin[ϕ])==0,
(A+Pi/2-ϕ-θ)-(B-(θ-ϕ)(1+A)/2-(θ-ϕ)^2/4)==0
};

eqns//TraditionalForm

Set@@@FindRoot[eqns,{A,.1},{B,1.4},{ϕ,.04},{θ,.68},
WorkingPrecision->20]

First/@eqns/.soln

Attempt at Exact Solution

Factor/@GroebnerBasis[Join[eqns,Sin[#]^2+Cos[#]^2==1&/@{θ,ϕ}],{A,B,θ,ϕ},{Cos[θ],Cos[ϕ],Sin[θ],Sin[ϕ]},MonomialOrder->EliminationOrder]

Area

v5.0

Piecewise[x_,l__]:=Plus@@Function[f,Last[f]Subtract@@(UnitStep[x-#]&/@First[f])]/@Partition[{l},2]

r[a_]:=Piecewise[a,
{0,ϕ},1/2,
{ϕ,θ},1/2(1+A+a-ϕ),
{θ,Pi/2-θ},A+a-ϕ,
{Pi/2-θ,Pi/2-ϕ},B-1/2(Pi/2-a-ϕ)(1+A)-(Pi/2-a-ϕ)^2/4]

Plot[r[a],{a,0,Pi/2-ϕ}]

s[a_]:=1-r[a]
u[a_]:=Piecewise[a,
{ϕ,θ},B-(a-ϕ)(1+A)/2,
{θ,Pi/4},A+Pi/2-ϕ-a]

Plot[s[a],{a,0,Pi/2-ϕ}]

Plot[u[a],{a,ϕ,Pi/4}]

du[a_]:=Piecewise[a,
{ϕ,θ},-1/2(1+a)-(a-ϕ)/2,
{θ,Pi/4},-1]

Plot[du[a],{a,ϕ,Pi/4}]

y1[a_]:=1-Integrate[r[t]Sin[t],{t,0,a}]
y2[a_]:=1-Integrate[s[t]Sin[t],{t,0,a}]
y3[a_]:=1-Integrate[s[t]Sin[t],{t,0,a}]-u[a]Sin[a]

y1[1/2]

Plot[y1[a],{a,0,Pi/2}]

NIntegrate[y1[a]r[a]Cos[a],{a,0,Pi/2-ϕ}]//Timing

2(NIntegrate[y1[a]r[a]Cos[a],{a,0,Pi/2-ϕ},WorkingPrecision->20]+NIntegrate[y2[a]s[a]Cos[a],{a,0,θ},WorkingPrecision->20]+NIntegrate[y3[a](u[a]Sin[a]-du[a]Cos[a]-s[a]Cos[a]),{a,ϕ,Pi/4},WorkingPrecision->20])

v5.1

r[a_]:=Piecewise[{
{1/2,0<a<ϕ},
{1/2(1+A+a-ϕ),ϕ<a<θ},
{A+a-ϕ,θ<a<Pi/2-θ},
{B-1/2(Pi/2-a-ϕ)(1+A)-(Pi/2-a-ϕ)^2/4,Pi/2-θ<a<Pi/2-ϕ}
}]
s[a_]:=1-r[a]
u[a_]:=Piecewise[{
{B-(a-ϕ)(1+A)/2,ϕ<a<θ},
{A+Pi/2-ϕ-a,θ<a<Pi/4}
}]
du[a_]:=Piecewise[{
{-1/2(1+a)-(a-ϕ)/2,ϕ<a<θ},
{-1,θ<a<Pi/4}
}]

<<Graphics`Colors`

Plot[{r[a],s[a],u[a],du[a]},{a,0,Pi/2},PlotStyle->List/@{Red,DarkOrange,Green,Blue,Purple},
AxesLabel->TraditionalForm/@{α,{
StyleForm[HoldForm[r[α]],FontColor->Red],
StyleForm[HoldForm[s[α]],FontColor->DarkOrange],
StyleForm[HoldForm[u[α]],FontColor->Green],
StyleForm[HoldForm[(Subscript[D, u])[α]],FontColor->Blue]}}]

y1[a_?NumericQ]:=1-NIntegrate[r[t]Sin[t],{t,0,a},WorkingPrecision->20]
y2[a_?NumericQ]:=1-NIntegrate[s[t]Sin[t],{t,0,a},WorkingPrecision->20]
y3[a_?NumericQ]:=1-NIntegrate[s[t]Sin[t],{t,0,a},WorkingPrecision->20]-u[a]Sin[a]

y1[1/2]//Timing

Plot[y1[a],{a,0,Pi/2},PlotStyle->Red]//Timing

NIntegrate[y1[a]r[a]Cos[a],{a,0,Pi/2-ϕ},Method->GaussKronrod]//Timing

2(NIntegrate[y1[a]r[a]Cos[a],{a,0,Pi/2-ϕ}]+NIntegrate[y2[a]s[a]Cos[a],{a,0,θ}]+NIntegrate[y3[a](u[a]Sin[a]-du[a]Cos[a]-s[a]Cos[a]),{a,ϕ,Pi/4}])//Timing

With[{opts=Sequence[Method->QuasiMonteCarlo]},
2(NIntegrate[y1[a]r[a]Cos[a],{a,0,Pi/2-ϕ},opts]+NIntegrate[y2[a]s[a]Cos[a],{a,0,θ},opts]+NIntegrate[y3[a](u[a]Sin[a]-du[a]Cos[a]-s[a]Cos[a]),{a,ϕ,Pi/4},opts])
]//Timing

With[{opts=Sequence[Method->QuasiMonteCarlo,PrecisionGoal->2]},
2(NIntegrate[y1[a]r[a]Cos[a],{a,0,Pi/2-ϕ},opts]+NIntegrate[y2[a]s[a]Cos[a],{a,0,θ},opts]+NIntegrate[y3[a](u[a]Sin[a]-du[a]Cos[a]-s[a]Cos[a]),{a,ϕ,Pi/4},opts])
]//Timing

With[{opts=Sequence[Method->QuasiMonteCarlo,PrecisionGoal->3]},
2(NIntegrate[y1[a]r[a]Cos[a],{a,0,Pi/2-ϕ},opts]+NIntegrate[y2[a]s[a]Cos[a],{a,0,θ},opts]+NIntegrate[y3[a](u[a]Sin[a]-du[a]Cos[a]-s[a]Cos[a]),{a,ϕ,Pi/4},opts])
]//Timing

With[{opts=Sequence[Method->QuasiMonteCarlo,PrecisionGoal->3,MaxPoints->10^5]},
2(NIntegrate[y1[a]r[a]Cos[a],{a,0,Pi/2-ϕ},opts]+NIntegrate[y2[a]s[a]Cos[a],{a,0,θ},opts]+NIntegrate[y3[a](u[a]Sin[a]-du[a]Cos[a]-s[a]Cos[a]),{a,ϕ,Pi/4},opts])
]//Timing