I haven't got a way to do her sort of graph substititutions yet but
Michelle Previte gave me an idea
for Hadamard/ Matrix substitutions using the two fibonacci games.
The usual matrix subtitution is binary: ( gives a version of a modulo 2
Pascal 's triangle)
{{0,1}
{1,1}}->Matrix blocks
{{0,0,0,1},
{0,0,1,1},
{ 0,1,0,1},
{1,1,1,1}}
These are closely related to Statistical mechanics/ spin etc.
My games matrices are:
MA={{0,1},{1,1}}; MB={{1,0},{3,1}};
Suppose you use a Previte like rule:
1) Start with MB instead of MA
2) If matrix element is 1 then replace with MA else if 3 replace with MB
%I A000001
%S A000001 1, 1, -1, 1, -2, 1, 1, 2, -1, -2, 1, 1, -2, -7, 6, 20, 6, -7,
-2, 1, 1, 2,
-25, -10, 225, -184, -498, 500, 610, -500, -498, 184, 225, 10, -25, -2, 1
%N A000001 Coefficients of the polynomials of a three level Hadamard
matrix substitution set based on the game matrix set:
MA={{0,1},{1,1}};MB={{1,0},{3,1}}
Substitution rule is for m[n]:If[m[n - 1][[i, j]] == 0, {{0, 0}, {0,
0}}, If[m[n - 1][[i, j]] == 1, MA, MB]]
Based on the Previte idea of graph substitutions as applied to matrices
of graphs in the Fibonacci/ anti-Fibonacci game.
%C A000001 m[n_] := Table[Table[If[m[n - 1][[i, j]] == 0, {{0, 0}, {0,
0}}, If[m[n - 1][[i, j]] == 1, ma, {{1, 0},
{3, 1}}]], {j, 1, 2^(n - 1)}], {i, 1, 2^(n - 1)}]
%D A000001 http://www.maa.org/pubs/monthly_jan08_toc.html
A Novel Way to Generate Fractals
By: Michelle Previte and Sean Yang
michelleprevite@[EMAIL PROTECTED]
sean.yang@[EMAIL PROTECTED]
you ever wanted to build your own fractal? This article will
describe a procedure called a vertex replacement rule that can be used
to construct fractals. We also show how one can easily compute the
topological and box dimensions of the fractals resulting from vertex
replacements.
http://math.bd.psu.edu/faculty/mprevite/publications.html
A Novel Way to Generate Fractals
<http://math.bd.psu.edu/faculty/mprevite/Research/novelfractals_revision030306.pdf>,
with student author Shun-Hsiang Yang, /The American Mathematical
Monthly/
%F A000001 m[n] = If[m[n - 1][[i, j]] == 0, {{0, 0}, {0, 0}}, If[m[n -
1][[i, j]] == 1, MA, MB]]
m[0] = {{1}}
m[1] = {{1, 0},
{3, 1}}
m[2] = {{0, 1, 0, 0},
{1, 1, 0, 0},
{1, 0, 0, 1},
{3, 1, 1, 1}}
m[3] = {{0, 0, 0, 1, 0, 0, 0, 0},
{0, 0, 1, 1, 0, 0, 0, 0},
{0, 1, 0, 1, 0, 0, 0, 0},
{1, 1, 1, 1, 0, 0, 0, 0},
{0, 1, 0, 0, 0, 0, 0, 1},
{1, 1, 0, 0, 0, 0, 1, 1},
{1, 0, 0, 1, 0, 1, 0, 1},
{3, 1, 1, 1, 1, 1, 1, 1}}
m[4] = {{0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0},
{0, 0, 0, 0, 0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0},
{0, 0, 0, 0, 0, 1, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0},
{0, 0, 0, 0, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0},
{0, 0, 0, 1, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0},
{0, 0, 1, 1, 0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0},
{0, 1, 0, 1, 0, 1, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0},
{1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0},
{0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1},
{0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1},
{0, 1, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 1},
{1, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1},
{0, 1, 0, 0, 0, 0, 0, 1, 0, 0, 0, 1, 0, 0, 0, 1},
{1, 1, 0, 0, 0, 0, 1, 1, 0, 0, 1, 1, 0, 0, 1, 1},
{1, 0, 0, 1, 0, 1, 0, 1, 0, 1, 0, 1, 0, 1, 0, 1},
{3, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1}}
%e A000001 {1},
{1, -1},
{1, -2, 1},
{1, 2, -1, -2, 1},
{1, -2, -7, 6, 20, 6, -7, -2,1},
{1, 2, -25, -10, 225, -184, -498, 500, 610, -500, -498,184, 225, 10,
-25, -2, 1}
%t A000001 m[0] = {{1}}
m[1] = {{1, 0},
{3, 1}}
m[2] = {{0, 1, 0, 0},
{1, 1, 0, 0},
{1, 0, 0, 1},
{3, 1, 1, 1}}
m[3] = {{0, 0, 0, 1, 0, 0, 0, 0},
{0, 0, 1, 1, 0, 0, 0, 0},
{0, 1, 0, 1, 0, 0, 0, 0},
{1, 1, 1, 1, 0, 0, 0, 0},
{0, 1, 0, 0, 0, 0, 0, 1},
{1, 1, 0, 0, 0, 0, 1, 1},
{1, 0, 0, 1, 0, 1, 0, 1},
{3, 1, 1, 1, 1, 1, 1, 1}}
m[4] = {{0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0},
{0, 0, 0, 0, 0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0},
{0, 0, 0, 0, 0, 1, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0},
{0, 0, 0, 0, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0},
{0, 0, 0, 1, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0},
{0, 0, 1, 1, 0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0},
{0, 1, 0, 1, 0, 1, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0},
{1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0},
{0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1},
{0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1},
{0, 1, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 1},
{1, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1},
{0, 1, 0, 0, 0, 0, 0, 1, 0, 0, 0, 1, 0, 0, 0, 1},
{1, 1, 0, 0, 0, 0, 1, 1, 0, 0, 1, 1, 0, 0, 1, 1},
{1, 0, 0, 1, 0, 1, 0, 1, 0, 1, 0, 1, 0, 1, 0, 1},
{3, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1}};
Table[CharacteristicPolynomial[m[i], x], {i, 0, 4}];
a = Join[{{1}}, Table[CoefficientList[CharacteristicPolynomial[m[i],
x], x], {i, 0, 4}]];
Flatten[a]
(* visualization*)
Table[ListDensityPlot[m[i]], {i, 0, 4}]
%Y A000001 A122947,A131218
%O A000001 1
%K A000001 ,nonn,
%A A000001 Roger L. Bagula (rlbagulatftn@[EMAIL PROTECTED]
), Jan 24 2008
RH
RA 192.20.225.32
RU
RI
--
Respectfully, Roger L. Bagula
11759Waterhill Road, Lakeside,Ca 92040-2905,tel: 619-5610814
:http://www.geocities.com/rlbagulatftn/Index.html
alternative email: rlbagula@[EMAIL PROTECTED]
|
