(*^
::[ Information =
"This is a Mathematica Notebook file. It contains ASCII text, and can be
transferred by email, ftp, or other text-file transfer utility. It should
be read or edited using a copy of Mathematica or MathReader. If you
received this as email, use your mail application or copy/paste to save
everything from the line containing (*^ down to the line containing ^*)
into a plain text file. On some systems you may have to give the file a
name ending with ".ma" to allow Mathematica to recognize it as a Notebook.
The line below identifies what version of Mathematica created this file,
but it can be opened using any other version as well.";
FrontEndVersion = "Macintosh Mathematica Notebook Front End Version 2.2";
MacintoshStandardFontEncoding;
fontset = title, inactive, noPageBreakBelow, nohscroll, preserveAspect, groupLikeTitle, center, M7, bold, e8, 24, "Times";
fontset = subtitle, inactive, noPageBreakBelow, nohscroll, preserveAspect, groupLikeTitle, center, M7, bold, e6, 18, "Times";
fontset = subsubtitle, inactive, noPageBreakBelow, nohscroll, preserveAspect, groupLikeTitle, center, M7, italic, e6, 14, "Times";
fontset = section, inactive, noPageBreakBelow, nohscroll, preserveAspect, groupLikeSection, grayBox, M22, bold, a20, 18, "Times";
fontset = subsection, inactive, noPageBreakBelow, nohscroll, preserveAspect, groupLikeSection, blackBox, M19, bold, a15, 14, "Times";
fontset = subsubsection, inactive, noPageBreakBelow, nohscroll, preserveAspect, groupLikeSection, whiteBox, M18, bold, a12, 12, "Times";
fontset = text, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, 12, "Times";
fontset = smalltext, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, 10, "Times";
fontset = input, noPageBreakInGroup, nowordwrap, preserveAspect, groupLikeInput, M42, N23, bold, L-5, 12, "Courier";
fontset = output, output, inactive, noPageBreakInGroup, nowordwrap, preserveAspect, groupLikeOutput, M42, N23, L-5, 12, "Courier";
fontset = message, inactive, noPageBreakInGroup, nowordwrap, preserveAspect, groupLikeOutput, M42, N23, R65535, L-5, 12, "Courier";
fontset = print, inactive, noPageBreakInGroup, nowordwrap, preserveAspect, groupLikeOutput, M42, N23, L-5, 12, "Courier";
fontset = info, inactive, noPageBreakInGroup, nowordwrap, preserveAspect, groupLikeOutput, M42, N23, B65535, L-5, 12, "Courier";
fontset = postscript, PostScript, formatAsPostScript, output, inactive, noPageBreakInGroup, nowordwrap, preserveAspect, groupLikeGraphics, M7, l34, w282, h287, 12, "Courier";
fontset = name, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, italic, 10, "Geneva";
fontset = header, inactive, noKeepOnOnePage, preserveAspect, M7, 12, "Times";
fontset = leftheader, inactive, L2, 12, "Times";
fontset = footer, inactive, noKeepOnOnePage, preserveAspect, center, M7, 12, "Times";
fontset = leftfooter, inactive, L2, 12, "Times";
fontset = help, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, 10, "Times";
fontset = clipboard, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, 12, "Times";
fontset = completions, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, 12, "Times";
fontset = special1, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, 12, "Times";
fontset = special2, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, 12, "Times";
fontset = special3, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, 12, "Times";
fontset = special4, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, 12, "Times";
fontset = special5, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, 12, "Times";
currentKernel;
]
:[font = title; inactive; preserveAspect; startGroup]
Sierpinski-Menger Sponge Code
:[font = smalltext; inactive; preserveAspect]
by Robert M. Dickau
Developer Support Group
Wolfram Research, Inc.
100 Trade Center Drive
Champaign, IL 61820
email: robertd@wri.com
:[font = text; inactive; preserveAspect]
The parameter "iters," below, is the number of iterations used to create the sponge. Execution with iters=2 can be completed in a reasonable amount of time; execution with iters=3 will use nearly twelve megabytes of memory, and take about ten minutes to compute and twenty minutes to render using a NeXT kernel connected to a Macintosh PowerBook 180 front end.
:[font = input; preserveAspect]
iters = 3. (* change iters to 2 if you're short on time or RAM;
if anyone runs it with iters=4, I'd like to see
the result. *);
:[font = input; preserveAspect]
side = 3. ^ iters ;
:[font = input; preserveAspect]
cubmat (* cuboid-matrix, that is *) =
Table[
If[i==side + 1. || j==side + 1. || k==side + 1.,
(* Pad the table's edges with zeroes; if you want
to see the complement of the sponge, transpose
the 0. and 1. directly below. *)
0., 1.],
{i,1.,side + 1.},{j,1.,side+1.},{k,1.,side+1.}];
:[font = input; preserveAspect]
Do[ If[
(Mod[Round[i/3.^n + 0.5],3]==2 &&
(Mod[Round[j/3.^n + 0.5],3]==2 ||
Mod[Round[k/3.^n + 0.5],3]==2)) ||
(Mod[Round[j/3.^n + 0.5],3]==2 &&
(Mod[Round[i/3.^n + 0.5],3]==2 ||
Mod[Round[k/3.^n + 0.5],3]==2)) ||
(Mod[Round[k/3.^n + 0.5],3]==2 &&
(Mod[Round[i/3.^n + 0.5],3]==2 ||
Mod[Round[j/3.^n + 0.5],3]==2)),
(* then--taking advantage of eightfold symmetry--... *)
(cubmat[[i,j,k]]=0.;
cubmat[[side+1-i,j,k]]=0.;
cubmat[[i, side+1-j,k]]=0.;
cubmat[[i,j,side+1-k]]=0.;
cubmat[[side+1-i, side+1-j,k]]=0.;
cubmat[[side+1-i,j,side+1-k]]=0.;
cubmat[[i, side+1-j, side+1-k]]=0.;
cubmat[[side+1-i,side+1-j,side+1-k]]=0.;)
(* ...no cuboid goes there *)],
{i,(side+1)/2},{j,(side+1)/2},{k,(side+1)/2},
{n,0.,iters-1.}]
:[font = input; preserveAspect]
faces = {};
(* Instead of using the Cuboid graphics primitive,
we show only the polygons visible from
viewpoints in the default octant. *)
Do[
If[ cubmat[[i,j,k]]==1. && cubmat[[i,j,k+1.]]==0.
(* That is, if a face belongs at {i,j,k}
and there's nothing hiding it, add the
appropriate polygon to the list. *),
AppendTo[ faces,
(* cuboid tops... *)
{{i,j,k+1.},{i,j+1.,k+1.},
{i+1.,j+1.,k+1.},{i+1.,j,k+1.}}
] ],
{i,1.,side},{j,1.,side},{k,1.,side} ];
:[font = input; preserveAspect]
(* Since the figure looks the same regardless of which axis
is vertical, the polygon-corner list "faces" is computed
only for the tops of the cuboids, then rotated twice to get
lists of sides and fronts. *)
faces = Join[ faces (*tops*),
(*sides *) Map[ RotateLeft[#,2]&,faces,{2}],
(*fronts*) Map[
RotateLeft[#,1]*{1,-1,1}+{0,side+2,0}&,
faces,{2}]
];
:[font = input; preserveAspect; endGroup]
Show[Graphics3D[ {EdgeForm[], Map[ Polygon, faces ]}],
Boxed->False]
:[font = smalltext; inactive; preserveAspect]
28 January 1994
^*)