Group Abstract

Message Boards

WOLFRAM COMMUNITY

9.6K Views

2 Replies

10 Total Likes

View groups...

Follow this post

Share this post:

GROUPS:

Get 3D-printable Batman logo given cross section?

Cameron Walker

Posted 8 years ago

Hi, I am new to Mathematica. For a school project we have to do a model of a 3D shape with a known base and cross sections (i.e. squares, circles, etc...), find the volume of that shape via integration, and present the 3D model. Does anyone know how to get a diagram of this model on Mathematica, and how to use that model to get a 3D printable version of the shape? This is the plot for base I am working with: Plot[{ With[{ w=3Sqrt[1-(x/7)^2], l=(6/7)Sqrt[10]+(3+x)/2-(3/7)Sqrt[10]Sqrt[4-(x+1)^2], h=(1/2)(3(Abs[x-1/2]+Abs[x+1/2]+6)-11(Abs[x-3/4]+Abs[x+3/4])), r=(6/7)Sqrt[10]+(3-x)/2-(3/7)Sqrt[10]Sqrt[4-(x-1)^2]}, w+(l-w)UnitStep[x+3]+(h-l)UnitStep[x+1]+(r-h)UnitStep[x-1]+(w-r)UnitStep[x-3]], (1/2)(3Sqrt[1-(x/7)^2]+Sqrt[1-(Abs[Abs[x]-2]-1)^2]+Abs[x/2]-((3Sqrt[33]-7)/112)x^2-3)* ((x+4)/Abs[x+4]-(x-4)/Abs[x-4])-3*Sqrt[1-(x/7)^2]}, {x,-7,7}, AspectRatio->Automatic]

Hi, I am new to Mathematica. For a school project we have to do a model of a 3D shape with a known base and cross sections (i.e. squares, circles, etc...), find the volume of that shape via integration, and present the 3D model. Does anyone know how to get a diagram of this model on Mathematica, and how to use that model to get a 3D printable version of the shape? This is the plot for base I am working with:

enter image description here

Plot[{

    With[{
       w=3*Sqrt[1-(x/7)^2],
       l=(6/7)*Sqrt[10]+(3+x)/2-(3/7)*Sqrt[10]*Sqrt[4-(x+1)^2],
       h=(1/2)*(3*(Abs[x-1/2]+Abs[x+1/2]+6)-11*(Abs[x-3/4]+Abs[x+3/4])),
       r=(6/7)*Sqrt[10]+(3-x)/2-(3/7)*Sqrt[10]*Sqrt[4-(x-1)^2]},
       w+(l-w)*UnitStep[x+3]+(h-l)*UnitStep[x+1]+(r-h)*UnitStep[x-1]+(w-r)*UnitStep[x-3]],

    (1/2)*(3*Sqrt[1-(x/7)^2]+Sqrt[1-(Abs[Abs[x]-2]-1)^2]+Abs[x/2]-((3*Sqrt[33]-7)/112)*x^2-3)*
    ((x+4)/Abs[x+4]-(x-4)/Abs[x-4])-3*Sqrt[1-(x/7)^2]},

{x,-7,7}, AspectRatio->Automatic]

POSTED BY: Cameron Walker

2 Replies

Sort By:

J. M.

Posted 8 years ago

