Skip to main content

graphics3d - How to generate random non-overlapping cylinders of fixed radius and height in a fixed cube?


I have seen these two questions (first) (second) which are related to generating non-overlapping cylinders in a cube. I am trying to adapt them to my goal which is to generate random non-overlapping fixed cylinders (radius=10nm and height=20nm) in a cube of (100*100*100 nm).



The number of cylinders would be 20, 40 and 60 for the three cases that I would like to build. This makes the volume fraction in the range of around 0.1, 0.2 and 0.3 for the three cases.


Then at the end I would like to export the coordinates of each cylinders (x1,y1,z1) &(x2,y2,z2) in a file.


I have been using the following reference code as an example and trying to modify this.


    p1.p1 + p2.p2 - 2 p1.p2
((p1.p1 + p2.p2 - 2 p1.p2) /. {p1 -> p1i + dp1 t1, p2 -> p2i + dp2 t2}) // tf // Expand
(* p1i.p1i - 2 p1i.p2i + p1i.(dp1 t1) - 2 p1i.(dp2 t2) + p2i.p2i +
p2i.(dp2 t2) + (dp1 t1).p1i - 2 (dp1 t1).p2i + (dp1 t1).(dp1 t1) -
2 (dp1 t1).(dp2 t2) + (dp2 t2).p2i + (dp2 t2).(dp2 t2) *)



tf[e_] := e /. Dot[z1_ + z2_, z3_ + z4_] ->
Dot[z1, z3] + Dot[z2, z3] + Dot[z1, z4] + Dot[z2, z4]

