(*漸化式アプローチ*)

(*n=2*)

n=2;

ss=Array[s,n];

u[n_]:=s[n]/Sqrt[1-Sum[s[i]^2,{i,n-1}]]

v[1][ss_]:=ss[[1]]

v[n_][ss_]:=v[n][ss]=u[n]+Integrate[v[n-1][ss[[;;n-1]]/Sqrt[1-ss[[n]]^2/a[n]^2]],{a[n],u[n],1},Assumptions->And@@Thread[0<ss]]

v[n][ss]

v[n][ss]=Simplify[Apart[v[n][ss]],Sum[s[i]^2,{i,n}]<1]

V[n]=Evaluate[v[n][ss]/.Table[s[i]->Slot[i],{i,n}]]&

jacobian[n_]:=r^(n-1)Product[Sin[θ[i]]^(n-i-1),{i,n-1}]

ss=Table[(1-r)Product[Sin[θ[i]],{i,j-1}]If[j==n,1,Cos[θ[j]]],{j,n}]

w[n]=2^n Integrate[V[n]@@ss jacobian[n],{r,0,1},Sequence@@Table[{θ[i],0,π/2},{i,n-1}]]

(*n=3*)

n=3;

ss=Array[s,n];

u[n_]:=s[n]/Sqrt[1-Sum[s[i]^2,{i,n-1}]]

v[1][ss_]:=ss[[1]]

v[n_][ss_]:=v[n][ss]=u[n]+Integrate[v[n-1][ss[[;;n-1]]/Sqrt[1-ss[[n]]^2/a[n]^2]],{a[n],u[n],1},Assumptions->And@@Thread[0<ss]]

v[n][ss]

Integrate[((s[2])/(Sqrt[1-((s[1])^2)]))+((Abs[a[3]] s[1] ((Sqrt[-((a[3])^2) (-1+((s[2])^2))-((s[3])^2)])-Abs[s[2]] (Sqrt[((-((a[3])^2) ((s[1])^2)+((s[3])^2))/(-1+((s[1])^2)))])))/(((a[3])^2)-((s[3])^2))),{a[3],((s[3])/(Sqrt[1-((s[1])^2)-((s[2])^2)])),1},Assumptions->0<s[1]&&0<s[2]&&0<s[3]]+((s[3])/(Sqrt[1-((s[1])^2)-((s[2])^2)]))

(*別アプローチ*)

(*n=2*)

n=2;

ss=Array[s,n];

u[n_]:=s[n]/Sqrt[1-Sum[s[i]^2,{i,n-1}]]

u[n_,k_]:=s[k]/Sqrt[1-Sum[s[i]^2,{i,1,k-1}]-Sum[s[i]^2/a[i]^2,{i,k+1,n}]]

u[n,1]

u[n,2]

u[n]==u[n,n]

t[1]=u[n,n]

t[k_]:=t[k]=Integrate[u[n,n-k+1],Sequence@@Table[{a[i],u[n,i],1},{i,n-k+2,n}],Assumptions->And@@Thread[0<ss]]

t[2]

t[2]=Simplify[t[2],Sum[s[i]^2,{i,n}]<1&&0<s[1]&&0<s[2]]

T[k_]:=Evaluate[t[k]/.Table[s[i]->Slot[i],{i,n}]]&

T[1]

T[2]

jacobian[n_]:=r^(n-1)Product[Sin[θ[i]]^(n-i-1),{i,n-1}]

ss=Table[(1-r)Product[Sin[θ[i]],{i,j-1}]If[j==n,1,Cos[θ[j]]],{j,n}]

ω[k_]:=ω[k]=Integrate[T[k]@@ss jacobian[n],Sequence@@Table[{θ[i],0,π/2},{i,n-1,1,-1}],{r,0,1}]

ω[1]

ω[2]

w[n]=2^n Sum[ω[i],{i,n}]

(*n=3*)

n=3;

ss=Array[s,n];

u[n_,k_]:=s[k]/Sqrt[1-Sum[s[i]^2,{i,1,k-1}]-Sum[s[i]^2/a[i]^2,{i,k+1,n}]]

u[n,1]

u[n,2]

u[n,3]

t[1]=u[n,n]

t[k_]:=t[k]=Integrate[u[n,n-k+1],Sequence@@Table[{a[i],u[n,i],1},{i,n-k+2,n}],Assumptions->And@@Thread[0<ss]]

