Computational Mathematics IV

Lists

list1={1,2,3,4}       (*    is a 1x4 matrix      *)

list2:=(({{1, 3}, {2, 4}, {3, 3}}))                (*    is a 3x2 matrix     *)

list2                                   (* is a list of lists     *)

MatrixForm[Transpose[list2]]

chpoly[m_]:=Det[y IdentityMatrix[Length[m]]-m]

m:=(({{2, -1}, {-3, 2}}))

chpoly[m]

m

MatrixPower[m,8]

q=Inverse[m] (*m is a square matrix*)

TableForm[q]

m.q  (*matrix multiplication*)

chpoly[m]

solutn=Solve[chpoly[m]==0,y]

{w1,w2}=x/.solutn

Simplify[Times@@{w1,w2}]

N[%11,3]

eigs=N[Eigensystem[m],3]

eigvals1=eigs[[1]]

eigvecs1=eigs[[2]]

N[Eigenvalues[m],3]

N[Eigenvectors[m],3]

Recurrence Relations

<<DiscreteMath`RSolve`

RSolve[a[n+1] == 2 a[n], a[n], n]

partsol=RSolve[{a[n+1] == 2 a[n], a[0] == 5},
                                a[n], n]

m={{3,-1},{0,1}}

es=Eigensystem[m]

p=Transpose[{{1,2},{1,0}}]

p=es[[2]]

q=Inverse[p]

d4=q.m.p

Table[(a[n] /.partsol)[[1]], {n, 0, 10}] // Expand

(*Fibonacci*)
RSolve[{a[n] == a[n-1] + a[n-2], 
    a[0] == a[1] == 1}, a[n], n] // FunctionExpand

Table[(a[n] /. %)[[1]], {n, 0, 10}] // Expand

x/.x->%

m1={{5,-2,0},{-1,4,0},{0,0,6}}

RSolve[{(({{a[n]}, {a[n+1]}, {a[n+2]}}))==m1.(({{a[n-1]}, {a[n]}, {a[n+1]}})),a[0]==a[1]==1},a[n],n]

Combinatorica

Combinatorica

(*Quit Kernel*)

Needs["Combinatorica`"]

c6={{2,6},{1,3},{4,2},{3,5},{4,6},{5,1}}

gr=FromAdjacencyLists[c6]  (*graph in Mathca5*)

ShowLabeledGraph[gr]

ShowLabeledGraph[RankedEmbedding[gr,{3}]]

gr[[1]]  (*edges in double brackets*)

e=Edges[gr]

gr[[2]]  (*vertices*)

v=Vertices[gr]

v={{0.5000000000000001`,0.8660254037844386`},{-0.4999999999999998`,0.8660254037844387`},{-1.`,0},{-0.5000000000000004`,-0.8660254037844384`},{0.49999999999999933`,-0.866025403784439`},{1.`,.5}}

adjmat=ToAdjacencyMatrix[gr](*adjacency matrix*)

es=Eigensystem[adjmat]

eigvec=es[[2]]

gr0=FromAdjacencyMatrix[adjmat,v](*adjacency matrix*)

gr1=FromUnorderedPairs[e,v]

IsomorphicQ[gr0,gr1]

d=DiagonalMatrix[{1,3,2,2,2,2,2}]

c6

gr=FromAdjacencyLists[c6];
matgr=ToAdjacencyMatrix[gr];B=matgr;eigs=N[Eigenvalues[B],3];
es=N[Eigensystem[B],3];evec=es[[2]];n=Length[B];
cp=Det[x  IdentityMatrix[n]-matgr];
Print["chpoly = ",cp," = ",Factor[cp], "eigs  ",eigs,"                           evec= ",evec];
Print["kereig   ", NullSpace[B]];

(*Dodecahedron*)

adjdod={{2,3,4},{1,5,6},{1,7,8},{1,9,10},{2,10,11},{2,7,12},{6,3,13},{3,9,14},{8,4,15},{4,5,16},
{12,5,19},{11,6,17},{7,14,17},{8,13,18},{9,16,18},{15,10,19},{12,13,20},{14,15,20},{11,16,20},{17,19,18}
};

