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[x IdentityMatrix[Length[m]]-m]

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

m

MatrixPower[m,8]

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

TableForm[q]

m.q  (*matrix multiplication*)

chpoly[m]

Solve[chpoly[m]==0,x]

{w1,w2}=x/.%11

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`  (*No need in version 7*)

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

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] /. %25)[[1]], {n, 0, 10}] // Expand

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

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

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`"

<<DiscreteMath`Combinatorica`  (*Version 5*)

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]

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

gr1=FromUnorderedPairs[e,v]

IsomorphicQ[gr0,gr1]

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

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}
};

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}]]

Clear[p,g,m];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"]*)

GramSchmidtOrthogonalization

<<LinearAlgebra`Orthogonalization` (*Version 5*)

(*Orthogonalize instead of GramSchmidt in version 7*)

{w1, w2, w3,w4,w5,w6} = GramSchmidt[evec];w=%

Chop[w .Transpose[w]]

(*Spectral Decomposition*)

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[w] .{{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}}.w

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