Discussion:
new type ot Hadamard matrix self-similarity
(too old to reply)
Roger Bagula
2009-04-19 14:16:52 UTC
Permalink
Loading Image...
Loading Image...
Mathematica:
Clear[HadamardMatrix, HadamardMatrix1]
MatrixJoinH[A_, B_] := Transpose[Join[Transpose[A], Transpose[B]]]
KroneckerProduct[M_, N_] := Module[{M1, N1, LM, LN, N2},
M1 = M;
N1 = N;
LM = Length[M1];
LN = Length[N1];
Do[M1[[i, j]] = M1[[i, j]]N1, {i, 1, LM}, {j, 1, LM}];
Do[M1[[i, 1]] = MatrixJoinH[M1[[i, 1]], M1[[i, j]]], {j, 2, LM}, {
i, 1, LM}];
N2 = {};
Do[AppendTo[N2, M1[[i, 1]]], {i, 1, LM}];
N2 = Flatten[N2];
Partition[N2, LM*LN, LM*LN]]
HadamardMatrix[0] := {{1}}
HadamardMatrix[2] := {{1, -1}, {1, 1}}
HadamardMatrix[3] := {{1, 0, 0}, {0, 1, -1}, {0, 1, 1}}
HadamardMatrix[n_] := Module[{m},
m = {{1, 0, 0}, {0, 1, -1}, {0, 1, 1}};
KroneckerProduct[m, HadamardMatrix[n/3]]]
HadamardMatrix1[n_] := If[Mod[n, 3] == 0 &&
IntegerQ[Log[3, n]], HadamardMatrix[n], Table[HadamardMatrix[3^(Floor[
Log[3, n]] + 1)][[i, j]], {i, n}, {j, n}]]
Table[HadamardMatrix1[n], {n, 1, 10}]
Join[{{1}},
Table[CoefficientList[CharacteristicPolynomial[HadamardMatrix1[n],
x], \
x], {n, 1, 10}]]
Flatten[%]
Join[{1}, Table[Apply[
Plus, CoefficientList[
CharacteristicPolynomial[HadamardMatrix1[n], x], x]], {n, 1, 10}]]
Table[HadamardMatrix1[n].Transpose[HadamardMatrix1[n]], {n, 1, 10}]
Table[HadamardMatrix1[n].HadamardMatrix1[n], {n, 1, 10}]
ListDensityPlot[HadamardMatrix1[3^5], Frame ->
False, Mesh -> False, ColorFunction -> (Hue[1 - #] &)]



Thinking like an Alien again...
Remember in the oriiginal H.G. Wells "war of the worlds"
the aliens used base three.

Only partually successful,
but it is a new kind of orthogonality
If you change the pattern matrix to:
{{Sqrt[2], 0, 0},
{0, 1, -1},
{0, 1, 1}}
the result gives diagonal 2^n on the 3^n levels.
as Matrix transposes,
so it is a kind of limited matrix orthogonality.
I had tried 3x3 matrix self-similarity before,
but never this well done!

There may well be better pattern matrices
that give a better more
orthogonal result.



%I A159663
%S A159663 1,1,1,1,2,1,2,4,3,1,2,6,7,4,1,2,8,13,11,5,1,4,16,28,28,17,
%T A159663 6,1,8,32,60,68,50,24,7,1,16,64,124,152,128,76,31,8,1,64,256,
%U A159663 480,560,452,268,120,40,9,1,64,320,736,1040,1012,720,388,160,49
%V A159663
1,1,-1,1,-2,1,2,-4,3,-1,2,-6,7,-4,1,2,-8,13,-11,5,-1,4,-16,28,-28,17,
%W A159663
-6,1,8,-32,60,-68,50,-24,7,-1,16,-64,124,-152,128,-76,31,-8,1,64,-256,
%X A159663
480,-560,452,-268,120,-40,9,-1,64,-320,736,-1040,1012,-720,388,-160,49
%N A159663 Base three Hadamard matrix self-similarity characteristic
polynomials: M(3^n)->M(3^(n+1) %C A159663 Row sums are zero except
for one.
%C A159663 the diagonality of the product
%C A159663 M(n).Transpose(M(n))
%C A159663 fails on n=3.
%C A159663 The orthogonality is imperfect.
%C A159663 The matrix self-similarity does work.
%C A159663 Example matrix:
%C A159663 M(6)={{1, 0, 0, 0, 0, 0}, %C A159663 {0, 1, -1, 0, 0, 0}, %C
A159663 {0, 1, 1, 0, 0, 0}, %C A159663 {0, 0, 0, 1, 0, 0}, %C A159663
{0, 0, 0, 0, 1, -1}, %C A159663 {0, 0, 0, 0, 1, 1}} %F A159663
M(3^n)->M(3^(n+1);
%F A159663 t(n,m)=coefficients(characteristicpolynomial(M(n),x),x) %e
A159663 {1}, %e A159663 {1, -1}, %e A159663 {1, -2, 1}, %e A159663 {2,
-4, 3, -1}, %e A159663 {2, -6, 7, -4, 1}, %e A159663 {2, -8, 13, -11, 5,
-1}, %e A159663 {4, -16, 28, -28, 17, -6, 1}, %e A159663 {8, -32, 60,
-68, 50, -24, 7, -1}, %e A159663 {16, -64, 124, -152, 128, -76, 31, -8,
1}, %e A159663 {64, -256, 480, -560, 452, -268, 120, -40, 9, -1}, %e
A159663 {64, -320, 736, -1040, 1012, -720, 388, -160, 49, -10, 1} %t
A159663 MatrixJoinH[A_, B_] := Transpose[Join[Transpose[A], Transpose[B]]];
%t A159663 KroneckerProduct[M_, N_] := Module[{M1, N1, LM, LN, N2},
%t A159663 M1 = M;
%t A159663 N1 = N;
%t A159663 LM = Length[M1];
%t A159663 LN = Length[N1];
%t A159663 Do[M1[[i, j]] = M1[[i, j]]N1, {i, 1, LM}, {j, 1, LM}];
%t A159663 Do[M1[[i, 1]] = MatrixJoinH[M1[[i, 1]], M1[[i, j]]], {j, 2,
LM}, {i, 1, LM}];
%t A159663 N2 = {}; Do[AppendTo[N2, M1[[i, 1]]], {i, 1, LM}];
%t A159663 N2 = Flatten[N2];
%t A159663 Partition[N2, LM*LN, LM*LN]]
%t A159663 HadamardMatrix[0] := {{1}}
%t A159663 HadamardMatrix[2] := {{1, -1}, {1, 1}}
%t A159663 HadamardMatrix[3] := {{1, 0, 0}, {0, 1, -1}, {0, 1, 1}}
%t A159663 HadamardMatrix[n_] := Module[{m},
%t A159663 m = {{1, 0, 0}, {0, 1, -1}, {0, 1, 1}}; KroneckerProduct[m,
HadamardMatrix[n/3]]]
%t A159663 HadamardMatrix1[n_] := If[Mod[n, 3] == 0 && IntegerQ[Log[3,
n]], HadamardMatrix[n],
%t A159663 Table[HadamardMatrix[3^(Floor[Log[3, n]] + 1)][[i, j]], {i,
n}, {j, n}]];
%t A159663 Table[HadamardMatrix1[n], {n, 1, 10}] Join[{{1}},
Table[CoefficientList[ CharacteristicPolynomial[HadamardMatrix1[n], x],
x], {n, 1, 10}]];
%t A159663 Flatten[%] %Y A159663 A158800,A158239,A122944,A123184 %K
A159663 sign,tabl
%O A159663 1,5
%A A159663 Roger L. Bagula (rlbagulatftn(AT)yahoo.com), Apr 19 2009
--
Respectfully, Roger L. Bagula
11759Waterhill Road, Lakeside,Ca 92040-2905,tel: 619-5610814
:http://www.geocities.com/rlbagulatftn/Index.html
alternative email: ***@sbcglobal.net
Roger Bagula
2009-04-19 15:33:09 UTC
Permalink
Loading Image...

This was a little harder to get working
and again it fails to be strictly orthogonal at all levels,
but again it is "mostly"
orthagonal...
And the matrices give fractals of a strange sort as well.
Mathematica:
Clear[HadamardMatrix, HadamardMatrix1]
MatrixJoinH[A_, B_] := Transpose[Join[Transpose[A], Transpose[B]]]
KroneckerProduct[M_, N_] := Module[{M1, N1, LM, LN, N2},
M1 = M;
N1 = N;
LM = Length[M1];
LN = Length[N1];
Do[M1[[i, j]] = M1[[i, j]]N1, {i, 1, LM}, {j, 1, LM}];
Do[M1[[i, 1]] = MatrixJoinH[M1[[i, 1]], M1[[i, j]]], {j, 2, LM}, {
i, 1, LM}];
N2 = {};
Do[AppendTo[N2, M1[[i, 1]]], {i, 1, LM}];
N2 = Flatten[N2];
Partition[N2, LM*LN, LM*LN]]
HadamardMatrix[1] := {{1}}
HadamardMatrix[2] := {{1, 1}, {1, -1}}
HadamardMatrix[3] := {{1, 0, 0}, {0, 1, 1}, {0, 1, -1}}
HadamardMatrix[4] := {{1, 1, 1, 1}, {1, -1, 1, -1}, {1,
1, -1, -1}, {1, -1, -1, 1}}
HadamardMatrix[5] := {{2, 0, 0, 0, 0}, {0, 1, 1, 1, 1}, {0, 1, -1, 1,
-1}, {0,
1, 1, -1, -1}, {0, 1, -1, -1, 1}}
HadamardMatrix[n_] := Module[{m},
m = {{2, 0, 0, 0, 0}, {0, 1, 1, 1, 1}, {0, 1, -1, 1, -1}, {0, 1,
1, -1, -1}, {0, 1, -1, -1, 1}};
KroneckerProduct[m, HadamardMatrix[n/5]]]
HadamardMatrix1[n_] := If[n ≤ 5, HadamardMatrix[n], If[Mod[n,
5] == 0 && IntegerQ[Log[5, n]],
HadamardMatrix[n], Table[HadamardMatrix[5^(Floor[Log[
6, n]] + 1)][[i, j]], {i, n}, {j, n}]]]
Table[HadamardMatrix1[n], {n, 1, 10}]
Join[{{1}},
Table[CoefficientList[CharacteristicPolynomial[HadamardMatrix1[n],
x], x], {n, 1, 10}]]
Flatten[%]
Join[{1},
Table[Apply[Plus, \
CoefficientList[CharacteristicPolynomial[HadamardMatrix1[n], x], x]],
{n, 1, \
10}]]
Table[HadamardMatrix1[n].Transpose[HadamardMatrix1[n]], {n, 1, 10}]
Table[HadamardMatrix1[n].HadamardMatrix1[n], {n, 1, 10}]
ListDensityPlot[HadamardMatrix1[125], Frame -> False, Mesh -> False, \
ColorFunction -> (Hue[1 - #] &)]

%I A159670
%S A159670 1,1,1,2,0,1,2,2,1,1,16,0,8,0,1,32,16,16,8,2,1,2048,1536,0,192,
%T A159670 24,6,1,2048,3584,1536,192,216,18,7,1,4096,3072,2048,1920,48,204,
%U A159670 26,6,1,8192,2048,8192,256,2208,312,188,34,5,1,32768,24576
%V A159670 1,1,-1,-2,0,1,-2,2,1,-1,16,0,-8,0,1,32,-16,-16,8,2,-1,2048,-1536,0,192,
%W A159670 -24,-6,1,2048,-3584,1536,192,-216,18,7,-1,-4096,3072,2048,-1920,48,204,
%X A159670 -26,-6,1,8192,2048,-8192,256,2208,-312,-188,34,5,-1,32768,-24576
%N A159670 Base five Hadamard matrix self-similarity characteristic polynomials: M(5^n) matrix self similar to M(5^(n+1))
%C A159670 Row sums are:
%C A159670 {1, 0, -1, 0, 9, 9, 675, 0, -675, 4050, 6075,...}.
%C A159670 Matrix example:
%C A159670 M(7)={{4, 0, 0, 0, 0, 0, 0},
%C A159670 {0, 2, 2, 2, 2, 0, 0},
%C A159670 {0, 2, -2, 2, -2, 0, 0},
%C A159670 {0, 2, 2, -2, -2, 0,0},
%C A159670 {0, 2, -2, -2, 2, 0, 0},
%C A159670 {0, 0, 0, 0, 0, 2, 0},
%C A159670 {0, 0, 0, 0, 0, 0, 1}}.
%C A159670 Orthogonality fails on n=9.
%F A159670 M(5^n) matrix self similar to M(5^(n+1))
%F A159670 t(n,m)=coefficients(characteristicpolynomial(M(n),x),x)
%e A159670 {1},
%e A159670 {1, -1},
%e A159670 {-2, 0, 1},
%e A159670 {-2, 2, 1, -1},
%e A159670 {16, 0, -8, 0, 1},
%e A159670 {32, -16, -16, 8, 2, -1},
%e A159670 {2048, -1536, 0, 192, -24, -6, 1},
%e A159670 {2048, -3584, 1536, 192, -216, 18, 7, -1},
%e A159670 {-4096, 3072, 2048, -1920, 48, 204, -26, -6, 1},
%e A159670 {8192, 2048, -8192, 256, 2208, -312, -188, 34, 5, -1},
%e A159670 {32768, -24576, -16384, 15360, 1664, -3168, 208, 240, -32, -6, 1}
%t A159670 Clear[HadamardMatrix, HadamardMatrix1]
%t A159670 MatrixJoinH[A_, B_] := Transpose[Join[Transpose[A], Transpose[B]]]
%t A159670 KroneckerProduct[M_, N_] := Module[{M1, N1, LM, LN, N2},
%t A159670 M1 = M;
%t A159670 N1 = N;
%t A159670 LM = Length[M1];
%t A159670 LN = Length[N1];
%t A159670 Do[M1[[i, j]] = M1[[i, j]]N1, {i, 1, LM}, {j, 1, LM}];
%t A159670 Do[M1[[i, 1]] = MatrixJoinH[M1[[i, 1]], M1[[i, j]]], {j, 2, LM}, { i, 1, LM}];
%t A159670 N2 = {};
%t A159670 Do[AppendTo[N2, M1[[i, 1]]], {i, 1, LM}];
%t A159670 N2 = Flatten[N2];
%t A159670 Partition[N2, LM*LN, LM*LN]]
%t A159670 HadamardMatrix[1] := {{1}}
%t A159670 HadamardMatrix[2] := {{1, 1}, {1, -1}}
%t A159670 HadamardMatrix[3] := {{1, 0, 0}, {0, 1, 1}, {0, 1, -1}}
%t A159670 HadamardMatrix[4] := {{1, 1, 1, 1}, {1, -1, 1, -1}, {1, 1, -1, -1}, {1, -1, -1, 1}}
%t A159670 HadamardMatrix[5] := {{2, 0, 0, 0, 0}, {0, 1, 1, 1, 1}, {0, 1, -1, 1, -1}, {0, 1, 1, -1, -1}, {0, 1, -1, -1, 1}}
%t A159670 HadamardMatrix[n_] := Module[{m},
%t A159670 m = {{2, 0, 0, 0, 0}, {0, 1, 1, 1, 1}, {0, 1, -1, 1, -1}, {0, 1, 1, -1, -1}, {0, 1, -1, -1, 1}};
%t A159670 KroneckerProduct[m, HadamardMatrix[n/5]]]
%t A159670 HadamardMatrix1[n_] := If[n ≤ 5, HadamardMatrix[n],
%t A159670 If[Mod[n, 5] == 0 && IntegerQ[Log[5, n]], HadamardMatrix[n],
%t A159670 Table[HadamardMatrix[5^(Floor[Log[ 6, n]] + 1)][[i, j]], {i, n}, {j, n}]]] Table[HadamardMatrix1[n], {n, 1, 10}];
%t A159670 Join[{{1}}, Table[CoefficientList[CharacteristicPolynomial[HadamardMatrix1[n], x], x], {n, 1, 10}]];
%t A159670 Flatten[%]
%t A159670 Join[{1}, Table[Apply[Plus, CoefficientList[CharacteristicPolynomial[HadamardMatrix1[n], x], x]], {n, 1, 10}]];
%t A159670 Table[HadamardMatrix1[n].Transpose[HadamardMatrix1[n]], {n, 1, 10}];
%t A159670 Table[HadamardMatrix1[n].HadamardMatrix1[n], {n, 1, 10}];
%t A159670 ListDensityPlot[HadamardMatrix1[125], Frame -> False, Mesh -> False, ColorFunction -> (Hue[1 - #] &)]
%Y A159670 A158800,A158239,A122944,A123184
%K A159670 sign,tabl
%O A159670 1,4
%A A159670 Roger L. Bagula (rlbagulatftn(AT)yahoo.com), Apr 19 2009
Respectfully, Roger L. Bagula
11759Waterhill Road, Lakeside,Ca 92040-2905,tel: 619-5610814 :http://www.geocities.com/rlbagulatftn/Index.html
alternative email: ***@sbcglobal.net

Loading...