3
$\begingroup$

I keep seeing a notebook to use of Mathematica as a 3D Printing tool (e.g.: this link). In the notebook on slide 8/11, we find these pictures:

enter image description here enter image description here enter image description here enter image description here enter image description here

I'd like to design it as such that, but I don't know how to create the above examples. Thanks a lot!

Improve this question
$\endgroup$
3
  • $\begingroup$ Have you tried emailing the author of the notebook? $\endgroup$
    – bill s
    Jan 26, 2015 at 13:26
  • $\begingroup$ Interesting question! It will require something along this lines, if you are into relying on bitmap patterns: 1. EdgeDetect for the pattern image 2. Extraction of the contours, possibly using ImageValuePositions and constructing closed paths from that data. 3. Creating a hollowed region (hollow within some boundary you chose). 4. Deforming the region in 3D, using e.g. a 2D-Gaussian. 5. Extruding the deformed region by the target thickness you desire. 6. Constructing something of the shape by translation and rotation, e.g. something like the cube you mentioned. As I said: Interesting! $\endgroup$
    – Jinxed
    Jan 27, 2015 at 19:57
  • $\begingroup$ Then again, you could start out with your own regions, e.g. a disk, rectangle, superellipse or whatever, and transform/rotate to follow along a e.g. logarithmic spiral, putting all this into a BoundaryRegion and continue with the steps from my last comment, saving you the hassle of dealing with pixelated input. $\endgroup$
    – Jinxed
    Jan 27, 2015 at 20:05

1 Answer 1

Reset to default
3
$\begingroup$

Using a Graphics3D object from that file (4th object down from the top of slide 8)

enter image description here

(which I'm calling p) we can reconstruct your graphic as follows:

z = Union@
   Cases[p[[1]], {x_Real, y_Real, z_Real} :> {{x, y}, 
      z}, {0, \[Infinity]}];
d2 = DiscretizeGraphics@
   Graphics@
    Replace[p[[1]], {x_Real, y_Real, z_Real} :> {x, 
       y}, {0, \[Infinity]}];
b = BoundaryMesh[
   RegionProduct[d2, MeshRegion[{{0}, {1}}, Line[{1, 2}]]]];
iz = Quiet@Interpolation[z];
len = RegionBounds[b][[1, 2]];
mc = MeshCoordinates[
    b] /. {{x_, y_, 0.} :> {x, y, iz[x, y]}, {x_, y_, 1.} :> {x, y, 
      iz[x, y] + 1}};
mr = MeshRegion[mc, MeshCells[b, 2]];
m2 = Show[mr, 
   TransformedRegion[
    TransformedRegion[mr, RotationTransform[Pi, {1, 0, 0}]], 
    TranslationTransform[{0, 0, len*2}]]];
out = Show[m2, 
  Graphics3D[
   GeometricTransformation[
    GeometricTransformation[
     m2[[1]], {RotationMatrix[90 Degree, {0, 1, 0}]}], 
    TranslationTransform[{-50.8, 0, 50.8}]]], 
  Graphics3D[
   GeometricTransformation[
    GeometricTransformation[
     m2[[1]], {RotationMatrix[90 Degree, {1, 0, 0}]}], 
    TranslationTransform[{0, 50.8, 50.8}]]]]

enter image description here

Improve this answer
$\endgroup$
2
  • $\begingroup$ I really really appreciate your help! $\endgroup$
    – Xiang Li
    Feb 15, 2015 at 1:05
  • $\begingroup$ @XiangLi You're welcome :) $\endgroup$
    – M.R.
    Feb 15, 2015 at 3:32

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge that you have read and understand our privacy policy and code of conduct.

Not the answer you're looking for? Browse other questions tagged or ask your own question.