Get 3D-printable Batman logo given cross section?

[cameron9ww (Cameron Walker)]

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=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]

[Vitaliyk (Vitaliy Kaurov)]

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=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]]]

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.

[pleasureoffiguring (J. M.)]

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" Methods take too long, "DualMarchingSquares" and "MarchingSquares" don’t work, and "RegionPlot" is weirdly cut off.)