Grigorchuk-01.nb

The format for finite automaton rules used here is a list of entries of the form {s0, a0}→{s1,a1}, where the si are states and the ai are symbols. (This ordering is consistent with NKS Turing machine usage. As for Turing machines, the states should be numbered starting at 1.)

The automaton for the lamplighter group is then:

In[1]:=

In[2]:=

FAStep :: usage = "FAStep[rule, init, list] applies the finite automaton represented by rule to list, starting with state init." ;

In[3]:=

$FAStep[rule_, init_, list_] := FoldList[{First[#1], #2}/.rule&, {init}, list]$

In[4]:=

FAMap :: usage = "FAMap[rule, init, n] generates the mapping corresponding to finite automaton rule for sequences of length n." ;

In[5]:=

$FAMap[rule_, init_, n_] := With[{k = 1 + Max[#[[1, 2]] &/@rule]}, Table[{i, FromDigits[Last/@Rest[FAStep[rule, init, IntegerDigits[i, k, n]]], k]}, {i, 0, k^n - 1}]]$

This corresponds to a graph for a group.

The following produces a matrix version of the map. This can also be produced directly, using a 2D substitution system operating on matrices.

In[6]:=

$FAMapMatrix[rule_, init_, n_] := With[{k = 1 + Max[#[[1, 2]] &/@rule]}, Normal[SparseArray[((# + 1) 1) &/@FAMap[rule, init, n], {k^n, k^n}]]]$

In[7]:=

$FAMapSparseMatrix[rule_, init_, n_] := With[{k = 1 + Max[#[[1, 2]] &/@rule]}, SparseArray[((# + 1) 1) &/@FAMap[rule, init, n], {k^n, k^n}]]$

NOTE: It's not clear what to do if the matrix is singular...

In[8]:=

$FAMapSparseLaplacian[rule_, n_] := With[{s = Max[#[[1, 1]] &/@rule]}, Sum[(# + If[Det[#] 0, Throw[singular], Inverse[#]]) &[FAMapSparseMatrix[rule, i, n]], {i, s}]]$

In[9]:=

$FAMapSpectrum[rule_, n_] := Catch[{First[#], Length[#]} &/@Split[Sort[Eigenvalues[FAMapSparseLaplacian[rule, n]], Less]]]$

In[11]:=

Out[11]=

${{-2 3^(1/2), 1}, {-1 - 5^(1/2), 1}, {-2 2^(1/2), 2}, {-2, 5}, {1 - 5^(1/2), 1}, {0, 11}, {-1 + 5^(1/2), 1}, {2, 5}, {2 2^(1/2), 2}, {1 + 5^(1/2), 1}, {2 3^(1/2), 1}, {4, 1}}$

In[81]:=

Out[81]=

${{Root[-8 - 8 #1 + 2 #1^2 + #1^3&, 1], 1}, {-2 3^(1/2), 1}, {-1 - 5^(1/2), 2}, {-2 2^(1/2) ... ^(1/2), 4}, {1 + 5^(1/2), 2}, {2 3^(1/2), 1}, {Root[8 - 8 #1 - 2 #1^2 + #1^3&, 3], 1}, {4, 1}}$

Note: it does not work to numericalize the matrices first. It prevents the distinct eigenvalues from readily be identified.

In[10]:=

$Tuples[list_, n_] := Flatten[Outer[List, ##, 1] & @@ Table[list, {n}], n - 1]$

In[11]:=

$AllFAs[s_, k_] := With[{lhs = Flatten[Outer[List, Range[s], Range[0, k - 1], 1], 1]}, Thread[l ... en[Outer[List, ##, 1] & @@ Flatten[Table[{Range[s], Range[0, k - 1]}, {s k}], 1], 2 s k - 1])]$

In[124]:=

Out[124]=

In[12]:=

$FAMapGraphic[rule_, init_, n_] := With[{u = FAMap[rule, init, n]}, Graphics[{AbsolutePointSize ... True, FrameTicksNone, PlotRange {{0, Length[u] - 1}, {0, Length[u] - 1}}]]$

In[130]:=

[Graphics:HTMLFiles/index_20.gif]

In[13]:=

$FAMapSpectrumGraphic[rule_, n_] := With[{w = FAMapSpectrum[rule, n]}, If[w === singular, Graph ... e[{{First[#], 0}, #}] &/@w, PlotRangeAll, FrameTrue, FrameTicksNone]]]$

In[137]:=

[Graphics:HTMLFiles/index_23.gif]

Out[137]=

In[37]:=

[Graphics:HTMLFiles/index_26.gif]

In[38]:=

[Graphics:HTMLFiles/index_28.gif]

In[39]:=

Out[39]=

In[40]:=

[Graphics:HTMLFiles/index_32.gif]

In[41]:=

Out[41]=

In[14]:=

Out[14]=

${singular, {{4, 16}}, {{-4, 8}, {4, 8}}, {{0, 8}, {4, 8}}, {{-4, 4}, {0, 8}, {4, 4}}, {{0, 1}, ... 2))^(1/2))^(1/2), 1}, {2 (2 + 2^(1/2))^(1/2), 1}, {2 (2 + (2 + 2^(1/2))^(1/2))^(1/2), 1}, {4, 1}}}$

In[15]:=

Out[15]=

In[16]:=

Out[16]=

${singular, {{4, 32}}, {{-4, 16}, {4, 16}}, {{0, 16}, {4, 16}}, {{-4, 8}, {0, 16}, {4, 8}}, {{- ... (2 + (2 + 2^(1/2))^(1/2))^(1/2), 1}, {2 (2 + (2 + (2 + 2^(1/2))^(1/2))^(1/2))^(1/2), 1}, {4, 1}}}$

In[17]:=

Out[17]=

Created by Mathematica (November 16, 2003)