SetAttributes[Arc,{Orderless}]
Arc/:Arc[a_,b_]Arc[b_,c_]:=Arc[a,c]
Arc/:((Arc[a_,b_])^2):=qI[2]
Arc[a_,a_]:=qI[2]

δ=(Sqrt[((5+(Sqrt[13]))/2)]);

QI[0]=0;
QI[1]=1;
QI[n_]:=QI[n]=Simplify[δ QI[n-1]-QI[n-2]]

qIRules={qI[n_]:> QI[n]};

JW/:JW[a_,b_]:=Arc[a,b]

JW[pp__]:=(JW@@(z$/@Range[Length[{pp}]]))/.{z$[i_]:>{pp}[[i]]}
JW[pp__z$]:=JW[pp]=Module[{p={pp},b,i,n},
n=Length[{pp}]/2;
Collect[Sum[b=Drop[p,{2 n-i,2 n-i+1}];(((-1))^(i+n))((qI[i]/qI[n])/.qIRules) Expand[((JW@@(b/.z$->z$$))/.z$$->z$) Arc[p[[2 n-i]],p[[2 n-i+1]]]],{i,1,n}],_Arc,Together]]

jw1=Expand[JW@@Table[i,{i,1,2}]]

jw2=Expand[JW@@Table[i,{i,1,4}]]

jw3=Expand[JW@@Table[i,{i,1,6}]]

jw4=Expand[JW@@Table[i,{i,1,8}]];

vertices={0,1,2,3,a,b,c,d,e,f};

evenVertices={0,2,a,d,c,f};

(Adjacency=With[{a=(({{0, 1, 0, 0, 0, 0, 0, 0, 0, 0}, {0, 0, 1, 0, 0, 0, 0, 0, 0, 0}, {0, 0, 0, 1, 0, 0, 0, 0, 0, 0}, {0, 0, 0, 0, 1, 0, 0, 1, 0, 0}, {0, 0, 0, 0, 0, 1, 0, 0, 0, 0}, {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, 1, 0}, {0, 0, 0, 0, 0, 0, 0, 0, 0, 1}, {0, 0, 0, 0, 0, 0, 0, 0, 0, 0}}))},a+Transpose[a]])//MatrixForm