Needs["Combinatorica`"]

gr=FromAdjacencyLists[adjdod];
matgr=ToAdjacencyMatrix[gr];c=matgr;
cp=Det[x  IdentityMatrix[20]-matgr];
Print["chpoly = ",cp," = ",Factor[cp]];
(*Print["eigsp = ", Chop[N[Eigensystem[matgr],3]]]*)Print["kereig   ", NullSpace[c]];

ShowLabeledGraph[RankedEmbedding[gr,{19}]]

A:=matgr; n=Length[A];
cp=Det[x IdentityMatrix[n]-A];
Print[cp,"=",Factor[cp],"eigs: ",
	NSolve[cp==0,x],"kernleigvec: ",NullSpace[A]];
For[i=1,i<n+1,i++,
	f[i_]:=N[{((i^2)/(((n+1))^2)),(i/(2 n+1))}];
	v:=Table[f[i],{i,n}];
	G:=FromAdjacencyMatrix[A,v];
	g[i_]:=DeleteVertex[G,i];
	m[i_]:=ToAdjacencyMatrix[g[i]];k[i_]:=Flatten[NullSpace[m[i]]];
	p[i_]:=Det[x IdentityMatrix[n-1]-m[i]];
	Print[i,":","chrpol=",
		Factor[p[i]],"eigs: ",
		NSolve[p[i]==0,x],"kernleigvec: ",NullSpace[m[i]],
		"THE Partial END"]];
q=Table[k[i],{i,n}];Print[q];(* inv=Inverse[q];Print["inv",q]*)
(*Print[Re[N[Eigensystem[A],3]],"THE END"]*)

MakeGraph

(*Quit kernel*)

(*Needs["GraphUtilities`"];*)

(*UseEsc ue Escto enter\[UndirectedEdge]directly:*)gr=Graph[ {UndirectedEdge[1,5],UndirectedEdge[2,5],3\[UndirectedEdge]5,4\[UndirectedEdge]5,1\[UndirectedEdge]6,2\[UndirectedEdge]6,3\[UndirectedEdge]6,4\[UndirectedEdge]6,5\[UndirectedEdge]6,1\[UndirectedEdge]7,2\[UndirectedEdge]7,3\[UndirectedEdge]7,4\[UndirectedEdge]7,5\[UndirectedEdge]7,6\[UndirectedEdge]7,1\[UndirectedEdge]10,2\[UndirectedEdge]10,3\[UndirectedEdge]10,4\[UndirectedEdge]10,5\[UndirectedEdge]10,6\[UndirectedEdge]10,7\[UndirectedEdge]10,8\[UndirectedEdge]10,9\[UndirectedEdge]10,1\[UndirectedEdge]11,2\[UndirectedEdge]11,3\[UndirectedEdge]11,4\[UndirectedEdge]11,5\[UndirectedEdge]11,6\[UndirectedEdge]11,7\[UndirectedEdge]11,8\[UndirectedEdge]11,9\[UndirectedEdge]11,10\[UndirectedEdge]11,1\[UndirectedEdge]13,2\[UndirectedEdge]13,3\[UndirectedEdge]13,4\[UndirectedEdge]13,5\[UndirectedEdge]13,6\[UndirectedEdge]13,7\[UndirectedEdge]13,8\[UndirectedEdge]13,9\[UndirectedEdge]13,10\[UndirectedEdge]13,11\[UndirectedEdge]13,12\[UndirectedEdge]13},VertexLabels->{"Name"}]

gra=ToCombinatoricaGraph[gr]

matgra=ToAdjacencyMatrix[gra]

AdjacencyGraph[matgra,VertexLabels->"Name",ImagePadding->10]

Graph[{a\[UndirectedEdge]b,b\[UndirectedEdge]c,c\[UndirectedEdge]a}]

degsq=Sort[VertexDegree[gr],Greater]

AdjacencyGraph[(({{0, 1, 1}, {1, 0, 1}, {1, 1, 0}})),VertexLabels->"Name",ImagePadding->10]