t[2]

Clear[t]

t[k_]:=t[k]=Integrate[u[n,n-k+1],Sequence@@Table[{a[i],u[n,i],1},{i,n,n-k+2,-1}],Assumptions->And@@Thread[0<ss]]

t[2]

t[2]=Simplify[t[2],Sum[s[i]^2,{i,n}]<1]

t[3]

Length[t[3]]

t[3]=FullSimplify[t[3],Sum[s[i]^2,{i,n}]<1&&0<s[1]&&0<s[2]&&0<s[3]]

T[k_]:=Evaluate[t[k]/.Table[s[i]->Slot[i],{i,n}]]&

T[1]

T[2]

T[3]

jacobian[n_]:=r^(n-1)Product[Sin[θ[i]]^(n-i-1),{i,n-1}]

ss=Table[(1-r)Product[Sin[θ[i]],{i,j-1}]If[j==n,1,Cos[θ[j]]],{j,n}]

Clear[ω]

ω[k_]:=ω[k]=Integrate[T[k]@@ss jacobian[n],Sequence@@Table[{θ[i],0,π/2},{i,n-1,1,-1}],{r,0,1}]

ω[1]

Clear[ω]

Reverse[ss]

ω[k_]:=ω[k]=Integrate[T[k]@@Reverse[ss] jacobian[n],Sequence@@Table[{θ[i],0,π/2},{i,n-1,1,-1}],{r,0,1}]

ω[1]

ω[2]

Clear[ω]

ω[k_]:=ω[k]=Integrate[T[k]@@ss jacobian[n],Sequence@@Table[{θ[i],0,π/2},{i,n-1,1,-1}],{r,0,1}]

ω[2]

(*ω[3]*)

(*w[n]=2^n Sum[ω[i],{i,n}]*)

Clear[ωn]

ωn[k_]:=ωn[k]=NIntegrate[T[k]@@ss jacobian[n],Evaluate[Sequence@@Table[{θ[i],0,π/2},{i,n-1,1,-1}]],{r,0,1}]

ωn[1]

N[(1/12) π (-5+3 π-6 Log[2])]

ωn[2]

ωn[3]

2^n(ωn[1]+ωn[2]+Chop[ωn[3]])

N[(7/15)π]

(*n=4*)

n=4;

ss=Array[s,n];

u[n_,k_]:=s[k]/Sqrt[1-Sum[s[i]^2,{i,1,k-1}]-Sum[s[i]^2/a[i]^2,{i,k+1,n}]]

u[n,1]

u[n,2]

u[n,3]

u[n,4]

t[1]=u[n,n]

Clear[t]

t[k_]:=t[k]=Integrate[u[n,n-k+1],Sequence@@Table[{a[i],u[n,i],1},{i,n,n-k+2,-1}],Assumptions->And@@Thread[0<ss]]

T[k_]:=Evaluate[t[k]/.Table[s[i]->Slot[i],{i,n}]]&

jacobian[n_]:=r^(n-1)Product[Sin[θ[i]]^(n-i-1),{i,n-1}]

ss=Table[(1-r)Product[Sin[θ[i]],{i,j-1}]If[j==n,1,Cos[θ[j]]],{j,n}]

Clear[ωn]

ωn[k_]:=ωn[k]=NIntegrate[T[k]@@ss jacobian[n],{r,0,1},Evaluate[Sequence@@Table[{θ[i],0,π/2},{i,n-1}]]]

ωn[1]

ωn[2]

(*近似値*)

u[n_,k_]:=s[k]/Sqrt[1-Sum[s[i]^2,{i,1,k-1}]-Sum[s[i]^2/a[i]^2,{i,k+1,n}]]

t[n_,k_]:=integrate[u[n,n-k+1],Sequence@@Table[{a[i],u[n,i],1},{i,n,n-k+2,-1}]]

t[2,1]

t[2,2]

Clear[t]

t[n_,k_]:=integrate[1,Sequence@@Table[{a[i],u[n,i],1},{i,n,n-k+2,-1}],{a[n-k+1],0,u[n,n-k+1]}]

ωn[n_,k_]:=nintegrate[1,{r,0,1},Evaluate[Sequence@@Table[{θ[i],0,π/2},{i,n-1}]]]