adjacentVertices[v_]:=With[{n=Position[vertices,v][[1,1]]},Pick[vertices,#==1&/@Adjacency[[n]]]]

adjacentVertices[3]

Clear[FreePaths]

FreePaths[0]=FreePath[#]&/@evenVertices

Extensions[path_]:=Append[path,#]&/@adjacentVertices[Last[path]]

Extensions[FreePath[0]]

FreePaths[n_Integer]/;n≥1:=FreePaths[n]=
Flatten[Extensions/@FreePaths[n-1],1]

FreePaths[4]

Clear[FreeLoops]

FreeLoops[0]:=FreeLoop@@#&/@FreePaths[0]

FreeLoops[n_]:=FreeLoops[n]=Cases[FreePaths[n] ,FreePath[x_,y___,x_]:>FreeLoop[x,y,x]]

coefficient[arcs_,loop_FreeLoop]:=With[{n=Length[loop]-1},
Together[arcs/.{Arc[a_,b_]:>Delta[loop[[a]],loop[[b+1]]]Delta[loop[[a+1]],loop[[b]]]If[(a≤(n/2)∧b≤(n/2))∨(a>(n/2)∧b>(n/2)),(Sqrt[((dimension[loop[[a+1]]])/(dimension[loop[[a]]]))]),1]}]
]

dimension[0]=dimension[c]=dimension[f]=1;

dimension[1]=dimension[b]=dimension[e]=δ;
dimension[2]=dimension[a]=dimension[d]=(δ^2)-1;
dimension[3]=(δ^3)-2δ;

Delta[i_,i_]:=1
Delta[i_,j_]:=0

coefficient[Arc[1,4]Arc[2,3]Arc[5,6],FreeLoop[0,1,2,1,0,1,0]]

arcsToLoops[n_,arcs__]:=Plus@@(coefficient[arcs,#]#&/@FreeLoops[n])

Clear[fs]
fs[x_]:=fs[x]=Module[{r},r=FullSimplify[x];(*Print[r];*)r]

Collect[arcsToLoops[4,jw2],_FreeLoop,fs]

act[FreeLoop[x__],FreePath[y__]]:=With[{n=Length[{y}]},FreePath@@Take[{x},n]Delta[Reverse[Drop[{x},n-1]],{y}]]

act[X_Plus,Y_]:=act[#,Y]&/@X
act[z_ X_FreeLoop,Y_]:=z act[X,Y]
act[X_,Y_Plus]:=act[X,#]&/@Y
act[X_,z_ Y_FreePath]:=z act[X,Y]

f1=Collect[arcsToLoops[2,jw1],_FreeLoop,fs]
f2=Collect[arcsToLoops[4,jw2],_FreeLoop,fs]

f3=Collect[arcsToLoops[6,jw3],_FreeLoop,fs];

f4=Collect[arcsToLoops[8,jw4],_FreeLoop,fs];

subspace=act[f4,#]&/@FreePaths[4]

Length[FreePaths[4]]

subspace2=subspace/.fp_FreePath:>UnitVector[87,Position[FreePaths[4],fp][[1,1]]]

subspace3=Map[fs,subspace2,{2}]

subspace4=DeleteCases[subspace3,0|Table[0,{150}]]

Last[subspace4]

subspace4.FreePaths[4]

foo=Flatten[Outer[DeleteCases[Union[(subspace4.FreePaths[4])/.fp:FreePath[x_,_,_,_,y_]:>Delta[x,#1]Delta[y,#2]fp],0]&,vertices,vertices],1]

Length/@foo

MatrixRank/@(DeleteCases[foo,{}]/.fp_FreePath:>UnitVector[87,Position[FreePaths[4],fp][[1,1]]])

Plus@@%

Tally[%%]

AddOneVectorToSpanningSet[{},v_?VectorQ]:=If[ZeroVectorQ[v],{},{v}]

ZeroVectorQ[v_]:=Union[v]=={0}

AddOneVectorToSpanningSet[m_?MatrixQ,v_?VectorQ]:=If[MatrixRank[m~Join~{v}]==Length[m],m,m~Join~{v}]

SpanningSet[{}]:={};

SpanningSet[m_?MatrixQ]:=(Global`spanningSetArgument=m;Fold[AddOneVectorToSpanningSet,{},m])

foo2=SpanningSet/@(DeleteCases[foo,{}]/.fp_FreePath:>UnitVector[87,Position[FreePaths[4],fp][[1,1]]]);

foo2[[1]].FreePaths[4]

foo3=Map[fs,RowReduce[#],{2}].FreePaths[4]&/@foo2

RowReduce[foo2[[3]]].FreePaths[4]

N[RowReduce[foo2[[6]]].FreePaths[4]]

Chop[N[RowReduce[foo2[[13]]].FreePaths[4]]]

Chop[N[RowReduce[foo2[[-4]]].FreePaths[4]]]

N[foo2[[12]].FreePaths[4]]

foo[[14]]

MatrixRank[foo[[14]]/.fp_FreePath:>UnitVector[150,Position[FreePaths[4],fp][[1,1]]]]

N[SpanningSet[foo[[14]]/.fp_FreePath:>UnitVector[150,Position[FreePaths[4],fp][[1,1]]]].FreePaths[4]]//TableForm

SpanningSet[foo[[14]]/.fp_FreePath:>UnitVector[150,Position[FreePaths[4],fp][[1,1]]]]

rr=RowReduce[%]

rr.FreePaths[4]

Length[%]

ZeroVectorQ[v_]:=Union[v]=={0}

Length[%]

Length[subspace4]

MatrixRank[subspace4]

CutDownLoops[8]=DeleteCases[FreeLoops[8],FreeLoop[x:(0|c|f),_,_,_,x_,_,_,_,x_]|FreeLoop[0,_,_,_,2,_,_,_,0]|FreeLoop[2,_,_,_,0,_,_,_,2]|FreeLoop[c,_,_,_,a,_,_,_,c]|FreeLoop[a,_,_,_,c,_,_,_,a]|FreeLoop[f,_,_,_,d,_,_,_,f]|FreeLoop[d,_,_,_,f,_,_,_,d]];

Length[CutDownLoops[8]]

rotation[FreeLoop[a_,b_,c_,d_,e_,f_,g_,h_,a_]]:=rotation[FreeLoop[a,b,c,d,e,f,g,h,a]]=fs[(Sqrt[((dimension[a]dimension[e])/(dimension[c]dimension[g]))])]FreeLoop[c,d,e,f,g,h,a,b,c]

rotation[X_Plus]:=rotation/@X
rotation[z_ X_FreeLoop]:=z rotation[X]

Take[FreeLoops[8],5]

rotation[FreeLoop[0,1,0,1,0,1,0,1,0]]

Length[FreeLoops[8]]

rotm=Transpose[(rotation[#]/.fl_FreeLoop:>UnitVector[375,Position[FreeLoops[8],fl][[1,1]]])&/@FreeLoops[8]];

cdrotm=Transpose[(rotation[#]/.fl_FreeLoop:>UnitVector[375,Position[FreeLoops[8],fl][[1,1]]])&/@CutDownLoops[8]];

cdinclusion=Transpose[(#/.fl_FreeLoop:>UnitVector[375,Position[FreeLoops[8],fl][[1,1]]])&/@CutDownLoops[8]];

Dimensions[cdrotm]

Clear[es,cdes]
es[z_]:=es[z]=NullSpace[rotm-z IdentityMatrix[375]]
cdes[z_]:=cdes[z]=NullSpace[cdrotm-z cdinclusion]

Length[es[-1]]//AbsoluteTiming

Length[cdes[-1]]//AbsoluteTiming

es[-1][[1]].FreeLoops[8]

es[I][[3]].FreeLoops[8]

Length[es[1]]

Length[es[-I]]

Length[es[I]]

96+105+87+87

e1=arcsToLoops[8,Arc[1,2]Arc[3,6]Arc[4,5]Arc[7,8]];
e2=arcsToLoops[8,Arc[1,8]Arc[2,3]Arc[4,5]Arc[6,7]];

multiply[FreeLoop[x__],FreeLoop[y__]]:=With[{n=((Length[{y}]-1)/2)},FreeLoop@@(Take[{x},n+1]~Join~Drop[{y},n+1])Delta[Reverse[Drop[{x},n]],Take[{y},n+1]]]

multiply[X_Plus,Y_]:=multiply[#,Y]&/@X
multiply[z_ X_FreeLoop,Y_]:=z multiply[X,Y]
multiply[X_,Y_Plus]:=multiply[X,#]&/@Y
multiply[X_,z_ Y_FreeLoop]:=z multiply[X,Y]

multiply[FreeLoop[1,2,3,4,3,2,1],FreeLoop[1,2,z,4,b,c,1]]

Collect[multiply[e1,e1]-δ e1,_FreeLoop,fs]

Collect[multiply[e2,e2]-δ e2,_FreeLoop,fs]

ZeroVector[n_]:=Table[0,{n}]

Clear[me1]
me1[z_]:=me1[z]=Transpose[ZeroVector[375]+(multiply[e1,#.FreeLoops[8]]/.fl_FreeLoop:>UnitVector[375,Position[FreeLoops[8],fl][[1,1]]])&/@es[z]]

Clear[me2]
me2[z_]:=me2[z]=Transpose[ZeroVector[375]+(multiply[e2,#.FreeLoops[8]]/.fl_FreeLoop:>UnitVector[375,Position[FreeLoops[8],fl][[1,1]]])&/@es[z]]

Clear[cdme1]
cdme1[z_]:=cdme1[z]=Transpose[ZeroVector[375]+(multiply[e1,#.CutDownLoops[8]]/.fl_FreeLoop:>UnitVector[375,Position[FreeLoops[8],fl][[1,1]]])&/@cdes[z]]

Clear[cdme2]
cdme2[z_]:=cdme2[z]=Transpose[ZeroVector[375]+(multiply[e2,#.CutDownLoops[8]]/.fl_FreeLoop:>UnitVector[375,Position[FreeLoops[8],fl][[1,1]]])&/@cdes[z]]

me1[-1];//AbsoluteTiming

me2[-1]

cdme1[-1];//AbsoluteTiming

Clear[ns]
ns[z_]:=ns[z]=Map[fs,NullSpace[me1[z]~Join~me2[z]].es[z],{2}]

Clear[cdns]
cdns[z_]:=cdns[z]=Map[fs,NullSpace[cdme1[z]~Join~cdme2[z]].cdes[z],{2}]

Length[ns[-1]]//AbsoluteTiming

Length[cdns[-1]]//AbsoluteTiming

ccc=cdns[-1].CutDownLoops[8]/.fl_FreeLoop:>UnitVector[375,Position[FreeLoops[8],fl][[1,1]]];

Dimensions[ccc]

MatrixRank[ns[-1]~Join~ccc]

Length[ns[1]]

Length[ns[I]]

Length[ns[-I]]

Broken : don' t use

Clear[sans]
sans[z_]:=sans[z]=Module[{nns},nns=NullSpace[Transpose[(((#.FreeLoops[8])/.{fl_FreeLoop:>(fl-Reverse[fl])})/.fl_FreeLoop:>UnitVector[375,Position[FreeLoops[8],fl][[1,1]]])&/@ns[z]]];
If[nns=={},{},nns.ns[z]]
]

Length[sans[-1]]

Length[sans[1]]

Length[sans[I]]

Length[sans[-I]]

S=Table[α[i],{i,1,4}].ns[-1].FreeLoops[8]

vect=((multiply[S,S]-f4)/.fl_FreeLoop:>UnitVector[375,Position[FreeLoops[8],fl][[1,1]]])

Solve[Take[vect,20]==0,Table[α[i],{i,1,4}]]

Solve[Take[vect/.α[1]->-1,40]==0,Table[α[i],{i,1,4}]]

Solve[Take[vect/.{α[1]->-1,α[2]->-((-25+7 (Sqrt[13]))/(3 (-3+(Sqrt[13]))))},40]==0,Table[α[i],{i,143}]]

Solve[(fs/@Take[vect/.{α[1]->-1,α[2]->-((-25+7 (Sqrt[13]))/(3 (-3+(Sqrt[13]))))},43])==0,Table[α[i],{i,1,3}]]

FullSimplify[%]

Solve[(fs/@Take[vect/.{α[1]->-1,α[2]->-((-25+7 (Sqrt[13]))/(3 (-3+(Sqrt[13])))),α[3]->-(1/2) I (-3+(Sqrt[13]))},45])==0,Table[α[i],{i,1,4}]]

FullSimplify[%]

Solve[(fs/@Take[vect/.{α[1]->-1,α[2]->-((-25+7 (Sqrt[13]))/(3 (-3+(Sqrt[13])))),α[3]->(1/2) I (-3+(Sqrt[13]))},45])==0,Table[α[i],{i,1,4}]]

FullSimplify[%]

Solve[(fs/@Take[vect/.{α[1]->-1,α[2]->-((-25+7 (Sqrt[13]))/(3 (-3+(Sqrt[13])))),α[3]->-(1/2) I (-3+(Sqrt[13])),α[4]->(1/3) (4-(Sqrt[13]))},All])==0,Table[α[i],{i,1,4}]]

Solve[(fs/@Take[vect/.{α[1]->-1,α[2]->-((-25+7 (Sqrt[13]))/(3 (-3+(Sqrt[13])))),α[3]->(1/2) I (-3+(Sqrt[13])),α[4]->(1/3) (4-(Sqrt[13]))},All])==0,Table[α[i],{i,1,4}]]

realS=Collect[S/.{α[1]->-1,α[2]->-((-25+7 (Sqrt[13]))/(3 (-3+(Sqrt[13])))),α[3]->(1/2) I (-3+(Sqrt[13])),α[4]->(1/3) (4-(Sqrt[13]))},_FreeLoop,fs]

Collect[multiply[realS,realS]-f4,_FreeLoop,fs]

P=Collect[(1/2)(f4+realS),_FreeLoop,fs];

Q=Collect[(1/2)(f4-realS),_FreeLoop,fs];

Collect[multiply[P,P]-P,_FreeLoop,fs]

Psubspace=act[P,#]&/@FreePaths[4]

Psubspace2=Psubspace/.fp_FreePath:>UnitVector[87,Position[FreePaths[4],fp][[1,1]]]

Psubspace3=Map[fs,Psubspace2,{2}]

Psubspace4=DeleteCases[Psubspace3,0|Table[0,{87}]]

Pfoo=Flatten[Outer[DeleteCases[Union[(Psubspace4.FreePaths[4])/.fp:FreePath[x_,_,_,_,y_]:>Delta[x,#1]Delta[y,#2]fp],0]&,vertices,vertices],1]

Qsubspace=act[Q,#]&/@FreePaths[4];

Qsubspace2=Qsubspace/.fp_FreePath:>UnitVector[87,Position[FreePaths[4],fp][[1,1]]];

Qsubspace3=Map[fs,Qsubspace2,{2}];

Qsubspace4=DeleteCases[Qsubspace3,0|Table[0,{87}]];

Qfoo=Flatten[Outer[DeleteCases[Union[(Qsubspace4.FreePaths[4])/.fp:FreePath[x_,_,_,_,y_]:>Delta[x,#1]Delta[y,#2]fp],0]&,vertices,vertices],1];

MatrixRank/@(DeleteCases[Pfoo,{}]/.fp_FreePath:>UnitVector[87,Position[FreePaths[4],fp][[1,1]]])

Plus@@%

Tally[%%]

MatrixRank/@(DeleteCases[Qfoo,{}]/.fp_FreePath:>UnitVector[87,Position[FreePaths[4],fp][[1,1]]])

Pfoo2=SpanningSet/@(DeleteCases[Pfoo,{}]/.fp_FreePath:>UnitVector[87,Position[FreePaths[4],fp][[1,1]]]);

Qfoo2=SpanningSet/@(DeleteCases[Qfoo,{}]/.fp_FreePath:>UnitVector[87,Position[FreePaths[4],fp][[1,1]]]);

Pfoo3=Map[fs,RowReduce[#],{2}].FreePaths[4]&/@Pfoo2

Qfoo3=Map[fs,RowReduce[#],{2}].FreePaths[4]&/@Qfoo2

foo3[[4]]

Pfoo3[[3]]

Qfoo3[[3]]

partialTrace[FreeLoop[a_,b_,c_,d_,e_,d_,g_,h_,a_]]:=FreeLoop[a,b,c,d,g,h,a]((dimension[e])/(dimension[d]))
partialTrace[FreeLoop[a_,b_,c_,d_,c_,f_,a_]]:=FreeLoop[a,b,c,f,a]((dimension[d])/(dimension[c]))
partialTrace[FreeLoop[a_,b_,c_,b_,a_]]:=FreeLoop[a,b,a]((dimension[c])/(dimension[b]))
partialTrace[FreeLoop[a_,b_,a_]]:=FreeLoop[a]((dimension[b])/(dimension[a]))
partialTrace[_FreeLoop]:=0

partialTrace[X_Plus]:=partialTrace/@X
partialTrace[X_Times]:=partialTrace[Expand[X]]
partialTrace[z_ X_FreeLoop]:=z partialTrace[X]

leftPartialTrace[FreeLoop[a_,b_,c_,d_,e_,f_,g_,b_,a_]]:=FreeLoop[b,c,d,e,f,g,b]((dimension[a])/(dimension[b]))

leftPartialTrace[FreeLoop[a_,b_,c_,d_,e_,b_,a_]]:=FreeLoop[b,c,d,e,b]((dimension[a])/(dimension[b]))

leftPartialTrace[FreeLoop[a_,b_,c_,b_,a_]]:=FreeLoop[b,c,b]((dimension[a])/(dimension[b]))

leftPartialTrace[FreeLoop[a_,b_,a_]]:=FreeLoop[b]((dimension[a])/(dimension[b]))

leftPartialTrace[_FreeLoop]:=0

leftPartialTrace[X_Plus]:=leftPartialTrace/@X
leftPartialTrace[X_Times]:=leftPartialTrace[Expand[X]]
leftPartialTrace[z_ X_FreeLoop]:=z leftPartialTrace[X]

partialTrace[f4]

arcsToLoops[2,Arc[1,2]]

Collect[partialTrace[arcsToLoops[2,Arc[1,2]]],_FreeLoop,fs]

Collect[leftPartialTrace[arcsToLoops[2,Arc[1,2]]],_FreeLoop,fs]

Collect[leftPartialTrace[leftPartialTrace[arcsToLoops[4,Arc[1,4]Arc[2,3]]]],_FreeLoop,fs]

arcsToLoops[6,Arc[1,4]Arc[2,3]Arc[5,6]]

Collect[leftPartialTrace[leftPartialTrace[leftPartialTrace[leftPartialTrace[arcsToLoops[8,Arc[1,6]Arc[2,3]Arc[4,5]Arc[7,8]]]]]],_FreeLoop,fs]

Simplify[Z[Collect[leftPartialTrace[leftPartialTrace[leftPartialTrace[leftPartialTrace[FreeLoop[0,1,2,3,a,3,2,1,0]]]]],_FreeLoop,fs]]]

Simplify[Z[Collect[partialTrace[partialTrace[partialTrace[partialTrace[FreeLoop[0,1,2,3,a,3,2,1,0]]]]],_FreeLoop,fs]]]

trf2=Collect[partialTrace[partialTrace[f2]],_FreeLoop,fs]

trf3=Collect[partialTrace[partialTrace[partialTrace[f3]]],_FreeLoop,fs]

trf4=Collect[partialTrace[partialTrace[partialTrace[partialTrace[f4]]]],_FreeLoop,fs]

S2=Collect[multiply[S,S],_FreeLoop,Together]

S3=Collect[multiply[S2,S],_FreeLoop,Together]

S4=Collect[multiply[S3,S],_FreeLoop,Together]

Simplify[Z[trf4]]

trS2=FullSimplify[partialTrace[partialTrace[partialTrace[partialTrace[S2]]]]]

vect2=Simplify[(trS2/.fl_FreeLoop:>UnitVector[6,Position[FreeLoops[0],fl][[1,1]]])/((2 (11+3 (Sqrt[13])) ((α[1])^2))/(3+(Sqrt[13])))]

Solve[vect2=={1,1,1,1,1,1},{α[1],α[2],α[3],α[4]}]

FreeLoops[0]

trS2=FullSimplify[Z[partialTrace[partialTrace[partialTrace[partialTrace[S2]]]]]]

Solve[trS2==Z[trf4],{α[2]}]

trS3=FullSimplify[Z[partialTrace[partialTrace[partialTrace[partialTrace[S3]]]]]]

FullSimplify[trS3/.α[1]->(1/24) (-12 α[2]-67 α[3]+19 (Sqrt[13]) α[3]-(Sqrt[-1404+396 (Sqrt[13])-540 ((α[2])^2)+108 (Sqrt[13]) ((α[2])^2)+2376 α[2] α[3]-648 (Sqrt[13]) α[2] α[3]+7326 ((α[3])^2)-2034 (Sqrt[13]) ((α[3])^2)]))]

Solve[%==0,{α[1],α[2],α[3]}]

trS4=Together[Z[partialTrace[partialTrace[partialTrace[partialTrace[S4]]]]]/.{α[1]->(1/24) (-12 α[2]-67 α[3]+19 (Sqrt[13]) α[3]-(Sqrt[-1404+396 (Sqrt[13])-540 ((α[2])^2)+108 (Sqrt[13]) ((α[2])^2)+2376 α[2] α[3]-648 (Sqrt[13]) α[2] α[3]+7326 ((α[3])^2)-2034 (Sqrt[13]) ((α[3])^2)]))}/.{α[2]->(1/3) (4 α[3]-(Sqrt[13]) α[3])}]

N[%]

Simplify[Z[trf4]]

FullSimplify[(((Plus@@(dimension[#]&/@vertices)))^2)]

Simplify[Z[trS4]]

vect3=trS3/.fl_FreeLoop:>UnitVector[10,Position[FreeLoops[0],fl][[1,1]]]

Solve[vect3==0,{α[1],α[2],α[3]}]

vect2=(trS2-trf4)/.fl_FreeLoop:>UnitVector[10,Position[FreeLoops[0],fl][[1,1]]]

Solve[Take[vect2,1]==0,{α[1],α[2],α[3]}]

FullSimplify[Solve[(1/(9 (3+(Sqrt[13]))))((82-31 (Sqrt[13])) (Sqrt[3 (4+(Sqrt[13]))])+18 (119+33 (Sqrt[13])) ((α[1])^2)+12 (Sqrt[-3+(Sqrt[13])]) (((3 (4+(Sqrt[13]))))^(1/4)) (11+4 (Sqrt[13])) α[2]+9 (131+37 (Sqrt[13])) ((α[2])^2)+6 α[1] ((Sqrt[3]) (((1796482+497498 (Sqrt[13])))^(1/4))+(357+99 (Sqrt[13])) α[2]))==0,α[2]]]

FullSimplify[vect2/.{α[3]->-(1/2) (Sqrt[-3 (Sqrt[3 (4+(Sqrt[13]))])+(Sqrt[39 (4+(Sqrt[13]))])])}]

Z[FreeLoop[a_]]:=((dimension[a])^2)
Z[X_Plus]:=Z/@X
Z[z_ X_FreeLoop]:=z Z[X]

N@fs[Z[trf2]]

q2=fs[dimension[2]];
q3=fs[dimension[3]];
q4=fs[(δ^4)-3(δ^2)+1];
q5=fs[(δ^5)-4(δ^3)+3δ];

q4

N@FullSimplify[(q5/q4)]

trS2=%;

FreeLoops[0]

fs/@(trS2/.fl_FreeLoop:>UnitVector[10,Position[FreeLoops[0],fl][[1,1]]])

Solve[(Take[vect,80]/.{α[5]->1,α[3]->0,α[1]->(I/(Sqrt[3]))})==0,Table[α[i],{i,1,8}]]

fs/@(Take[vect,80]/.{α[5]->1,α[3]->0,α[1]->(I/(Sqrt[3]))})