Drawing circular patches around arbitrary points on a sphere
Here is a routine that renders a spherical cap on a unit sphere as a NURBS surface:
sphericalCap[{θ_, φ_}, α_] := With[{c = Cos[α/2]},
Style[BSplineSurface[Map[RotationTransform[{{0, 0, 1},
Append[{Cos[θ], Sin[θ]} Sin[φ], Cos[φ]]}],
Map[Function[pt, Append[#1 pt, #2]],
{{1, 0}, {1, 1}, {-1, 1}, {-1, 0}, {-1, -1}, {1, -1}, {1, 0}}] & @@@
{{0, 1}, {Sin[α/2]/c, 1}, {Sin[α], Cos[α]}}],
SplineClosed -> {False, True}, SplineDegree -> 2,
SplineKnots -> {{0, 0, 0, 1, 1, 1},
{0, 0, 0, 1/4, 1/2, 1/2, 3/4, 1, 1, 1}},
SplineWeights -> Outer[Times, {1, c, 1}, {1, 1/2, 1/2, 1, 1/2, 1/2, 1}]],
BSplineSurface3DBoxOptions -> {Method -> {"SplinePoints" -> 25}}]]
Examples:
Graphics3D[{Opacity[0.7, Black], sphericalCap[{0, 0}, π/6]}, Axes -> True]
BlockRandom[SeedRandom["spherecaps"];
Graphics3D[{EdgeForm[], Table[{Append[RandomColor[], 2/3],
sphericalCap[{RandomReal[{0, 2 π}], RandomReal[{0, π}]},
RandomReal[{0, π/4}]]}, {10}]}]]
Graphics3D[{Directive[EdgeForm[], GrayLevel[1/5],
Glow[Blend[{Brown, Yellow}, 1/4]], Specularity[Gray, 25]],
sphericalCap[{ArcTan @@ Most[#], ArcCos[Last[#]]},
ArcCos[(80 + 9 Sqrt[5])/109]/2] & /@
N[PolyhedronData["TruncatedIcosahedron", "VertexCoordinates"]/
PolyhedronData["TruncatedIcosahedron", "Circumradius"]]},
Boxed -> False, Lighting -> "Neutral"]
Show[
SphericalPlot3D[1, {θ, 0, π}, {ϕ, 0, 2 π}, Mesh -> None, RegionFunction ->
Function[{x, y, z, θ, ϕ, r}, Norm[{x, y, z} - {1, 1, 0}] > 1], PlotStyle -> Red],
SphericalPlot3D[1, {θ, 0, π}, {ϕ, 0, 2 π}, Mesh -> None, RegionFunction ->
Function[{x, y, z, θ, ϕ, r}, Norm[{x, y, z} - {1, 1, 0}] < 1], PlotStyle -> Blue]]
Here's a way using MeshFunctions
and MeshShading
that generalized to any number of points.
pts = Normalize /@ RandomReal[{-1, 1}, {2, 3}];
angles = Table[{Pi/3}, Length@pts];
SphericalPlot3D[1, {θ, 0, Pi}, {ϕ, 0, 2 Pi},
MeshFunctions ->
Table[With[{v0 = v0},
Function[{x, y, z, θ, ϕ},
VectorAngle[{x, y, z}, v0]]], {v0, pts}],
Mesh -> angles,
MeshShading -> {{Black, Black}, {Black, Automatic}},
BoundaryStyle -> None]
More random points, random angles:
SeedRandom[7];
pts = Normalize /@ RandomReal[{-1, 1}, {3, 3}];
angles = RandomReal[0.66, {Length@pts, 1}];
shading = ReplacePart[
ConstantArray[Black, Table[2, Length@pts]],
Table[-1, Length@pts] -> Automatic];
SphericalPlot3D[1, {θ, 0, Pi}, {ϕ, 0, 2 Pi},
PlotPoints -> 50,
MeshFunctions ->
Table[With[{v0 = v0},
Function[{x, y, z, θ, ϕ},
VectorAngle[{x, y, z}, v0]]], {v0, pts}],
Mesh -> angles,
MeshShading -> shading,
BoundaryStyle -> None, MeshStyle -> None]