ωn[2,1]

ωn[2,2]

ωn[3,1]

ωn[3,2]

ωn[3,3]

u[n_,k_,ss_]:=ss[[k]]/Sqrt[1-Sum[ss[[i]]^2,{i,1,k-1}]-Sum[ss[[i]]^2/a[i]^2,{i,k+1,n}]]

ss[n_]:=Reverse[Table[(1-r)Product[Sin[θ[i]],{i,j-1}]If[j==n,1,Cos[θ[j]]],{j,n}]]

ss[4]

U[n_,k_,ss_]:=ss[[k]]/Sqrt[1-(1-r)^2Sum[Sin[θ[i]]^2,{i,n-k+1}]-Sum[ss[[i]]^2/a[i]^2,{i,k+1,n}]]

ss[n_]:=Table[(1-r)Product[Sin[θ[i]],{i,n-k}]If[k==1,1,Cos[θ[n-k+1]]],{k,n}]

ss[4]

u[n_,k_]:=U[n,k,ss[n]]

u[2,1]

u[2,2]

u[3,1]

u[3,2]

u[3,3]

jacobian[n_]:=r^(n-1)Product[Sin[θ[i]]^(n-i-1),{i,n-1}]

ωn[n_,k_]:=nintegrate[jacobian[n],{r,0,1},Evaluate[Sequence@@Table[{θ[i],0,π/2},{i,n-1}]],Sequence@@Table[{a[i],u[n,i],1},{i,n,n-k+2,-1}],{a[n-k+1],0,u[n,n-k+1]}]

ωn[2,1]

ωn[n_,k_]:=nintegrate[jacobian[n],{r,0,1},Sequence@@Table[{θ[i],0,π/2},{i,n-1}],Sequence@@Table[{a[i],u[n,i],1},{i,n,n-k+2,-1}],{a[n-k+1],0,u[n,n-k+1]}]

ωn[2,1]

ω[n_,k_]:=Integrate[jacobian[n],{r,0,1},Sequence@@Table[{θ[i],0,π/2},{i,n-1}],Sequence@@Table[{a[i],u[n,i],1},{i,n,n-k+2,-1}],{a[n-k+1],0,u[n,n-k+1]}]

ω[2,1]

ω[2,2]

ωn[n_,k_]:=NIntegrate[jacobian[n],{r,0,1},Sequence@@Table[{θ[i],0,π/2},{i,n-1}],Sequence@@Table[{a[i],u[n,i],1},{i,n,n-k+2,-1}],{a[n-k+1],0,u[n,n-k+1]}]

ωn[2,1]

ωn[n_,k_]:=NIntegrate[jacobian[n],Evaluate[{r,0,1},Sequence@@Table[{θ[i],0,π/2},{i,n-1}],Sequence@@Table[{a[i],u[n,i],1},{i,n,n-k+2,-1}],{a[n-k+1],0,u[n,n-k+1]}]]

ωn[2,1]

ωn[2,2]

?u

U[2,1,ss[2]]

?U

u[2,1]

(*バグってた*)

U[n_,k_,ss_]:=ss[[k]]/Sqrt[1-If[k==1,0,(1-r)^2Product[Sin[θ[i]]^2,{i,n-k+1}]]-Sum[ss[[i]]^2/a[i]^2,{i,k+1,n}]]

ω[2,1]

N[%]

ωn[2,1]

ω[2,2]

N[%]

(*ω[2,2]に余計な-i/12が含まれている→Mathematicaのバグ*)

ωn[2,2]

ω[3,1]

ωn[3,1]

ω[3,2]

ωn[3,2]

ωn[3,3]

(*グラフ*)

ωn[n_,k_,option___]:=NIntegrate[jacobian[n],Evaluate[{r,0,1},Sequence@@Table[{θ[i],0,π/2},{i,n-1}],Sequence@@Table[{a[i],u[n,i],1},{i,n,n-k+2,-1}],{a[n-k+1],0,u[n,n-k+1]}],option]

ωn[3,3]

ωn[3,3,Method->"MonteCarlo"]

(*色々オプションを試して計算し、値が決まったらωnOKに代入する*)

wn[n_]:=2^n Sum[ωnOK[n,i],{i,n}]

(*n=1*)

ωnOK[1,1]=ωn[1,1]