Just to add to what Vitaliy said, that formula I derived can be adapted for use in `RegionPlot[]` instead of `Plot[]`: p = RegionPlot[(3 Sqrt[1 - (x/7)^2] + Sqrt[1 - (Abs[Abs[x] - 2] - 1)^2] + Abs[x/2] - (3 Sqrt[33] - 7)/112 x^2 - 3) (Sign[x + 4] - Sign[x - 4])/2 - 3 Sqrt[1 - (x/7)^2] < y < With[{w = 3 Sqrt[1 - (x/7)^2], l = 6 Sqrt[10]/7 + (3 + x)/2 - 3 Sqrt[10]/7 Sqrt[4 - (x + 1)^2], h = (3 (Abs[x - 1/2] + Abs[x + 1/2] + 6) - 11 (Abs[x - 3/4] + Abs[x + 3/4]))/2, r = 6 Sqrt[10]/7 + (3 - x)/2 - 3 Sqrt[10]/7 Sqrt[4 - (x - 1)^2]}, w + (l - w) UnitStep[x + 3] + (h - l) UnitStep[x + 1] + (r - h) UnitStep[x - 1] + (w - r) UnitStep[x - 3]], {x, -7, 7}, {y, -3, 3}, PlotPoints -> 145]; batman = BoundaryDiscretizeGraphics[p] after which, you can proceed with the extrusion and exporting just like in his post. (As a side-note: directly applying `BoundaryDiscretizeRegion[]` on the corresponding `ImplicitRegion[]` leaves a lot to be desired. The `"Continuation"` and `"Semialgebraic"` `Method`s take too long, `"DualMarchingSquares"` and `"MarchingSquares"` don't work, and `"RegionPlot"` is weirdly cut off.)

Just to add to what Vitaliy said, that formula I derived can be adapted for use in RegionPlot[] instead of Plot[]:

p = RegionPlot[(3 Sqrt[1 - (x/7)^2] + Sqrt[1 - (Abs[Abs[x] - 2] - 1)^2] + Abs[x/2] - (3 Sqrt[33] - 7)/112 x^2 - 3)
               (Sign[x + 4] - Sign[x - 4])/2 - 3 Sqrt[1 - (x/7)^2] < y < 
               With[{w = 3 Sqrt[1 - (x/7)^2], l = 6 Sqrt[10]/7 + (3 + x)/2 - 3 Sqrt[10]/7 Sqrt[4 - (x + 1)^2], 
                     h = (3 (Abs[x - 1/2] + Abs[x + 1/2] + 6) - 11 (Abs[x - 3/4] + Abs[x + 3/4]))/2,
                     r = 6 Sqrt[10]/7 + (3 - x)/2 - 3 Sqrt[10]/7 Sqrt[4 - (x - 1)^2]}, 
                    w + (l - w) UnitStep[x + 3] + (h - l) UnitStep[x + 1] +
                    (r - h) UnitStep[x - 1] + (w - r) UnitStep[x - 3]], {x, -7, 7}, {y, -3, 3},
               PlotPoints -> 145];
batman = BoundaryDiscretizeGraphics[p]

batman

after which, you can proceed with the extrusion and exporting just like in his post.

(As a side-note: directly applying BoundaryDiscretizeRegion[] on the corresponding ImplicitRegion[] leaves a lot to be desired. The "Continuation" and "Semialgebraic" Methods take too long, "DualMarchingSquares" and "MarchingSquares" don't work, and "RegionPlot" is weirdly cut off.)

POSTED BY: J. M.

Vitaliy Kaurov

Vitaliy Kaurov, WOLFRAM Research

Posted 8 years ago

Here are some musings on the subject. There are many famous objects available in Wolfram Language as built-in data. For example: RegionProduct[ DiscretizeGraphics[ Entity["Lamina", "BatmanInisgniaLamina"][EntityProperty["Lamina", "BoundaryDiagram"]] ], BoundaryMeshRegion[{{0},{3}},Point[{{1},{2}}]] ] You can get many properties: EntityProperties["Lamina"] If you would like to deal with custom curves, not present in the built-in data, first assign your plot to a variable: batPLT=Plot[{ With[{ w=3Sqrt[1-(x/7)^2], l=(6/7)Sqrt[10]+(3+x)/2-(3/7)Sqrt[10]Sqrt[4-(x+1)^2], h=(1/2)(3(Abs[x-1/2]+Abs[x+1/2]+6)-11(Abs[x-3/4]+Abs[x+3/4])), r=(6/7)Sqrt[10]+(3-x)/2-(3/7)Sqrt[10]Sqrt[4-(x-1)^2]}, w+(l-w)UnitStep[x+3]+(h-l)UnitStep[x+1]+(r-h)UnitStep[x-1]+(w-r)UnitStep[x-3]], (1/2)(3Sqrt[1-(x/7)^2]+Sqrt[1-(Abs[Abs[x]-2]-1)^2]+Abs[x/2]-((3Sqrt[33]-7)/112)x^2-3)* ((x+4)/Abs[x+4]-(x-4)/Abs[x-4])-3*Sqrt[1-(x/7)^2]}, {x,-7,7},AspectRatio->Automatic]; Get only the points of the plot and make sure they are sorted properly. Then build a flat mesh region: points = Flatten[MapAt[Reverse, Cases[batPLT, Line[x_] -> x, Infinity], 1], 1]; batREG = BoundaryMeshRegion[points, Line[Append[Range[Length[points]], 1]]] You can extrude it to 3D as: bat3D = RegionProduct[batREG, BoundaryMeshRegion[{{0}, {3}}, Point[{{1}, {2}}]]] Next export to a 3D printing format and verify that export indeed worked: Export["bat3D.stl", bat3D] Import[%] There could be a better way to do this, perhaps suggestions will follow. But don't wait, read documentation about all functions used above and explore on your own.

Here are some musings on the subject. There are many famous objects available in Wolfram Language as built-in data. For example:

RegionProduct[
    DiscretizeGraphics[
       Entity["Lamina", "BatmanInisgniaLamina"][EntityProperty["Lamina", "BoundaryDiagram"]]
    ],
    BoundaryMeshRegion[{{0},{3}},Point[{{1},{2}}]]
]

enter image description here

You can get many properties:

EntityProperties["Lamina"]

enter image description here

If you would like to deal with custom curves, not present in the built-in data, first assign your plot to a variable:

batPLT=Plot[{

    With[{
       w=3*Sqrt[1-(x/7)^2],
       l=(6/7)*Sqrt[10]+(3+x)/2-(3/7)*Sqrt[10]*Sqrt[4-(x+1)^2],
       h=(1/2)*(3*(Abs[x-1/2]+Abs[x+1/2]+6)-11*(Abs[x-3/4]+Abs[x+3/4])),
       r=(6/7)*Sqrt[10]+(3-x)/2-(3/7)*Sqrt[10]*Sqrt[4-(x-1)^2]},
       w+(l-w)*UnitStep[x+3]+(h-l)*UnitStep[x+1]+(r-h)*UnitStep[x-1]+(w-r)*UnitStep[x-3]],

    (1/2)*(3*Sqrt[1-(x/7)^2]+Sqrt[1-(Abs[Abs[x]-2]-1)^2]+Abs[x/2]-((3*Sqrt[33]-7)/112)*x^2-3)*
    ((x+4)/Abs[x+4]-(x-4)/Abs[x-4])-3*Sqrt[1-(x/7)^2]},

{x,-7,7},AspectRatio->Automatic];

Get only the points of the plot and make sure they are sorted properly. Then build a flat mesh region:

points = Flatten[MapAt[Reverse, Cases[batPLT, Line[x_] -> x, Infinity], 1], 1];
batREG = BoundaryMeshRegion[points, Line[Append[Range[Length[points]], 1]]]

enter image description here

You can extrude it to 3D as:

bat3D = RegionProduct[batREG, BoundaryMeshRegion[{{0}, {3}}, Point[{{1}, {2}}]]]

enter image description here

Next export to a 3D printing format and verify that export indeed worked:

Export["bat3D.stl", bat3D]
Import[%]

enter image description here

There could be a better way to do this, perhaps suggestions will follow. But don't wait, read documentation about all functions used above and explore on your own.

POSTED BY: Vitaliy Kaurov

Reply to this discussion

Reply Preview

Attachments

Remove Add a file to this post

Follow this discussion

or Discard

Feedback