Ball Triangle Picking

Author

Eric W. Weisstein
March 14, 2017

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

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

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

Area of a Random Triangle

TriangleArea3D[{{x1_,y1_,z1_},{x2_,y2_,z2_},{x3_,y3_,z3_}}]:=Sqrt[(-x2*y1+x3*y1+x1*y2-x3*y2-x1*y3+x2*y3)^2+(x2*z1-x3*z1-x1*z2+x3*z2+x1*z3-x2*z3)^2+(-y2*z1+y3*z1+y1*z2-y3*z2-y1*z3+y2*z3)^2]/2

Exact Mean

(9/77)π//N

RandomPoint

tri=RandomPoint[Ball[],{(10^6),3}];//Timing

Length[areas=Abs[TriangleArea3D/@tri]]//Timing

TimeConstrained[Length[areas=Area[Triangle[#]]&/@tri],60]//Timing

TimeConstrained[Length[areas=RegionMeasure[Triangle[#]]&/@tri],60]//Timing

bug(330535): Area, Volume, and RegionMeasure should be faster on shape primitives

Through[{Mean,Variance}[areas]]

Histogram[areas,100]

Monte Carlo

(10^7)

Length[pts3=Select[2Table[Random[],{10^7},{3}]-1,Norm[#]<1&]]//Timing

Length[tris3=Partition[pts3,3]]

Mean[data=TriangleArea3D/@tris3]//Timing

Histogram[data,{.02},"PDF",AxesLabel->{A,P[A]}]

(10^8)

Length[pts3=Select[2Table[Random[],{10^8},{3}]-1,Norm[#]<1&]]//Timing

Length[tris3=Partition[pts3,3]]

Mean[data=TriangleArea3D/@tris3]//Timing

MaxMemoryUsed[]/10^9.GB

Probability of Obtaining an Acute Triangle

Monte Carlo

2-D

N[Count[Triangle/@tris,_?ObtuseQ]/Length[tris],10]//Timing

1-Last[%]

Exact value is supposed to be (Subscript[P, 2])= 4/(π^2)-1/8≈0.280285.

3-D

N[Count[Triangle@@@Polygon2D/@tris3,_?ObtuseQ]/Length[tris3],10]//Timing

1-Last[%]

Exact value is supposed to be (Subscript[P, 3])= 33/70≈0.471429.

Exact

p[n_Integer?OddQ]:=Module[{m=(n-1)/2,k},
m Binomial[2m,m]^2 2^(2m) Sum[Binomial[2k,k](3m+k+1)/(m+k)/(4m+2k+1)/Binomial[2m+k,m]/Binomial[4m+2k,2m+k],{k,0,m}]-1/2-2^(2m-1) Binomial[2m,m]Binomial[4m,2m]/Binomial[4m,m]/Binomial[6m+1,2m]
]

p[n_Integer?EvenQ]:=Module[{m=(n-2)/2,k},
2^(4m)/Binomial[2m,m]/Pi^2 (Sum[2^(2k)(3m+k+3)/Binomial[2k,k]/(2k+1)/Binomial[2m+k,m]/Binomial[2m+k+2,2],{k,0,m}]+1/(2m+1)^2/Binomial[2m,m])+1/4-3/2^(2m+4)Binomial[4m+4,m+1]/Binomial[2m+2,m+1]
]

Plot

ListPlot[Table[p[n],{n,2,20}],AxesLabel->{n,Subscript[P,n]}]

Values

Table[{n,p[n]},{n,2,10}]//ColumnForm//TraditionalForm

N[%]

Explicit

Even

FullSimplify[With[{m=(n-2)/2},
2^(4m)/Binomial[2m,m]/Pi^2 (Sum[2^(2k)(3m+k+3)/Binomial[2k,k]/(2k+1)/Binomial[2m+k,m]/Binomial[2m+k+2,2],{k,0,m}]+1/(2m+1)^2/Binomial[2m,m])+1/4-3/2^(2m+4)Binomial[4m+4,m+1]/Binomial[2m+2,m+1]],n∈Integers&&n>0&&Mod[n,2]==0]

Odd

(expr=FullSimplify[With[{m=(n-1)/2},
m Binomial[2m,m]^2 2^(2m) Sum[Binomial[2k,k](3m+k+1)/(m+k)/(4m+2k+1)/Binomial[2m+k,m]/Binomial[4m+2k,2m+k],{k,0,m}]-1/2-2^(2m-1) Binomial[2m,m]Binomial[4m,2m]/Binomial[4m,m]/Binomial[6m+1,2m]],
n∈Integers&&n>0&&Mod[n,2]==1
])//TraditionalForm

However, this expression is valid for all n, not just odd

expr=(1/4) (4-(((4^(1-n)) (Sqrt[π]) Gamma[2 n])/(Gamma[((3 n)/2)] Gamma[((1+n)/2)]))+(1/(π^(3/2)))((2^(-3+2 n)) (-1+n) n ((Gamma[(n/2)])^4) (-2 HypergeometricPFQRegularized[{1,n,((2+n)/2)},{((3 n)/2),((3+n)/2)},1]+n HypergeometricPFQRegularized[{1,1+n,((2+n)/2)},{((3+n)/2),1+((3 n)/2)},1])));

v=Table[expr,{n,9}];

N[v]

FullSimplify[v]//ColumnForm