wn[1]

(*n=2*)

ωnOK[2,1]=ωn[2,1]

ωnOK[2,2]=ωn[2,2]

wn[2]

N[(5/4)π-8/3]

(*n=3*)

ωnOK[3,1]=ωn[3,1]

ωnOK[3,2]=ωn[3,2]

ωnOK[3,3]=ωn[3,3]

wn[3]

N[(7/15)π]

(*n=4*)

ωnOK[4,1]=ωn[4,1]

ωnOK[4,2]=ωn[4,2]

ωnOK[4,3]=ωn[4,3]

ωnOK[4,4]=ωn[4,4]

wn[4]

N[π((33/32)π-96/35)]

(*n=5*)

ωnOK[5,1]=ωn[5,1]

ωnOK[5,2]=ωn[5,2]

ωnOK[5,3]=ωn[5,3]

ωnOK[5,4]=ωn[5,4]

ωnOK[5,5]=ωn[5,5]

wn[5]

(*n=6*)

ωnOK[6,1]=ωn[6,1]

ωnOK[6,2]=ωn[6,2]

ωnOK[6,3]=ωn[6,3]

ωnOK[6,4]=ωn[6,4]

ωnOK[6,5]=ωn[6,5]

ωnOK[6,6]=ωn[6,6]

wn[6]

(*n=7*)

AbsoluteTiming[ωnOK[7,1]=ωn[7,1]]

AbsoluteTiming[ωnOK[7,2]=ωn[7,2]]

AbsoluteTiming[ωnOK[7,3]=ωn[7,3]]

AbsoluteTiming[ωnOK[7,4]=ωn[7,4]]

AbsoluteTiming[ωnOK[7,5]=ωn[7,5]]

AbsoluteTiming[ωnOK[7,6]=ωn[7,6]]

AbsoluteTiming[ωnOK[7,7]=ωn[7,7]]

wn[7]

(*n=8*)

AbsoluteTiming[ωnOK[8,1]=ωn[8,1]]

AbsoluteTiming[ωnOK[8,2]=ωn[8,2]]

AbsoluteTiming[ωnOK[8,3]=ωn[8,3]]

AbsoluteTiming[ωnOK[8,4]=ωn[8,4]]

AbsoluteTiming[ωnOK[8,5]=ωn[8,5]]

AbsoluteTiming[ωnOK[8,6]=ωn[8,6]]

AbsoluteTiming[ωnOK[8,7]=ωn[8,7]]

AbsoluteTiming[ωnOK[8,8]=ωn[8,8]]

AbsoluteTiming[ωnOK[8,8]=ωn[8,8,MaxPoints->10000000]]

wn[8]

ListLinePlot[Table[wn[n],{n,8}],PlotMarkers->Automatic]

(*n=9*)

AbsoluteTiming[ωnOK[9,1]=ωn[9,1]]

AbsoluteTiming[ωnOK[9,2]=ωn[9,2]]

AbsoluteTiming[ωnOK[9,3]=ωn[9,3]]

AbsoluteTiming[ωnOK[9,4]=ωn[9,4]]

AbsoluteTiming[ωnOK[9,5]=ωn[9,5]]

AbsoluteTiming[ωnOK[9,6]=ωn[9,6]]

AbsoluteTiming[ωnOK[9,7]=ωn[9,7]]

AbsoluteTiming[ωnOK[9,8]=ωn[9,8]]

AbsoluteTiming[ωnOK[9,9]=ωn[9,9]]

wn[9]

(*n=10*)

AbsoluteTiming[ωnOK[10,1]=ωn[10,1]]

AbsoluteTiming[ωnOK[10,2]=ωn[10,2]]

AbsoluteTiming[ωnOK[10,3]=ωn[10,3]]

AbsoluteTiming[ωnOK[10,4]=ωn[10,4]]

AbsoluteTiming[ωnOK[10,5]=ωn[10,5]]

AbsoluteTiming[ωnOK[10,6]=ωn[10,6]]

AbsoluteTiming[ωnOK[10,7]=ωn[10,7]]

AbsoluteTiming[ωnOK[10,8]=ωn[10,8]]

AbsoluteTiming[ωnOK[10,9]=ωn[10,9]]

AbsoluteTiming[ωnOK[10,10]=ωn[10,10]]

wn[10]