#### Sculpture for 3D printing

Feb 11, 2001

Here is the source notebook for a 3D sculpture I really like.

It is very organic..

it is similar to a plant which would start as a disk, but where the outside edge would grow faster than the radius…

`NormalizeVector[u_] := If[ u.u > 0, u/Sqrt[u.u], 0];`

```
<< Default3D`[/wlcode]
[wlcode]G1[r_, \[CapitalTheta]_] := {
r Cos[\[CapitalTheta]] - 1/15 r^5 Cos[5 \[CapitalTheta]],
r Sin[\[CapitalTheta]] + 1/15 r^5 Sin[5 \[CapitalTheta]],
2/3 r^3 Cos[3 \[CapitalTheta]] + 0.5
};[/wlcode]
[wlcode]G2[r_, \[CapitalTheta]_] := {
r Cos[\[CapitalTheta]] - 1/15 r^5 Cos[5 (\[CapitalTheta] + Pi)],
r Sin[\[CapitalTheta]] + 1/15 r^5 Sin[5 (\[CapitalTheta] + Pi)],
2/3 r^3 Cos[3 \[CapitalTheta]]
};[/wlcode]
[wlcode]r = 1.3;
Do[g1 = ParametricPlot[ {
r Cos[\[CapitalTheta]] -
1/5 r^5 (Cos[5 \[CapitalTheta]] - Cos[n \[CapitalTheta]]/10),
r Sin[\[CapitalTheta]] +
1/5 r^5 ( Sin[5 \[CapitalTheta]] - Sin[n \[CapitalTheta]]/10)
}, {\[CapitalTheta], 0, 2 Pi}, DisplayFunction -> Identity,
PlotPoints -> 70];
g2 = ParametricPlot[ {
r Cos[Θ] –
1/5 r^5 (Cos[5 Θ] + Cos[n Θ]/10),
r Sin[Θ] +
1/5 r^5 ( Sin[5 Θ] + Sin[n Θ]/10)
}, {Θ, 0, 2 Pi}, DisplayFunction -> Identity,
PlotPoints -> 70, PlotStyle -> RGBColor[1, 0, 0]];
Show[ g1, g2, DisplayFunction -> $DisplayFunction,
AspectRatio -> Automatic, PlotLabel -> ("n=" <> ToString[n])];
, {n, 2, 2}];
Clear[r];
```

`pairList[l_] := Transpose[ { Drop[l, -1], Rest[l]}];`

```
MaxRValue = 1.3;
ThetaPoints = 28;
Rpoints = 8;
MinTheta = (1/3 + 1/6) Pi;
MaxTheta = MinTheta + 1 /3 Pi;
edgeSize = 1/5;
edgePower = 1;
centerThickness = .1;
f1[r_, Θ_] := {
r Cos[Θ] – 1/5 r^5 (Cos[5 Θ]) +
1/5 r (Cos[2 Θ] edgeSize),
r Sin[Θ] + 1/5 r^5 (Sin[5 Θ]) –
1/5 r ( Sin[2 Θ] edgeSize),
2/3 r^3 Cos[3 Θ] –
centerThickness/2 (MaxRValue – r)^edgePower
};
f2[r_, Θ_] := {
r Cos[Θ] – 1/5 r^5 (Cos[5 Θ]) –
1/5 r (Cos[2 Θ] edgeSize),
r Sin[Θ] + 1/5 r^5 (Sin[5 Θ]) +
1/5 r ( Sin[2 Θ] edgeSize),
2/3 r^3 Cos[3 Θ] +
centerThickness/2 (MaxRValue – r)^edgePower
};
g2 = ParametricPlot3D[
f2[r, Θ], {Θ, MinTheta, MaxTheta}, {r,
0, MaxRValue}, PlotPoints -> {ThetaPoints, Rpoints},
ViewPoint -> {-2, 0, 0}, Boxed -> False, ViewVertical -> {0, 0, 1},
PlotRange -> All, DisplayFunction -> Identity,
Compiled -> False];
g1 = ParametricPlot3D[
f1[r, Θ], {Θ, MinTheta, MaxTheta}, {r,
0, 1.3}, PlotPoints -> {ThetaPoints, Rpoints},
ViewPoint -> {-2, 0, 0}, Boxed -> False, ViewVertical -> {0, 0, 1},
PlotRange -> All, DisplayFunction -> Identity,
Compiled -> False];
allborder1 =
Table[f1[MaxRValue, Θ], {Θ, MinTheta,
MaxTheta, (MaxTheta – MinTheta)/(ThetaPoints – 1)}];
allborder2 =
Table[f2[MaxRValue, Θ], {Θ, MinTheta,
MaxTheta, (MaxTheta – MinTheta)/(ThetaPoints – 1)}];
edges = Flatten[#, 1] & /@
Transpose[{pairList[allborder1],
Reverse /@ pairList[allborder2]}];
If[{MinTheta, MaxTheta} != {0, 2 Pi},
allborder1 =
Table[f1[r, MinTheta], {r, 0, MaxRValue,
MaxRValue/(Rpoints – 1)}];
allborder2 =
Table[f2[r, MinTheta], {r, 0, MaxRValue,
MaxRValue/(Rpoints – 1)}];
edges =
Join[edges,
Flatten[#, 1] & /@
Transpose[{pairList[allborder1],
Reverse /@ pairList[allborder2]}]];
allborder1 =
Table[f1[r, MaxTheta], {r, 0, MaxRValue,
MaxRValue/(Rpoints – 1)}];
allborder2 =
Table[f2[r, MaxTheta], {r, 0, MaxRValue,
MaxRValue/(Rpoints – 1)}];
edges =
Join[edges,
Flatten[#, 1] & /@
Transpose[{pairList[allborder1],
Reverse /@ pairList[allborder2]}]];
];
Show[g1, g2, Graphics3D[Polygon /@ edges],
DisplayFunction -> $DisplayFunction, PlotRange -> {All, All, All}];
```

```
<< RealTime3D`[/wlcode]
[wlcode]Show[g1, g2, Graphics3D[Polygon /@ edges],
DisplayFunction -> $DisplayFunction, Mesh -> False];
```