BeginPackage["Durffee`",{"Combinatorica`"}]; Needs["Combinatorica`"];degsq=Sort[VertexDegree[gr],Greater];Print[ DurfeeSquare[degsq]]

FerrersDiagram[{12,11,11,9,9,9,6,6,6,6,3,3,1}]

EndPackage[]

G=VertexDegree[Graph[{1\[UndirectedEdge]5,2\[UndirectedEdge]5,3\[UndirectedEdge]5,4\[UndirectedEdge]5,1\[UndirectedEdge]6,2\[UndirectedEdge]6,3\[UndirectedEdge]6,4\[UndirectedEdge]6,5\[UndirectedEdge]6,1\[UndirectedEdge]7,2\[UndirectedEdge]7,3\[UndirectedEdge]7,4\[UndirectedEdge]7,5\[UndirectedEdge]7,6\[UndirectedEdge]7,1\[UndirectedEdge]10,2\[UndirectedEdge]10,3\[UndirectedEdge]10,4\[UndirectedEdge]10,5\[UndirectedEdge]10,6\[UndirectedEdge]10,7\[UndirectedEdge]10,8\[UndirectedEdge]10,9\[UndirectedEdge]10,1\[UndirectedEdge]11,2\[UndirectedEdge]11,3\[UndirectedEdge]11,4\[UndirectedEdge]11,5\[UndirectedEdge]11,6\[UndirectedEdge]11,7\[UndirectedEdge]11,8\[UndirectedEdge]11,9\[UndirectedEdge]11,10\[UndirectedEdge]11,1\[UndirectedEdge]13,2\[UndirectedEdge]13,3\[UndirectedEdge]13,4\[UndirectedEdge]13,5\[UndirectedEdge]13,6\[UndirectedEdge]13,7\[UndirectedEdge]13,8\[UndirectedEdge]13,9\[UndirectedEdge]13,10\[UndirectedEdge]13,11\[UndirectedEdge]13,12\[UndirectedEdge]13},VertexLabels->{"Name"}]]

Needs["Combinatorica`"]

list={{2,3,4},{1,3},{1,2},{1}}

g=FromAdjacencyLists[list]

Adj=ToAdjacencyMatrix[g];A={Adj,{}}

(*A = {{{0,1,1,0},{1,0,1,1},{1,1,0,1},{0,1,1,0}},{}};*)
ShowLabeledGraph[FromAdjacencyMatrix[A[[1]]]]

isolatedGraph[n_] := {ConstantArray[0,{n,n}],{Table[i,{i,1,n}]}}




oneedgecontraction[A0_]:=
Module[{A = A0, B,n,m},
B = {};
For[n = 1, n ≤ Length[A[[1]]]-1,n++,
For[m = n+1, m ≤ Length[A[[1]]], m++,
AppendTo[B,mycontraction[A,{n,m}]];
]];
B = DeleteCases[B,A];
B
]

repeatedcontraction[A0_]:=
Module[{A =A0,B,m,mothers,num},
num = Length[A[[1]]] - 1;
f[list_,n_] := Map[oneedgecontraction,{list},{n}][[1]];
B = FoldList[f,A,Table[m, {m,1,num}]];
B

]


getGreater[A0_,B0_] :=
Module[{A = A0, B = B0,relations,greaterpos,greater,pos,i},
relations = repeatedcontraction[B];
pos = Position[relations,A];
greaterpos = {};
For [i = 1, i ≤ Length[pos],i++,
	AppendTo[greaterpos, Delete[ReplacePart[pos[[i]],1 ->pos[[i,1]]-1],-1]];
        ]; 
greater = Extract[relations,greaterpos];
greater
]

getGreaterAll[A0_,B0_] :=
Module[{A= A0, B=B0,i,temp,result},
temp = getGreater[A,B];
i = 0;
While[temp[[-1]] ≠ B,
i++;
temp = Join[temp,getGreater[temp[[i]],B]]];
result = Union[temp];
result
]