Map[# /. z_ :> (z /. t1 -> 1) t1^Count[z, t1, 4] &,
Map[# /. z_ :> (z /. t2 -> 1) t2^Count[z, t2, 4] &, %]]
(* t1^2 dp1.dp1 - 2 t1 t2 dp1.dp2 + t1 dp1.p1i - 2 t1 dp1.p2i + t2^2 dp2.dp2 +
t2 dp2.p2i + t1 p1i.dp1 - 2 t2 p1i.dp2 + p1i.p1i - 2 p1i.p2i + t2 p2i.dp2 + p2i.p2i *)

FullSimplify[Solve[{D[%, t1] == 0, D[%, t2] == 0}, {t1, t2}],
TransformationFunctions -> {Automatic, tf1}]

(* {{t1 -> (dp2.dp1 (-dp2.p1i + dp2.p2i) +
dp2.dp2 (p1i.dp1 - p2i.dp1))/((dp1.dp2)^2 - dp1.dp1 dp2.dp2),
t2 -> (dp1.dp1 (-dp2.p1i + dp2.p2i) +
dp2.dp1 (p1i.dp1 - p2i.dp1))/((dp1.dp2)^2 - dp1.dp1 dp2.dp2)}} *)

tf1[e_] := e /. Dot[z1_, z2_] -> Dot[z2, z1]

int[cyl1_, cyl2_] :=
Module[{p1i = cyl1[[1, 1]], dp1 = cyl1[[1, 2]] - cyl1[[1, 1]], r1 = cyl1[[2]],
p2i = cyl2[[1, 1]], dp2 = cyl2[[1, 2]] - cyl2[[1, 1]], r2 = cyl2[[2]],

loc, t1, t2}, loc = {t1 -> (dp2.dp1 (-dp2.p1i + dp2.p2i) +
dp2.dp2 (p1i.dp1 - p2i.dp1))/((dp1.dp2)^2 - dp1.dp1 dp2.dp2),
t2 -> (dp1.dp1 (-dp2.p1i + dp2.p2i) +
dp2.dp1 (p1i.dp1 - p2i.dp1))/((dp1.dp2)^2 - dp1.dp1 dp2.dp2)};
(-r2/Norm[dp2] < (t1 /. loc) < 1 + r2/Norm[dp2]) &&
(-r1/Norm[dp1] < (t2 /. loc) < 1 + r1/Norm[dp1]) &&
((t1^2 dp1.dp1 - 2 t1 t2 dp1.dp2 + t1 dp1.p1i - 2 t1 dp1.p2i + t2^2 dp2.dp2 +
t2 dp2.p2i + t1 p1i.dp1 - 2 t2 p1i.dp2 + p1i.p1i - 2 p1i.p2i + t2 p2i.dp2 +
p2i.p2i) /. loc) < (r1 + r2)^2]


cylinders = Table[{RandomReal[{-100, 100}, {2, 3}], RandomReal[5]}, {100}];
nint = ParallelTable[Or @@ Table[int[cylinders[[i]], cylinders[[j]]], {j, i + 1, 100}],
{i, 100}];
c = Cases[{cylinders, nint} // Transpose, {z_, False} -> z, {1}];
Graphics3D[{EdgeForm[None], Directive[Opacity@RandomReal[{.4, .9}], Hue[RandomReal[]]],
Cylinder[First@#, Last@#]} & /@ c, Boxed -> False, ImageSize -> 800]

Any heads up would be helpful.



Answer



Edited to Improve Definition of cylinders



This problem differs from the two referenced in the question in three important ways. The cylinders are precisely confined within a box, the filling factor is much larger, and the aspect ratio of the cylinders is essentially unity. With perfect ordering, 125 cylinders can fit into the box. As soon as only a few are placed randomly, the maximum number of remaining cylinders that fit drops precipitously. To take these considerations into account, int (which determines whether two cylinders are non-overlapping) was modified from the referenced answers.


int[cyl1_, cyl2_] := Module[{p1i = cyl1[[1, 1]], dp1 = cyl1[[1, 2]] - cyl1[[1, 1]], 
r1 = cyl1[[2]], p2i = cyl2[[1, 1]], dp2 = cyl2[[1, 2]] - cyl2[[1, 1]],
r2 = cyl2[[2]], loc, t1, t2},
loc = {t1 -> Clip[(dp2.dp1 (-dp2.p1i + dp2.p2i) + dp2.dp2 (p1i.dp1 - p2i.dp1))/
((dp1.dp2)^2 - dp1.dp1 dp2.dp2), {- r1/Norm[dp1], 1 + r1/Norm[dp1]}],
t2 -> Clip[(dp1.dp1 (-dp2.p1i + dp2.p2i) + dp2.dp1 (p1i.dp1 - p2i.dp1))/
((dp1.dp2)^2 - dp1.dp1 dp2.dp2), {- r2/Norm[dp2], 1 + r2/Norm[dp2]}]};
((t1^2 dp1.dp1 - 2 t1 t2 dp1.dp2 + t1 dp1.p1i - 2 t1 dp1.p2i + t2^2 dp2.dp2 +
t2 dp2.p2i + t1 p1i.dp1 - 2 t2 p1i.dp2 + p1i.p1i - 2 p1i.p2i + t2 p2i.dp2 +

p2i.p2i) /. loc) > 2 (r1 + r2)^2]

Note that this function is only approximate and occasionally determines that two cylinders overlap when they do not. A precise determination could be obtained from


Volume@RegionIntersection[Cylinder @@ cylinders[[i]], Cylinder @@ cylinders[[j]]] == 0

but is orders of magnitude slower than int. The number of falsely excluded cylinders is not large. In addition, a second function is introduced to identify and eliminate cylinders that extend slightly beyond the 100 x 100 x 100 box. It is exact and quite fast.


inb[cyl_] := Module[{cos, d, rl = Last[cyl], hlf = Norm[cyl[[1, 1]] - cyl[[1, 2]]]/2},
And @@ Map[(cos = (cyl[[1, 1, #]] - cyl[[1, 2, #]])/(2 hlf);
d = hlf Abs[cos] + rl Sqrt[1 - cos^2];
(-50 + d < (cyl[[1, 1, #]] + cyl[[1, 2, #]])/2 < 50 - d)) &, {1, 2, 3}]]


The code to determine the non-overlapping cylinders then is,


(SeedRandom[1492]; ict = 2000000; rl = 10; hlf = 10; n = 60;
cylinders = Table[s = RandomReal[{-50 + rl, 50 - rl}, {3}]; zz = RandomReal[{-hlf, hlf}];
phi = RandomReal[{-Pi, Pi}];
{{s - {Sqrt[hlf^2 - zz^2] Cos[phi], Sqrt[hlf^2 - zz^2] Sin[phi], zz},
s + {Sqrt[hlf^2 - zz^2] Cos[phi], Sqrt[hlf^2 - zz^2] Sin[phi], zz}}, rl}, ict];
cylinders = Pick[cylinders, inb /@ cylinders];
c = {cylinders[[1]]};
Do[If[(And @@ Table[int[cylinders[[i]], c[[j]]], {j, Length[c]}]) && (Length[c] < n),

AppendTo[c, cylinders[[i]]]], {i, 2, Length[cylinders]}];
Length[c]) // AbsoluteTiming

(* {2412.55, 16} *)

Graphics3D[{EdgeForm[None], Directive[Opacity@RandomReal[{.4, .9}], Hue[RandomReal[]]],
Cylinder @@ #} & /@ c, ImageSize -> 800, PlotRange -> {{-50, 50}, {-50, 50}, {-50, 50}}]

enter image description here


Although some cylinders in the figure may appear to be overlap, rotating the figure within Mathematica shows that they are not. Significantly increasing the number of randomly placed cylinders will be difficult unless rl is decreased.



Result for rl == hlf == 7.


Reducing rl and hlf to 7 nearly triples the number of non-overlapping cylinders obtained, although slowly.


(* {6881.68, 45} *)

enter image description here


Result for 2:1 aspect ratio


At the request of the OP in a comment below, the code above has been modified modestly to accommodate independent values for the cylinder radius, rl, and half length, hlf. Choosing


ict = 10000; rl = 5; hlf = 10; n = 60

and the code otherwise as above yields



(* {29.1495, 42} *)

enter image description here


Minor Addition


At the OP's request, the parameter n has been added to the code above. It specifies the maximum number of non-overlapping cylinders to be generated. Of course, fewer may be generated, depending on the values of the other parameters, ict, rl, and hlf.


Comments

Popular posts from this blog

functions - Get leading series expansion term?

Given a function f[x] , I would like to have a function leadingSeries that returns just the leading term in the series around x=0 . For example: leadingSeries[(1/x + 2)/(4 + 1/x^2 + x)] x and leadingSeries[(1/x + 2 + (1 - 1/x^3)/4)/(4 + x)] -(1/(16 x^3)) Is there such a function in Mathematica? Or maybe one can implement it efficiently? EDIT I finally went with the following implementation, based on Carl Woll 's answer: lds[ex_,x_]:=( (ex/.x->(x+O[x]^2))/.SeriesData[U_,Z_,L_List,Mi_,Ma_,De_]:>SeriesData[U,Z,{L[[1]]},Mi,Mi+1,De]//Quiet//Normal) The advantage is, that this one also properly works with functions whose leading term is a constant: lds[Exp[x],x] 1 Answer Update 1 Updated to eliminate SeriesData and to not return additional terms Perhaps you could use: leadingSeries[expr_, x_] := Normal[expr /. x->(x+O[x]^2) /. a_List :> Take[a, 1]] Then for your examples: leadingSeries[(1/x + 2)/(4 + 1/x^2 + x), x] leadingSeries[Exp[x], x] leadingSeries[(1/x + 2 + (1 - 1/x...

How to thread a list

I have data in format data = {{a1, a2}, {b1, b2}, {c1, c2}, {d1, d2}} Tableform: I want to thread it to : tdata = {{{a1, b1}, {a2, b2}}, {{a1, c1}, {a2, c2}}, {{a1, d1}, {a2, d2}}} Tableform: And I would like to do better then pseudofunction[n_] := Transpose[{data2[[1]], data2[[n]]}]; SetAttributes[pseudofunction, Listable]; Range[2, 4] // pseudofunction Here is my benchmark data, where data3 is normal sample of real data. data3 = Drop[ExcelWorkBook[[Column1 ;; Column4]], None, 1]; data2 = {a #, b #, c #, d #} & /@ Range[1, 10^5]; data = RandomReal[{0, 1}, {10^6, 4}]; Here is my benchmark code kptnw[list_] := Transpose[{Table[First@#, {Length@# - 1}], Rest@#}, {3, 1, 2}] &@list kptnw2[list_] := Transpose[{ConstantArray[First@#, Length@# - 1], Rest@#}, {3, 1, 2}] &@list OleksandrR[list_] := Flatten[Outer[List, List@First[list], Rest[list], 1], {{2}, {1, 4}}] paradox2[list_] := Partition[Riffle[list[[1]], #], 2] & /@ Drop[list, 1] RM[list_] := FoldList[Transpose[{First@li...

front end - keyboard shortcut to invoke Insert new matrix

I frequently need to type in some matrices, and the menu command Insert > Table/Matrix > New... allows matrices with lines drawn between columns and rows, which is very helpful. I would like to make a keyboard shortcut for it, but cannot find the relevant frontend token command (4209405) for it. Since the FullForm[] and InputForm[] of matrices with lines drawn between rows and columns is the same as those without lines, it's hard to do this via 3rd party system-wide text expanders (e.g. autohotkey or atext on mac). How does one assign a keyboard shortcut for the menu item Insert > Table/Matrix > New... , preferably using only mathematica? Thanks! Answer In the MenuSetup.tr (for linux located in the $InstallationDirectory/SystemFiles/FrontEnd/TextResources/X/ directory), I changed the line MenuItem["&New...", "CreateGridBoxDialog"] to read MenuItem["&New...", "CreateGridBoxDialog", MenuKey["m", Modifiers-...