26
$\begingroup$

I want to create the following graphicenter image description here (ignore the unit vectors).

What I do is the following (not the most elegent and smart way I guess:-)!):

1) Use the code below to generate randomly distributed but not intersecting circles (I adopt the code from this forum but I don't remember the thread. Actually I learnt from my recent posts other ways to do this.)

distinct[n_, r_] := Module[{d, f, p}, d = {Disk[RandomReal[{-1, 1}, 2], r]}; Do[f = RegionDistance[RegionUnion @@ d]; While[p = RandomReal[{-1, 1}, 2]; f[p] < r]; d = Append[d, Disk[p, r]], {n - 1}]; d]

Generate the circles

circles = distinct[75, 0.1];

Generate the respective cylinders which have this circles as cross sections.

cylinders = Graphics3D[{Cyan, EdgeForm[Thick], Cylinder[{{#[[1]], #[[2]], -3}, {#[[1]], #[[2]], 3}}, 0.1] & /@ Map[First, fibers]}, PlotRange -> {{-1, 1}, {-1, 1}, Automatic}, Lighting -> "Neutral"];

Generate the parallelepiped.

par= Graphics3D[{Blue, EdgeForm[Thick], Opacity[0.6], Cuboid[{-1, -1, -3}, {1, 1, 3}]}, Lighting -> "Neutral"];

And adding them altogether

Show[{cylinders, par}, PlotRange -> {{-1, 1}, {-1, 1}, Automatic}, Boxed -> False]

But the result is quite unsatisfactory.

I will appreciate any help. Thanks in advance!

Improve this question
$\endgroup$
2
  • 1
    $\begingroup$ A bit related: How to plot contours in the faces of a cube $\endgroup$ Commented Nov 5, 2015 at 20:00
  • $\begingroup$ You can find almost everything here:-)! $\endgroup$ Commented Nov 5, 2015 at 20:04

4 Answers 4

Reset to default
43
$\begingroup$

Firstly, let us generate some set of random circles with findPoints from this answer

findPoints = Compile[{{n, _Integer}, {low, _Real}, {high, _Real}, {minD, _Real}}, Block[{data = RandomReal[{low, high}, {1, 2}], k = 1, rv, temp}, While[k < n, rv = RandomReal[{low, high}, 2]; temp = Transpose[Transpose[data] - rv]; If[Min[Sqrt[(#.#)] & /@ temp] > minD, data = Join[data, {rv}]; k++;];]; data]]; npts = 150; r = 0.03; minD = 2.2 r; low = 0; high = 1; pts = findPoints[npts, low, high, minD]; g2d = Graphics[{FaceForm@Lighter[Blue, 0.8], EdgeForm@Directive[Thickness[0.004], Black], Disk[#, r] & /@ pts}, PlotRange -> {{low, high}, {low, high}}, Background -> Lighter@Blue]

enter image description here

Method 1: Texture

We can simply use this graphics as a texture of the cube

pad = 0.1; coords = Tuples[{0, 1}, 3]; cube = Polygon[{{1, 3, 7, 5}, {1, 5, 6, 2}, {5, 7, 8, 6}, {7, 3, 4, 8}, {3, 1, 2, 4}, {6, 8, 4, 2}}]; vtc = pad + (1 - 2 pad) coords[[;; , {1, 3}]]; Graphics3D[{Texture[g2d], GraphicsComplex[coords, cube, VertexTextureCoordinates -> vtc]}, Lighting -> "Neutral", Boxed -> False, ImageSize -> 500]

enter image description here

Method 2: MeshRegion

I'm appreciate many upvotes so I want to expand my answer and add a more general approach. Mathematica has very powerful (and still very limited) region functions.

Let's try to use some interesting 2D mask:

mask = BoundaryDiscretizeRegion[#, {{0, 1}, {0, 1}}, MaxCellMeasure -> {1 -> .02}] &@ ImplicitRegion[ 0.1 < x < 0.9 && 0.1 < y < 0.9 + 0.05 Sin[20 x], {x, y}]; r2d = DiscretizeGraphics[g2d, MaxCellMeasure -> {1 -> .01}, PlotRange -> All]; inside = RegionIntersection[r2d, mask]

enter image description here

Then I find the edge and points on the edge. Unfortunately RegionIntersection doesn't work with lines and points. Here is workaround

edge = DiscretizeRegion@*Line@*Intersection @@ Round[{Sort /@ MeshPrimitives[RegionIntersection[r2d, mask], 1][[;; , 1]], Sort /@ MeshPrimitives[RegionDifference[r2d, mask], 1][[;; , 1]]}, .0001]; points = DiscretizeRegion@*Point@*Intersection @@ Round[{MeshPrimitives[RegionDifference[r2d, mask], 0][[;; , 1]], MeshPrimitives[RegionDifference[mask, r2d], 0][[;; , 1]]}, .0001];

Then I want to make RegionProduct to create 3D regions from corresponding 2D regions. I also have to use hand-written workaround

regionProduct[reg_, join_: True, y1_: 0, y2_: 1] := Module[{n = MeshCellCount[reg, 0]}, MeshRegion[Join @@ (ArrayFlatten@{{#[[;; , ;; 1]], #2, #[[;; , 2 ;;]]}} &[ MeshCoordinates@reg, #] & /@ {y1, y2}), {MeshCells[reg, _], MeshCells[reg, _] /. p : {__Integer} :> p + n, If[join, MeshCells[reg, _] /. {(Polygon | Line)[ p_] :> (Polygon@Join[#, Reverse[#, 2] + n, 2] &@ Partition[p, 2, 1, 1]), Point[p_] :> Line@{p, p + n}}, ## &[]]}]]; mask3d = regionProduct@mask; inside3d = regionProduct[inside, False]; edge3d = regionProduct@edge; points3d = regionProduct@points;

The result is impressive

toGC[reg_, dim_] := GraphicsComplex[MeshCoordinates@reg, MeshCells[reg, dim]]; Graphics3D[{FaceForm@Lighter[Blue, 0.7], toGC[inside3d, 2], EdgeForm[], toGC[edge3d, 2], toGC[points3d, 1], Lighter@Blue, GeometricTransformation[toGC[mask3d, 2], ScalingTransform[0.999 {1, 1, 1}, RegionCentroid@mask3d]]}, Lighting -> "Neutral", Boxed -> False]

enter image description here

Also with transparency:

Graphics3D[{FaceForm@Lighter[Blue, 0.7], toGC[regionProduct[RegionBoundary@inside, False], 1], EdgeForm[], toGC[regionProduct@inside, 2], toGC[edge3d, 2], toGC[points3d, 1], Blue, Opacity[0.03], GeometricTransformation[toGC[mask3d, 2], ScalingTransform[0.999 {1, 1, 1} #, RegionCentroid@mask3d] & /@ Range[0, 1, 0.01]]}, Lighting -> "Neutral", Boxed -> False, BaseStyle -> {RenderingOptions -> {"DepthPeelingLayers" -> 100}}]

enter image description here

I hope future versions will do it more automatically.

Improve this answer
$\endgroup$
14
  • 1
    $\begingroup$ @dimitris, it is a cross section of the circle near its edge. Circles have black edge with nonzero thickness. After texture interpolation it smooths and becomes gray. You can find more accurate random realization of circles. $\endgroup$ Commented Nov 5, 2015 at 19:29
  • 2
    $\begingroup$ Can you explain coords[[;; , {1, 3}]]? I see it yields {{0, 0}, {0, 1}, {0, 0}, {0, 1}, {1, 0}, {1, 1}, {1, 0}, {1, 1}}, but I don't know why. Thanks! $\endgroup$ Commented Nov 6, 2015 at 1:17
  • 2
    $\begingroup$ @JosephO'Rourke It's projection of coordinates to x-z plane $\endgroup$ Commented Nov 6, 2015 at 1:46
  • 1
    $\begingroup$ @dimitris It is number of coords, which makes faces of the cube. You are right, I rotated the graphics manually. Now regionProduct expands in the y direction for the proper orientation. $\endgroup$ Commented Nov 6, 2015 at 11:01
  • 1
    $\begingroup$ Very very nice +1 $\endgroup$ Commented Nov 6, 2015 at 11:15
7
$\begingroup$

Although I think that some of the options presented on the other answers are better, this one is probably the one with the shortest code on the 3D aspect:

Starting from any of the 2D generated graphics, from the other answers, hereafter named g2d:

Image3D[{Rasterize[g2d]}, BoxRatios -> 1]

enter image description here

and a lot of tweaking is possible with the Image3D options.

Improve this answer
$\endgroup$
10
  • $\begingroup$ Thank you very much! I think my collegue who is afraid of large codes will love this solution:-)! $\endgroup$ Commented Nov 6, 2015 at 14:59
  • $\begingroup$ @dimitris and I just reduced a few more characters... (I recently participated on the one-liner... :-) $\endgroup$ Commented Nov 6, 2015 at 15:16
  • $\begingroup$ I don't know why but I cannot reproduce your result. I got error message: Image3D::imgarray: The specified argument... $\endgroup$ Commented Nov 6, 2015 at 16:27
  • $\begingroup$ @dimitris You have to put the image inside a list. Have you done that? {g2d} I'm on 10.3.0. If it doesn't work, try to repeat the image {g2d, g2d} $\endgroup$ Commented Nov 6, 2015 at 16:35
  • $\begingroup$ Same error message with Image3D[{g2d}, BoxRatios -> 1] & Image3D[{g2d, g2d}, BoxRatios -> 1]. Strangely the Documentation Center says Introduced in 2012 (9.0) | Updated in 2014 (10.0) for this function (reference.wolfram.com/language/ref/Image3D.html) $\endgroup$ Commented Nov 6, 2015 at 16:39
4
$\begingroup$

How about DensityPlot3D or ListDensityPlot3D.

DensityPlot3D[ Sin[\[Pi] z] + Cos[\[Pi] x], {x, -6, 6}, {y, -4, 4}, {z, -4.5, 4.5}, OpacityFunction -> Function[f, If[f > 1, 1, .5]], OpacityFunctionScaling -> False, ColorFunction -> Function[f, If[f > 1, Gray, Blue]], ColorFunctionScaling -> False]

enter image description here

Improve this answer
$\endgroup$
3
  • $\begingroup$ If you notice I want the cylinders randomly distributed. Thanks anyway for the answer. $\endgroup$ Commented Nov 5, 2015 at 22:45
  • $\begingroup$ It is an interesting idea. May be you can use NearestFunction with some random points. $\endgroup$ Commented Nov 6, 2015 at 3:29
  • $\begingroup$ @ybektukov: You are right. The solution of Edmund is very nice and I agree it can be further extended. $\endgroup$ Commented Nov 6, 2015 at 8:47
3
$\begingroup$

Nothing new here. Just a workaround following the new things I learn from ybeltukov amazing answer (and copy them:-)!).

Use the code below to generate randomly distributed but not intersecting disks

distinct[n_, r_] := Module[{d, f, p}, d = {Disk[RandomReal[{0, 1}, 2], r]}; Do[f = RegionDistance[RegionUnion @@ d]; While[p = RandomReal[{0, 1}, 2]; f[p] < r]; d = Append[d, Disk[p, r]], {n - 1}]; d] disks // Clear SeedRandom[159] disks = distinct[75, 0.03]; g2d = Graphics[{FaceForm@Lighter[Blue, 0.8], EdgeForm@Directive[Thickness[0.004], Black], disks}, PlotRange -> {{0, 1}, {0, 1}}, Background -> Lighter@Blue]

Texture...

pad = 0.1; coords = Tuples[{0, 1}, 3]; cube = Polygon[{{1, 3, 7, 5}, {1, 5, 6, 2}, {5, 7, 8, 6}, {7, 3, 4, 8}, {3, 1, 2, 4}, {6, 8, 4, 2}}]; vtc = pad + (1 - 2 pad) coords[[;; , {1, 3}]];

and the 3D final drawing...

Graphics3D[{Texture[g2d], GraphicsComplex[coords, cube, VertexTextureCoordinates -> vtc]}, Lighting -> "Neutral", Boxed -> False, ImageSize -> 500]

enter image description here

enter image description here

And a bit of cylinders now...(do not expect something advanced here:-)!)

mycylinders = Cylinder[{{#[[1]], #[[2]], -3}, {#[[1]], #[[2]], 3}}, 0.03] & /@ Map[First, disks]; cub = Graphics3D[{FaceForm@Blue, Opacity[0.2], Cuboid[{0, 0, -3}, {1, 1, 3}]}, Lighting -> "Neutral"]; Show[{Graphics3D[{FaceForm@Lighter[Blue, 0.7], Lighting -> "Neutral", BaseStyle -> {RenderingOptions -> {"DepthPeelingLayers" -> 100}}, mycylinders}], cub}, Boxed -> False, PlotRange -> {{0, 1}, {0, 1}, Automatic}]

enter image description here

I guess the final drawing can be made much better...

Improve this answer
$\endgroup$
2
  • $\begingroup$ Just a side note: BaseStyle -> {RenderingOptions -> {"DepthPeelingLayers" -> 100}} is a specific option to plot complicated semi-transparent graphics (e.g. in quasi-volumetric rendering). $\endgroup$ Commented Nov 6, 2015 at 12:05
  • $\begingroup$ Thanks for the comment. I will modify it! $\endgroup$ Commented Nov 6, 2015 at 12:11

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.