Cross posted on mathematica.stackexchange - https://mathematica.stackexchange.com/q/144167/5478
Question
Given a list of points on a sphere and the sphere/radius I'd like to plot a spherical polygon with vertices in those points.
And this needs to be fast, fast enough for the user to not "feel" generation time.
One should be able to style them too. Most importantly the surface but an edge style would be nice aswell.
What have I tried?
This is very closely related topic but answers there are not fast enough for my needs.
Is great but "only good for making spherical quadrilaterals, or isosceles spherical triangles".
ClipPlanes
in V11+ can be used as a directive which is very effective:
RandomSeed[3];
pts = Normalize /@ RandomReal[{-1, 1}, {3, 3}]
Graphics3D[
{AbsolutePointSize@12, Point@pts,
Red, Sphere[{0, 0, 0}, .999], Blue,
Style[Sphere[], ClipPlanes -> {
InfinitePlane[{#, #2, {0, 0, 0}}],
InfinitePlane[{{0, 0, 0}, #3, #}],
InfinitePlane[{{0, 0, 0}, #2, #3}]
},
ClipPlanesStyle -> Directive[Opacity@.2, Red]]
}
] & @@ pts
But I'd need to write some code to determine in what order should those points be put in InfinitePlanes
in order to clip from the right side (ClipPlane orientation). I didn't do this because I was too lazy and because:
> The number of clipping planes that can be implemented with ClipPlanes is limited by available graphics hardware.
So it won't be general enough. Though if you want to make this method automatic I will gladly upvote it.
Motivation
I think it will be useful in many applications.
I don't have time for this but I thought it would be a nice feature to have to improve code I was playing with lately, mostly based on another J.M.'s answer - Voronoi grid on a sphere
arc[center_?VectorQ, {start_?VectorQ, end_?VectorQ}] := Module[{ang, co, r}, ang = VectorAngle[start - center, end - center];
co = Cos[ang/2]; r = EuclideanDistance[center, start];
{{start, center + r/co Normalize[(start + end)/2 - center], end}, co}
]
points = {2 \[Pi] #1, ArcCos[2 #2 - 1]} & @@@ RandomReal[1, {10, 2}];
sp = Append[Sin[#2] Through[{Cos, Sin}[#1]], Cos[#2]] & @@@ points;
proc[] := (
ch = ConvexHullMesh[sp];
verts = MeshCoordinates[ch]; polys = First /@ MeshCells[ch, 2];
voro = Normalize[ Cross[verts[[#2]] - verts[[#1]], verts[[#3]] - verts[[#1]]]] & @@@ polys;
edges = arc[{0, 0, 0}, voro[[##]]] & /@ Select[Subsets[Range[Length[polys]], {2}], Length[Intersection @@ polys[[#]]] >= 2 &];
);
proc[];
DynamicModule[{run = True}, Graphics3D[{ {Opacity[.75],
DynamicWrapper[EventHandler[Sphere[],
"MouseMoved" :> Module[{pos = MousePosition["Graphics3DBoxIntercepts", True],
pt}, If[
Not@TrueQ@pos , pt = RegionIntersection[Sphere[], Line@pos];
If[pt =!= EmptyRegion[3], sp[[-1]] = First@Nearest[pt[[1]], pos[[1]]]; proc[]] ]]]
, TrackedSymbols :> {run}
]
}
, {AbsoluteThickness[2],
Dynamic[BSplineCurve[#, SplineDegree -> 2,
SplineKnots -> {0, 0, 0, 1, 1, 1},
SplineWeights -> {1, #2, 1}] & @@@ edges]}
, {Red, Sphere[Most@sp, .02], Dynamic@Sphere[Last@sp, .02]}
}
, PlotRange -> 1.1 , SphericalRegion -> True , ImageSize -> 500]
]
To look more like https://www.jasondavies.com/maps/voronoi/