Sphere clipping

marveloustau

那就来个好玩儿的吧，前两天随手写的。

1. ApplyClippingFunction =
   
2.   Function[{x, y, z},
   
3.     And @@ (Function[o,
   
4.         Plus @@ ({x, y, z} o[[1]]) < o[[2]]] /@ #)] &;
   
5. ApplyPlottingRange = {{x, #[[1, 1]] + #[[2]], #[[1, 1]] - #[[
   
6.        2]]}, {y, #[[1, 2]] + #[[2]], #[[1, 2]] - #[[2]]}, {z, #[[1,
   
7.        3]] + #[[2]], #[[1, 3]] - #[[2]]}} &;
   
8. DrawingParameters := {Mesh -> False, Boxed -> False, Axes -> False,
   
9.     ContourStyle ->
   
10.      Directive[ColorData["StarryNightColors"][RandomReal[{0.7, 1}]],
    
11.       Opacity[0.7], Specularity[White, 30]]} &;
    
12. 
    
13. DrawSphere = ContourPlot3D[
    
14.     Plus @@ (({x, y, z} - First@#1)^2) == Last@#1^2,
    
15.     Evaluate[Sequence @@ ApplyPlottingRange[#1]],
    
16.     Evaluate[Sequence @@ DrawingParameters],
    
17.     RegionFunction -> ApplyClippingFunction[#2]
    
18.     ] &;

复制代码

1. DistanceSquare =
   
2.   Plus @@ ((#2[[1]] - #1[[1]])^2) &(*Square of center distance*);
   
3. Ratio = (#1[[2]]^2 + DistanceSquare[#1, #2] - #2[[2]]^2)/(2
   
4.       DistanceSquare[#1, #2]) &;
   
5. ClipPlane =
   
6.   If[#1 == #2, {{0, 0, 0},
   
7.      Infinity}, {#2[[1]] - #1[[
   
8.        1]], (#2[[1]] - #1[[1]]).(#1[[1]] + (#2[[1]] - #1[[1]])*
   
9.          Ratio[#1, #2])}] &;
   
10. 
    
11. GetPlaneListOfSingleSphere[sphereList_List, i_Integer] :=
    
12.   ClipPlane[sphereList[[i]], #] & /@ Drop[sphereList, {i}];
    
13. DrawIthClippedSphere[sphereList_List, i_Integer] :=  
    
14.   DrawSphere[sphereList[[i]],
    
15.    GetPlaneListOfSingleSphere[sphereList, i]];
    
16. DrawAllSpheres[sphereList_List] :=
    
17.   DrawIthClippedSphere[sphereList, #] & /@ Range[Length[sphereList]];
    
18. 
    
19. GenerateSpheres[centerRange_, radiusRangeL_, radiusRangeR_,
    
20.   pointNumber_] :=
    
21. Transpose@{RandomReal[{-centerRange, centerRange}, {pointNumber, 3}],
    
22.     RandomReal[{radiusRangeL, radiusRangeR}, pointNumber]}
    
23. 
    
24. Show[{DrawAllSpheres[A = GenerateSpheres[5, 3, 6, 8]]}, Boxed -> True,
    
25.   PlotRange -> 10]

复制代码

yyhdolphin

欣赏了     看不懂  但是还是看了  呵呵  谢谢

FreddyMusic

最近我对计算几何也非常着迷，它大大超出了我的想象力。

weichanghe2000

呵呵，永远跟不上 tao的 思维啊，太神奇了。