mobiusFunction[A0_,B0_] :=
Module[{A = A0, B = B0},
mu[B] = 1;
mu[x_] := -Sum[mu[getGreaterAll[x,B][[i]]],{i,1,Length[getGreaterAll[x,B]]}];
mu[A]
]

numberofvertices[A0_] := Module[{A = A0[[1]],row,i,n},
n = 0;
For[i = 1, i ≤ Length[A], i++, 
row = A[[i,All]];
If[row ≠ ConstantArray[0,Length[A]], n++;]];
If [n == 0, n = 1];
n
]


mycontraction[A0_,ij0_] :=

Module[{A = A0[[1]],previouscontractions = A0[[2]],pos,newcont, i = ij0[[1]], j = ij0[[2]], rowi, rowj, coli, colj,n},
If[(A[[i,j]] ≠ 0),
newcont=previouscontractions;
rowi = A[[i,All]];
rowj = A[[j,All]];
coli = A[[All,i]];
colj = A[[All,j]];
For [n = 1, n <= Length[rowi], n++,
rowi[[n]] = Boole[(rowi[[n]] == 1) || (rowj[[n]] == 1)];
rowj[[n]] = 0;
coli[[n]] = Boole[(coli[[n]] == 1) || (colj[[n]] == 1)];
colj[[n]] = 0;
];
rowi[[i]] = 0;
coli[[i]] = 0;
A[[i,All]] = rowi;
A[[All, i]] = coli;
A[[All, j]] = colj;
A[[j,All]] = rowj;
If[(MemberQ[previouscontractions,i,2] && !(MemberQ[previouscontractions,j,2])),pos = Position[previouscontractions,i][[1,1]];newcont[[pos]] = Union[previouscontractions[[pos]],{i,j}]];
If[(!(MemberQ[previouscontractions,i,2]) && MemberQ[previouscontractions,j,2]), pos = Position[previouscontractions,j][[1,1]];newcont[[pos]] = Union[previouscontractions[[pos]],{i,j}]];
If[(MemberQ[previouscontractions,i,2] && MemberQ[previouscontractions,j,2]), 
pos ={Position[previouscontractions,i][[1,1]],Position[previouscontractions,j][[1,1]]};
newcont[[pos[[1]]]] = Union[previouscontractions[[pos[[1]]]],previouscontractions[[pos[[2]]]]];
newcont = Delete[newcont,pos[[2]]];
]
If[!(MemberQ[previouscontractions,i,2] || MemberQ[previouscontractions,j,2]),newcont =Append[previouscontractions,{i,j}]];
{A,Sort[newcont]}, 
{A,previouscontractions}]
]

mobiusFunction[A,A]

A[[2]] = {};
mycontraction[A,{1,2}][[]]

Length[oneedgecontraction[A]]

A

repeatedcontraction[A]

isolatedGraph[4][[2]]

x = Position[repeatedcontraction[A],test]

Extract[repeatedcontraction[A],x]

test = oneedgecontraction[A][[1]]

test2 = oneedgecontraction[test][[2]]

oneedgecontraction[test2]

subgraphs = Prepend[getGreaterAll[isolatedGraph[4],A],isolatedGraph[4]];

Grid[Prepend[Table[{ShowLabeledGraph[FromAdjacencyMatrix[subgraphs[[i,1]]], ImageSize -> Tiny],MatrixForm[subgraphs[[i,1]]],MatrixForm[subgraphs[[i,2]]],Position[subgraphs,subgraphs[[i]]][[1,1]]},{ i,Length[subgraphs]}],{"Graph", "Adjacency Matrix","Contraction", "Label"}], Frame -> All]

