Mathematica 9 is now available
Services & Resources / Wolfram Forums
-----
 /
MathGroup Archive
2006
*January
*February
*March
*April
*May
*June
*July
*August
*September
*October
*November
*December
*Archive Index
*Ask about this page
*Print this page
*Give us feedback
*Sign up for the Wolfram Insider

MathGroup Archive 2006

[Date Index] [Thread Index] [Author Index]

Search the Archive

[Fwd: tripartite K(n) linked graphs as polynomials]

  • To: mathgroup at smc.vnet.net
  • Subject: [mg71331] [Fwd: tripartite K(n) linked graphs as polynomials]
  • From: Roger Bagula <rlbagula at sbcglobal.net>
  • Date: Wed, 15 Nov 2006 06:43:32 -0500 (EST)

Using graph theory to get higher level linked
structures, I get these
quantum Heisenberg algebra like polynomials.
The resolution of the graph root spectrum is
secular equation like
in quantum mechanical terms.

The K(2)*K(2)*K(2) tripartite is:
{{0, 1, 1, 0, 1, 0},
{1, 0, 0, 1, 0, 1},
{1, 0, 0, 1, 1, 0},
{0, 1, 1, 0, 0, 1},
{1, 0, 1, 0, 0, 1},
{0, 1, 0, 1, 1, 0}}
with Characteristic Polynomial:
12 x^2 - 4 x^3 - 9x^4 + x^6
root / graph spectrum is:
({{x -> -2 }, {x ->-2}, {x -> 0.`}, {x -> 0.`}, {x -> 1.`}, {x -> 3.`}}

The K(4)*K(4)*K(4) tripartite is: ( three tetrahedrons linked together)
{{0, 1, 1, 1, 1, 0, 0, 0, 1, 0, 0, 0},
{1, 0, 1, 1, 0, 1, 0, 0, 0, 1, 0, 0},
{1, 1, 0, 1, 0, 0, 1, 0, 0, 0, 1, 0},
{1, 1, 1, 0, 0, 0, 0, 1, 0, 0, 0, 1},
{1, 0, 0, 0, 0, 1, 1, 1, 1, 0, 0, 0},
{0, 1, 0, 0, 1, 0, 1, 1, 0, 1, 0, 0},
{0, 0, 1, 0, 1, 1, 0, 1, 0, 0, 1, 0},
{0, 0, 0, 1, 1, 1, 1, 0, 0, 0, 0, 1},
{1, 0, 0, 0, 1, 0, 0, 0, 0, 1, 1, 1},
{0, 1, 0, 0, 0, 1, 0, 0, 1, 0, 1, 1},
{0, 0, 1, 0, 0, 0, 1, 0, 1, 1, 0, 1},
{0, 0, 0, 1, 0, 0, 0, 1, 1, 1, 1, 0}}
with characteristic polynomial:
1280 - 1536 x - 2304 x^2 + 2432 x^3 + 2016x^4 - 1440 x^5 - 1008 x^6 + 
360x^7 + 261x^8 - 32 x^9 - 30 x^10 + x^12
(-5 + x)(-2 + x)^2(-1+ x)^3(2 + x)^6
The graph spectrum/ roots are:
{{x -> -2.}, {x -> -2.}, {x -> -2.}, {x -> -2.}, {x -> -2.}, {x -> -2.}, 
{x -> 1.}, {x -> 1.}, {x -> 1.}, {x -> 2.}, {x -> 2.}, {x -> 5.}}
NSolve[CharacteristicPolynomial[An[12], x] == 0, x]
If quarks behaves as quaternion like Leptons in Hadrons with Gluon 
bondings as the graph edges,
this would be a model for a proton with 6 Regge trajectory  Pions  (Pi 
mesons) at the -2 levels.

%I A000001
%S A000001 1, 1, -1, 0, -2, 1, 2, 3, 0, -1, 0, -4, -5, 0, 1, 0, 0, 0, 6, 
0, -1, 0, 0,
12, -4, -9, 0, 1, 0, 12, -10, -24, 8, 12, 0, -1, 1, 4, -15, -8, 35, -4, -14,
0, 1, 64, -144, 0, 168, -36, -81, 12, 18, 0, -1, -128, 96, 320, -200, -284,
116, 121, -20, -22, 0, 1, 0, 40, -52, -236, 170, 354, -112, -158, 18, 25, 0,
-1, 1280, -1536, -2304, 2432, 2016, -1440, -1008, 360, 261, -32, -30, 0, 1,
-1920, -256, 5920, 1152, -6536, -1968, 3222, 1320, -666, -348, 46, 35, 
0, -1,
3, 128, -97, -1440, 315, 3972, 588, -3664, -1500, 792, 429, -48, -39, 0, 1,
13824, -11520, -38400, 20480, 48960, -10080, -33440, -2160, 11430, 2955,
-1548, -615, 70, 45, 0, -1, -18432, -9216, 67328, 39936, -89344, -67968,
49824, 53696, -6456, -19044, -3321, 2368, 771, -92, -51, 0, 1, 0, 336, -156,
-5430, -130, 23653, 9156, -37544, -26782, 17840, 22022, 3402, -2860, -917,
100, 56, 0, -1, 114688, -73728, -414720, 132096, 679680, 0, -600960, 
-167040,
272160, 149920, -43236, -48924, -5565, 4608, 1215, -132, -63, 0, 1, -143360,
-101376, 611840, 517120, -966656, -1060480, 623680, 1072960, -10960, 
-531820,
-178730, 98512, 71660, 5240, -6398, -1465, 164, 70, 0, -1, 5, 684, -197,
-15888, -2750, 99176, 53102, -241520, -215229, 216140, 318197, 11360,
-154882, -82136, -4395, 7648, 1700, -180, -76, 0, 1
%N A000001 tripartite straight linked graphs as matrices producing 
polynomials and their triangular sequence:
Matrix model (A120658 ):
M(n,m,9)={{0, 1, 1, 1, 0, 0, 1, 0, 0},
         {1, 0, 1, 0, 1, 0, 0, 1, 0},
         {1, 1, 0, 0, 0, 1, 0, 0, 1},
         {1, 0, 0, 0, 1, 1, 1, 0, 0},
         {0, 1, 0, 1, 0, 1, 0, 1, 0},
         {0, 0, 1, 1, 1, 0, 0, 0, 1},
         {1, 0, 0, 1, 0, 0, 0, 1, 1},
         {0, 1, 0, 0, 1, 0, 1, 0, 1},
         {0, 0, 1, 0, 0, 1, 1, 1, 0}}
This Model is striaght hyper-connections between 3 generalized K(n) 
complete graphs.
%C A000001 The Large roots count:
Table[x /. NSolve[CharacteristicPolynomial[An[d], x] == 0, x][[d]], {d, 
2, 20}]
{2.`, 2.`, 2.5615528128088303`, 2.449489742783178`, 3.`, 
3.4880262221757476`,
3.552081133571793`, 3.9999999995851967`, 4.4586794310874645`,
4.597458186284443`, 5.`, 5.444061970030621`, 5.6239192478734195`,
5.999999274025329`, 6.43569176446824`, 6.641461869097823`,
6.999999682622629`, 7.415010662974701`, 7.654010866523878`}
%D A000001 F. Chung and R. L. Graham,Erdos on Graphs,AK Peters Ltd., Ma,1998
%D A000001 Weisstein, Eric W. "Complete Graph." From MathWorld--A 
Wolfram Web Resource. http://mathworld.wolfram.com/CompleteGraph.html
%F A000001 m(n,m,d)=If[m == n + Floor[d/3] , 1, If[m == n - Floor[d/3], 
1,If[m == n + Floor[2*d/3] , 1, If[m == n - Floor[2*d/3],1, If[ n <= 
Floor[d/3] && m <= Floor[d/3] && (n < m || n > m), 1, If[ n > Floor[d/3] 
&& n < Floor[2*d/3] + 1 && m > Floor[d/3] && m < Floor[2*d/3] + 1 && (n 
< m ||n > m), 1, If[ n > Floor[2*d/3] && m > Floor[2*d/3] && (n < m || n 
> m), 1, If[n == m, 0, 0]]]]]]]]
%e A000001 Triangular sequence:
{1},
{1, -1},
{0, -2, 1},
{2, 3, 0, -1},
{0, -4, -5, 0, 1},
{0, 0, 0, 6,0, -1},
{0, 0, 12, -4, -9, 0, 1},
{0, 12, -10, -24, 8, 12, 0, -1},
{1, 4, -15, -8, 35, -4, -14, 0, 1},
{64, -144, 0, 168, -36, -81, 12, 18, 0, -1},
{-128, 96, 320, -200, -284, 116, 121, -20, -22, 0, 1},
{0, 40, -52, -236,170, 354, -112, -158, 18,25, 0, -1},
{1280, -1536, -2304, 2432, 2016, -1440, -1008, 360, 261, -32, -30, 0, 
1}, {-1920, -256, 5920, 1152, -6536, -1968, 3222, 1320, -666, -348, 46, 
35, 0, -1}
Polynomials:
1
1 - x,
-2 x + x^2,
2 + 3 x - x^3,
-4 x - 5 x^2 + x^4,
6 x^3 - x^5,
12 x^2 - 4 x^3 - 9 x^4 + x^6,
12 x - 10 x^2 - 24 x^3 + 8 x^4 + 12 x^5 - x^7,
1 + 4 x - 15 x^2 - 8 x^3 + 35 x^4 - 4 x^5 - 14 x^6 + x^8,
64 - 144 x + 168 x^3 - 36 x^4 - 81 x^5 + 12 x^6 + 18 x^7 - x^9
%t A000001 M[n_, m_, d_] = If[ m == n + Floor[d/3] , 1, If[m == n - 
Floor[d/3], 1, If[m == n +Floor[2*d/3] , 1, If[m == n - Floor[2*d/3], 1, 
If[ n <= Floor[d/3] && m <= Floor[d/3] && (n < m || n > m), 1, If[ n > 
Floor[d/3] && n < Floor[2*d/3] + 1 && m > Floor[d/3] && m <Floor[2*d/3] 
+ 1 && (n < m || n > m), 1, If[ n > Floor[2*d/3] && m > Floor[2*d/3] && 
(n < m || n > m), 1, If[n == m, 0, 0]]]]]]]];
An[d_] := Table[M[n, m, d], {n, 1, d}, {m, 1, d}];
Join[An[1], Table[CoefficientList[CharacteristicPolynomial[An[d], x], 
x], {d, 1, 20}]];
Flatten[%]
%Y A000001 Cf. A120658
%O A000001 1
%K A000001 ,nonn,
%A A000001 Roger Bagula  and Gary Adamson (rlbagula at sbcglobal.net), Nov 
12 2006



  • Prev by Date: Re: Re: xvnc Mathematica menu fonts
  • Next by Date: Re: ContourFindRoot
  • Previous by thread: Re: Vandermonde Matrix/Optimization question
  • Next by thread: mouse drage listener!