Cube codes just done in Mathematica
- To: mathgroup at smc.vnet.net
- Subject: [mg79810] Cube codes just done in Mathematica
- From: Roger Bagula <rlbagula at sbcglobal.net>
- Date: Sun, 5 Aug 2007 04:53:17 -0400 (EDT)
These cubes came up as an answer to a question in sci.fractals.
Menger cube code By Szabolcs Horv=E1t <szhorvat at gmail.com> :
Clear[pieces, menger]
pieces =
Complement[
Flatten[Table[{i, j, k}, {i, 0, 2}, {j, 0, 2}, {k, 0, 2}],
2], {{1, 1, 1}, {0, 1, 1}, {2, 1, 1}, {1, 0, 1}, {1, 2, 1}, {1, 1,
0}, {1, 1, 2},}]
menger[cornerPt_, sideLen_, n_] :=
menger[cornerPt + #1*(sideLen/3), sideLen/3, n - 1] & /@ pieces;
menger[cornerPt_, sideLen_, 0] :=
Cuboid[cornerPt, cornerPt + sideLen*{1, 1, 1}];
gr = Flatten[menger[{0, 0, 0}, 1, 2]];
Show[Graphics3D[gr], Boxed -> False]
Cross Menger cube/ sponge:
Clear[pieces, menger]
(*Cross Menger cube by Roger Bagula 3 Aug 2007=A9*)
(* patterned from Menger cube code by Szabolcs Horv=E1t <
szhorvat at gmail.com >,
University of Bergen in Mathematica newsgroup : Mon, 28 May 2007 09 : 10=
:
50*)
Union[Flatten[Table[{{1, 2, i}, {2, 1, i}, {2, 2, i}, {2, 3, i}, {3,
2, i}, {1, i, 2}, {2, i, 1}, {2, i, 2}, {2, i, 3}, {3, i, 2}, {i, 1, 2}=
,
{i, 2, 1}, {i, 2, 2}, {i, 2, 3}, {i, 3, 2}}, {i, 0, 4}], 1]]
Length[%]
N[Log[53 - %]/Log[5]]
2.690835916581937`
pieces =
Complement[
Flatten[Table[{i, j, k}, {i, 0, 4}, {j, 0, 4}, {k, 0, 4}],
2], Union[Flatten[Table[{{1, 2, i}, {2, 1, i}, {2, 2, i}, {
2, 3, i}, {3, 2, i}, {1, i, 2}, {2, i, 1}, {2, i, 2}, {2, i, 3}, {
3, i, 2}, {i, 1, 2}, {i, 2, 1}, {i, 2, 2}, {i, 2, 3}, {i, 3, 2}}, =
{
i, 0, 4}], 1]]]
menger[cornerPt_, sideLen_, n_] :=
menger[cornerPt + #1*(sideLen/5), sideLen/5, n - 1] & /@ pieces
menger[cornerPt_, sideLen_, 0] :=
Cuboid[cornerPt, cornerPt + sideLen*{1, 1, 1}]
Show[Graphics3D[Flatten[menger[{0, 0, 0}, 1, 1]]], Boxed -> False]
Show[Graphics3D[Flatten[menger[{0, 0, 0}, 1, 2]]], Boxed -> False]
Higher level M<enger cube/ sponge ( called boxed set):
Clear[pieces, menger]
(* boxed set 444 cube by Roger Bagula 3 Aug 2007 =A9*)
(* patterned from Menger cube code by Szabolcs Horv=E1t < szhorvat at gmail.=
com
>, University of Bergen in Mathematica newsgroup : Mon, 28 May 2007 09
: 10 :
50*)
pieces =
Complement[
Flatten[Table[{i, j, k}, {i, 0, 3}, {j, 0, 3}, {k, 0, 3}],
2], Union[Flatten[Table[{{1, 1, i}, {2, 1, i}, {1, 2, i}, {2, 2, i},
{1, \
i, 1}, {2, i, 1}, {1, i, 2}, {2, i, 2}, {i, 1,
1}, {i, 2, 1}, {i, 1, 2}, {i, 2, 2}}, {i, 0, 3}], 1]]]
menger[cornerPt_, sideLen_, n_] :=
menger[cornerPt + #1*(sideLen/4), sideLen/4, n - 1] & /@ pieces
menger[cornerPt_, sideLen_, 0] :=
Cuboid[cornerPt, cornerPt + sideLen*{1, 1, 1}]
Show[Graphics3D[Flatten[menger[{0, 0, 0}, 1, 1]]], Boxed -> False]
Show[Graphics3D[Flatten[menger[{0, 0, 0}, 1, 2]]], Boxed -> False]