ShowLabeledGraph[HasseDiagram[MakeGraph[Subsets[4],#2⋂#1===#1&&#1≠#2&]]]

ShowLabeledGraph[HasseDiagram[MakeGraph[subgraphs,MemberQ[getGreater[#1,A],#2]&]]]

crompol = Sum[mobiusFunction[subgraphs[[i]],A]*k^(numberofvertices[subgraphs[[i]]]), {i,1,Length[subgraphs]}]

Factor[crompol]

Z=(({{1, 1, 1, 1, 1, 1, 1, 1, 1, 1}, {0, 1, 0, 1, 0, 0, 1, 1, 0, 1}, {0, 0, 1, 1, 0, 0, 0, 0, 1, 1}, {0, 0, 0, 1, 0, 0, 0, 0, 0, 1}, {0, 0, 0, 0, 1, 0, 1, 0, 1, 1}, {0, 0, 0, 0, 0, 1, 0, 1, 1, 1}, {0, 0, 0, 0, 0, 0, 1, 0, 0, 1}, {0, 0, 0, 0, 0, 0, 0, 1, 0, 1}, {0, 0, 0, 0, 0, 0, 0, 0, 1, 1}, {0, 0, 0, 0, 0, 0, 0, 0, 0, 1}}))

MOBIUS=Inverse[Z]; MatrixForm[MOBIUS]

(*Last Column only needed*)

Together[k(k-1)(k-2)(k-3)  +2k(k-1)(k-2)] (*Partitions Lovasz*)

(*(Subscript[p, G])(k)==(Subscript[p, (Subscript[K, 3])(OverDot[⋃])(Subscript[K, 1])])(k)-(Subscript[p, (Subscript[K, 3])])(k).    $p_{G}(k)=p_{K_3\dot\cup K_1}(k)-p_{K_3}(k).$*)
(*Recursive formula*)

Together[k^2(k-1)(k-2)-k(k-1)(k-2)]

GramSchmidtOrthogonalization

<<LinearAlgebra`Orthogonalization`

eigvec={{-(1/(Sqrt[6])),(1/(Sqrt[6])),-(1/(Sqrt[6])),(1/(Sqrt[6])),-(1/(Sqrt[6])),(1/(Sqrt[6]))},{(1/(Sqrt[6])),(1/(Sqrt[6])),(1/(Sqrt[6])),(1/(Sqrt[6])),(1/(Sqrt[6])),(1/(Sqrt[6]))},{-(1/2),0,(1/2),-(1/2),0,(1/2)},{-(1/(2 (Sqrt[3]))),(1/(Sqrt[3])),-(1/(2 (Sqrt[3]))),-(1/(2 (Sqrt[3]))),(1/(Sqrt[3])),-(1/(2 (Sqrt[3])))},{(1/2),0,-(1/2),-(1/2),0,(1/2)},{-(1/(2 (Sqrt[3]))),-(1/(Sqrt[3])),-(1/(2 (Sqrt[3]))),(1/(2 (Sqrt[3]))),(1/(Sqrt[3])),(1/(2 (Sqrt[3])))}}

{w1,w2,w3,w4,w5,w6} = GramSchmidt[eigvec]

w=%

Chop[w .Transpose[w]]

pp1=Transpose[w] .{{1,0,0,0,0,0},{0,0,0,0,0,0},{0,0,0,0,0,0},{0,0,0,0,0,0},{0,0,0,0,0,0},{0,0,0,0,0,0}}.w

pp2=Transpose[A] .{{0,0,0,0,0,0},{0,1,0,0,0,0},{0,0,1,0,0,0},{0,0,0,0,0,0},{0,0,0,0,0,0},{0,0,0,0,0,0}}.A

MatrixForm[A]

MatrixForm[%]

MatrixForm[%]

A=Table[a[i,j],{i,1,6},{j,1,6}]
(*m=TableForm[Table[Binomial[i,j],{i,0,8},{j,0,i}]]*)

m

pp3=Transpose[w] .{{0,0,0,0,0,0},{0,0,0,0,0,0},{0,0,0,0,0,0},{0,0,0,1,0,0},{0,0,0,0,1,0},{0,0,0,0,0,0}}.w

pp4=Transpose[w] .{{0,0,0,0,0,0},{0,0,0,0,0,0},{0,0,0,0,0,0},{0,0,0,0,0,0},{0,0,0,0,0,0},{0,0,0,0,0,1}}.w

a=Chop[-2 pp1-pp2+pp3+2pp4]

Chop[a-B]

e