# Sierpinski carpet with GraphData

Is this graph in the list among the so-called "standard" structures used in GraphData? However, I have not found, yet, anything like "Carpet" or "Sponge" in the list of the object that can be built. Maybe, this graph has a different name?

For me, using GraphData helps to save time for constructing adj. matrix, therefore, I would rather prefer using this function than drawing the graph...

Thank you very much in advance!

-
Have you seen this? – gpap Aug 19 '13 at 12:47
To the close voter - this certainly is not a duplicate of the "Generating a Sierpinski carpet" question. – Mark McClure Aug 19 '13 at 16:08
@gpap There is one vote to close and I addressed my comment to that person. I have no idea who it is. – Mark McClure Aug 19 '13 at 16:30

I don't think there is a carpet graph built-in, but it's hard to be sure that something is not there. Still it's not hard to construct a Graph -- not quite the same thing as drawing it (I wasn't sure what you meant).

There are probably more efficient ways, but adapting Mr.Wizard's carpet function, it is fairly straightforward to make an edge between adjacent 1s in the matrix.

carpet[n_] := (* Mr.Wizard *)
Nest[ArrayFlatten[{{#, #, #}, {#, 0, #}, {#, #, #}}] &, 1, n];
carpetGraph[n_] := Module[{sa, edges, parts, onesPositions},
parts = {{1, 0}, {0, 1}};
sa = SparseArray@carpet[n];
onesPositions = sa["NonzeroPositions"];
edges = Flatten[
With[{m = ArrayPad[sa, 1]},
Function[pos,  pos -> # & /@
Pick[pos + # & /@ parts, Extract[m, 1 + pos + # & /@ parts], 1]] /@
onesPositions],
1];
Graph[onesPositions, edges, VertexCoordinates -> onesPositions, DirectedEdges -> False]
]

g = carpetGraph[4]


You can then compute the adjacency matrix as with any other graph:

(* AdjacencyMatrix[g] // Timing // First *)
(* {0.010865, SparseArray[<12848>, {4096, 4096}]} *)

(* {0.878410, SparseArray[<104080>, {32768, 32768}]} *)

-
Michael, I can't run your code because v7 doesn't have Graph but I see that you modified carpet; I'm not sure why. It seems slower than using my original code and converting to a sparse array at the end. I suggest you try this code with my original and then sa = SparseArray @ carpet[n];. Also, you seem to be using sa["NonzeroPositions"] three separate times; why not assign that to an extra Symbol in the Module? – Mr.Wizard Aug 20 '13 at 2:28
@Mr.Wizard Thanks for the suggestions. I started with the idea of SparseArray and didn't think of applying it at the end. I suppose I could do something about pos + # & /@ parts appearing twice, too. I'm not sure it's worth changing, although the three sa["NonzeroPositions"] seem worth an extra variable. It turns out that the speed is not affected noticeably. (I get roughly equal timings, both faster and slower, up to carpetGraph[6].) My mem. usage would go up 20GB on carpetGraph[5] earlier but not now. Must have been something Mma ate. :) – Michael E2 Aug 20 '13 at 3:06
thank you all very much!!! – Lady InRed Aug 20 '13 at 9:24

Here is a "general" Lindenmayer System generator I wrote in the spirit of code-golf. Please beware that the objective of code-golfing is writing the shorter possible program to fulfill an objective, disregarding good practices, robustness, etc. Stay safe and don't use this style in real life.

f[i_, b_, h_, j_, r_, n_] :=
(a = h; p = j; s = k = {}; t = Flatten;
(Switch[#,
6, s = {a, p, s},
8, {a, p, s} = s,
_C, k = {k, Black, Line@{p, p += {Cos@a, Sin@a}}},
_W, k = {k, White, Line@{p, p += {Cos@a, Sin@a}}}];
If[# < 9, a += I^# b]) & /@ t@Nest[# /. r &, i, n];
Graphics@t@k)


Where

i : Initial state;
b : rotation angle
h : initial angle
j : initial position
r : production rules
n : iterations

And the production rules for the grammar are:

2 = Turn Left (-);
4 = Turn Right (+);
6 = Push and Turn Left ("[");
8 = Pop and Turn Right ("]");
C[i] = Draw (Any number of symbols)
W[i] = Draw in White (Any number of symbols)
Any other symbol = Do Nothing, just use it in producing next state

So the rules for the carpet are:

f[{C[1]}, Pi/2, 0, {0, 0},
{C@1 -> {C@1, 4, C@1, 2, C@1, 2, C@1, 2, W@3, 4, C@1, 4, C@1, 4, C@1, 2, C@1},
W@3 -> {W@3, W@3, W@3}}, 5]


Other usage examples (sorry, couldn't resist)

Examples:

f[{C@1, X}, Pi/2, 0, {0, 0}, {X -> {X, 4, Y, C@1}, Y -> {C@1, X, 2, Y}}, 10]


f[{C@1}, Pi/2, 0, {0,0}, {C@1->{C@1, 2, C@1, 4, C@1, 4, C@1, 2, C@1}}, 6]


f[{C@1}, Pi/4, Pi/2, {0, 0}, {C@2 -> {C@2, C@2}, C@1 -> {C@2, 6, C@1, 8, C@1}}, 10]


f[{C[1]}, Pi/3, 0, {0, 0},
{C@1 -> {C@2, 4, C@1, 4, C@2}, C@2 -> {C@1, 2, C@2, 2, C@1}}, 10]


f[{X},5/36 Pi, Pi/3, {0,0},
{X->{C@1, 4, 6, 6, X, 8, 2, X, 8, 2, C@1, 6, 2, C@1, X, 8, 4, X},
C@1->{C@1, C@1}}, 6]


Edit

Since you wanted a Graph ... here it is:

f[i_, b_, h_, j_, r_, n_] := (a = h; p = j; s = k = {}; g =.;
t = Flatten;
(Switch[#,
6, s = {a, p, s},
8, {a, p, s} = s,
_C, AppendTo[k, {p, (p += {Cos@a, Sin@a})}],
_W, p += {Cos@a, Sin@a}];
If[# < 9, a += I^# b]) & /@ t@Nest[# /. r &, i, n];);
f[{C[1]}, Pi/2, 0, {0, 0},
{C@1 -> {C@1, 4, C@1, 2, C@1, 2, C@1, 2, W@3, 4, C@1, 4, C@1, 4, C@1, 2, C@1},
W@3 -> {W@3, W@3, W@3}}, 2];

g = Graph[Rule @@@ k];
(PropertyValue[{g, #}, VertexCoordinates] = #) & /@ VertexList@g;
g


If you let Mathematica to place the Vertices automagically, you also get nice pictures

-
That sure looks nice, but since this isn't Code Golf you should probably localize your variables. Also, how long is this supposed to take to render? I tried the first example before starting to write this comment, and it's still running. (Okay, it just finished. +1) – Mr.Wizard Aug 21 '13 at 0:22
Well I just lifted my vote. This is undoubtedly cool but I don't think it answers the question, which I think is about Graph data as Michael's answer produces. – Mr.Wizard Aug 21 '13 at 0:25
@Mr.Wizard Now it does Graphs :) – Dr. belisarius Aug 21 '13 at 0:59
Noted and vote restored. Please consider adding Module still; it's just bad practice not to, outside of Code Golf. – Mr.Wizard Aug 21 '13 at 1:00
"I cannot agree with those who rank modesty among the virtues." Sherlock Holmes :) – cormullion Aug 21 '13 at 14:23