Genus Symbol Program
version 2.0
(written for Mathematica 10.0)

by David Yuen
yuen@lakeforest.edu

Genus Symbol Programs (execute this group)

Aux programs

The following routines are here because Mathematica 9 broke previous programs written in earlier versions.

ZeroMatrix[n_,m_]:=Table[0,{n},{m}];ZeroMatrix[n_]:=Table[0,{n},{n}];BlockMatrix[x___]:=ArrayFlatten[x];SubMatrix[a_,upperLeft_,dim_]:=Module[{},
If[a==={},Return[{}]];
If[(dim[[1]]===0)||(dim[[2]]===0),
{},
a[[Range[upperLeft[[1]],upperLeft[[1]]+dim[[1]]-1],Range[upperLeft[[2]],upperLeft[[2]]+dim[[2]]-1]]]
]
];
MyFactorInteger[n_]:=If[n===1,{},FactorInteger[n]];

Clear[Valuation];
Valuation[x_,p_]:=IntegerExponent[Numerator[x],p]-IntegerExponent[Denominator[x],p];
OldValuation[x_,p_]:=Module[{nu, top,bot,n},
If[x==0,Return[Infinity]];
n=x;top=Numerator[n];
bot=Denominator[n];
nu =0;
While[Mod[top,p]==0,{top=Quotient[top,p];nu = nu+1}];
While[Mod[bot,p]==0,{bot=Quotient[bot,p];nu = nu-1}];
Return[nu]]

ElementaryMatrix1[n_,i_,j_]:=Module[{a},
a=IdentityMatrix[n];
a[[i,i]]=0;a[[j,j]]=0;
a[[i,j]]=1;a[[j,i]]=1;
a
]

ElementaryMatrix3[n_,i_,j_,alp_]:=Module[{a},
a=IdentityMatrix[n];
a[[i,j]]=alp;
a
]

MyReplaceBox[a_,b_,ii_,jj_]:=Module[{t=a,i,j},
Do[t[[ii-1+i,jj-1+j]]=b[[i,j]],
{i,1,Length[b]},{j,1,Length[b[[1]]]}];
t
];

MyDiagonalizeOddPrime[m_,p_]
MyDiagonalizeOddPrimeList[mx_,p_]

MyMinEntry[m_]:=Module[{ans,i,j,x},
ans={1,1};x=m[[1,1]];
Do[If[m[[i,i]]<x,x=m[[i,i]];ans={i,i}],{i,1,Length[m]}];
Do[If[m[[i,j]]<x,x=m[[i,j]];ans={i,j}],{i,1,Length[m]-1},{j,i+1,Length[m]}];
ans
];

MyDiagonalizeOddPrime[mx_,p_]:=Module[{m=mx,v,i,j,n=Length[mx],minv,minij,
Em, m2},
If[n==1,Return[mx]];
v=Table[Valuation[m[[i,j]],p],{i,1,n},{j,1,n}];
minij=MyMinEntry[v];
minv=v[[minij[[1]],minij[[2]]]];
(*Print[{v,minij,minv}];*)
If[minij[[1]]=!=1,
Em=ElementaryMatrix1[n,1,minij[[1]]];
m=Em.m.Em;
v=Table[Valuation[m[[i,j]],p],{i,1,n},{j,1,n}];
minij=MyMinEntry[v];
minv=v[[minij[[1]],minij[[2]]]];
(*Print[{v,minij,minv}];*)
];
If[minij[[2]]=!=1,
Em=ElementaryMatrix3[n,1,minij[[2]],1];
m=Em.m.Transpose[Em];
v=Table[Valuation[m[[i,j]],p],{i,1,n},{j,1,n}];
minij=MyMinEntry[v];
minv=v[[minij[[1]],minij[[2]]]];
(*Print[{v,minij,minv}];*)
];
(*Print[m//MatrixForm];*)
Do[
If[Valuation[m[[1,j]]/m[[1,1]],p]<0,
Print["ERROR 23525124626"];Return[Indeterminate]];
Em=ElementaryMatrix3[n,j,1,-m[[1,j]]/m[[1,1]]];
m=Em.m.Transpose[Em];
(*Print[m//MatrixForm];*)
,{j,2,n}
];
m2=SubMatrix[m,{2,2},{n-1,n-1}];
m2=MyDiagonalizeOddPrime[m2,p];
m=MyReplaceBox[m,m2,2,2];
m
];

MyDiagonalizeOddPrimeList[mx_,p_]:=Module[{m=mx,v,i,j,n=Length[mx],minv,minij,
Em, m2},
If[n==1,Return[Flatten[mx]]];
v=Table[Valuation[m[[i,j]],p],{i,1,n},{j,1,n}];
minij=MyMinEntry[v];
minv=v[[minij[[1]],minij[[2]]]];
(*Print[{v,minij,minv}];*)
If[minij[[1]]=!=1,
Em=ElementaryMatrix1[n,1,minij[[1]]];
m=Em.m.Em;
v=Table[Valuation[m[[i,j]],p],{i,1,n},{j,1,n}];
minij=MyMinEntry[v];
minv=v[[minij[[1]],minij[[2]]]];
(*Print[{v,minij,minv}];*)
];
If[minij[[2]]=!=1,
Em=ElementaryMatrix3[n,1,minij[[2]],1];
m=Em.m.Transpose[Em];
v=Table[Valuation[m[[i,j]],p],{i,1,n},{j,1,n}];
minij=MyMinEntry[v];
minv=v[[minij[[1]],minij[[2]]]];
(*Print[{v,minij,minv}];*)
];
(*Print[m//MatrixForm];*)
Do[
If[Valuation[m[[1,j]]/m[[1,1]],p]<0,
Print["ERROR 23525124626"];Return[Indeterminate]];
Em=ElementaryMatrix3[n,j,1,-m[[1,j]]/m[[1,1]]];
m=Em.m.Transpose[Em];
(*Print[m//MatrixForm];*)
,{j,2,n}
];
m2=SubMatrix[m,{2,2},{n-1,n-1}];
m2=MyDiagonalizeOddPrimeList[m2,p];
Join[{m[[1,1]]},m2]
];

GenusSymbolOdd[m_,p_]

GenusSymbolOdd[m_,p_]:=Module[
{mL,i,mV,mVU,ans,nfq,detfq,v,nd,e,q},
mL=MyDiagonalizeOddPrimeList[m,p];(*Print[mL];*)
mV=Table[Valuation[mL[[i]],p],{i,1,Length[mL]}];
mVU=Union[mV];ans={};
Do[nfq=0;detfq=1;v=mVU[[i]];q=p^v;
Do[
If[mV[[j]]==v,
nfq++;
detfq=detfq*mL[[j]]/q;
],
{j,1,Length[mV]}
];
nd=Numerator[detfq]*Denominator[detfq];(*Print[detfq];*)
If[Mod[nd,p]==0,Print["ERROR 4354514"];Return[Indeterminate]];
e=JacobiSymbol[nd,p];
AppendTo[ans,{q,e*nfq}];
,
{i,1,Length[mVU]}
];
ans
]

GenusSymbolTwo[m_]
fixed

Valuation2[x_]:=Valuation[x,2];

MyDiagonalizeTwoList[mx_]:=Module[{m=mx,v,i,j,n=Length[mx],minv,minij,
Em, m2,p=2,X,b,Y},
If[n==1,Return[{mx}]];
v=Table[Valuation[m[[i,j]],p],{i,1,n},{j,1,n}];
minij=MyMinEntry[v];
minv=v[[minij[[1]],minij[[2]]]];
(*Print[{v,minij,minv}];*)
If[minij[[1]]=!=1,
Em=ElementaryMatrix1[n,1,minij[[1]]];
m=Em.m.Em;
v=Table[Valuation[m[[i,j]],p],{i,1,n},{j,1,n}];
minij=MyMinEntry[v];
minv=v[[minij[[1]],minij[[2]]]];
(*Print[{v,minij,minv}];*)
];
If[minij[[2]]==1,
Do[
If[Valuation[m[[1,j]]/m[[1,1]],p]<0,
Print["ERROR 46726411134"];Return[Indeterminate]];
Em=ElementaryMatrix3[n,j,1,-m[[1,j]]/m[[1,1]]];
m=Em.m.Transpose[Em];
(*Print[m//MatrixForm];*)
,{j,2,n}
];
m2=SubMatrix[m,{2,2},{n-1,n-1}];
m2=MyDiagonalizeTwoList[m2];
Return[Join[{{{m[[1,1]]}}},m2]]
,
If[n==2,Return[{m}]];
If[minij[[2]]≠2,
Em=ElementaryMatrix1[n,2,minij[[2]]];
m=Em.m.Em
];
b=SubMatrix[m,{1,1},{2,2}];
X=SubMatrix[m,{3,1},{n-2,2}];
Y=-X.Inverse[b]; (*Check valences are nonnegative*)
If[Min[Valuation2/@Flatten[Y]]<0,
Print["ERROR 84581155"];Return[Indeterminate]];
Em=BlockMatrix[{{IdentityMatrix[2],Transpose[Y]},{Y,IdentityMatrix[n-2]}}];
m=Em.m.Transpose[Em];
m2=SubMatrix[m,{3,3},{n-2,n-2}];
m2=MyDiagonalizeTwoList[m2];
Return[Join[{ b },m2]]

];
Indeterminate

];

MyJacobiSymbol2[x_]:=Module[{a},
a=Mod[x,8];
Which[a==1,1,
a==3,-1,
a==5,-1,
a==7,1,
True,0]
]

GenusSymbolTwo[m_]:=Module[
{mL,i,mV,mVU,ans,nfq,detfq,v,nd,e,q,gr,newgr,oddEven,oddity,t,p=2},
mL=MyDiagonalizeTwoList[m];(*Print[mL];*)
mV=Table[Valuation[mL[[i,1,-1]],p],{i,1,Length[mL]}];
(*Use upper right hand corner for valence! *)
mVU=Union[mV];ans={};
Do[
nfq=0;detfq=1;v=mVU[[i]];q=p^v;gr={};
Do[
If[mV[[j]]==v,
nfq+=Length[mL[[j]]];
detfq=detfq*Det[mL[[j]]/q];
AppendTo[gr,mL[[j]]];
],
{j,1,Length[mV]}
];
oddEven=Union[Length/@gr];
If[oddEven=={1,2},
gr=q*MyFurtherReduce[gr/q];
oddEven={1};
];
nd=Numerator[detfq]*Denominator[detfq];(*Print[detfq];*)
If[Mod[nd,2]==0,Print["ERROR 35261134"];Return[Indeterminate]];
e=MyJacobiSymbol2[nd];
(*Print[{gr,oddEven,detfq,nd,e}];*)
If[oddEven=={1},
(*Type1*)
t=Sum[gr[[j,1,1]],{j,1,Length[gr]}];
t=t/q;
oddity=Mod[Numerator[t]*Denominator[t],8];
AppendTo[ans,{q,e*nfq,1,oddity}];

];
If[oddEven=={2},
(*Type2*)
AppendTo[ans,{q,e*nfq,2}];

];
,
{i,1,Length[mVU]}
];
ans
]

MyFurtherReduce[g_]:=Module[
{ans={},oddI,z,i,res},
Do[If[Length[g[[i]]]==1,oddI=i;Break[]],{i,1,Length[g]}];
z=g[[oddI,1,1]];
Do[
If[i≠oddI,
If[Length[g[[i]]]==1,
AppendTo[ans,g[[i]]],
res=MyTrick[z,g[[i]]];
ans=Join[ans,{{{res[[2]]}},{{res[[3]]}}}];
z=res[[1]];
]
],{i,1,Length[g]}
];
AppendTo[ans,{{z}}];
ans
];

MyTrick[z_,mx_]:=Module[
{a=mx[[1,1]],b=mx[[1,2]],c=mx[[2,2]]},
{c+z,(-b^2+a*c+a*z)/(c+z),(-(b^2*z)+a*c*z)/(-b^2+a*c+a*z)}
];

GenusSymbol[m_]
GenusSymbolCompact[m_]
FlatGenusSymbol[m_]

GenusSymbol[m_]:=Module[{li,p,i,ans},
li=FactorInteger[Det[m]][[All,1]];
li=Complement[li,{2}];
ans={{2,GenusSymbolTwo[m]}};
Do[
p=li[[i]];
AppendTo[ans,{p,GenusSymbolOdd[m,p]}];
,
{i,1,Length[li]}];
ans
];

GenusSymbolCompact[m_]:=Module[{li,part,i,j,ans={}},
li=GenusSymbol[m];
Do[
part=li[[i,2]];
Do[
If[part[[j,1]]≠1,AppendTo[ans,part[[j]]]]
,{j,1,Length[part]}
]
,
{i,1,Length[li]}];
ans
];

FlattenGenusSymbol[gs_]:=Module[{ans,n,i,j,a,b,p,li},
a=gs[[1]];
n=Apply[Plus,Abs[a[[2,All,2]]]];
ans={n,1};
li={};
For[i=1,i≤Length[gs],i++,
{p,a}=gs[[i]];b={};
For[j=1,j≤Length[a],j++,
If[a[[j,1]]≠1,
ans[[2]]*=a[[j,1]]^(Abs[a[[j,2]]]);
AppendTo[b,a[[j]]]
]
];
If[b=!={},
AppendTo[li,{p,Sort[b]}]
]
];
li=Reverse[Sort[li]];
ans=Join[ans,Flatten[li[[All,2]]]];
ans
]

FlatGenusSymbol[b_]:=FlattenGenusSymbol[GenusSymbol[b]];

GenusSymbolForPerlPreparation[m_]

UnFlatGS[li_]:=Module[{gs,j},
gs={li[[1]]};j=3;
While[j≤Length[li],
If[Mod[li[[j]],2]==0,
If[li[[j+2]]==1,
AppendTo[gs,{li[[j]],li[[j+1]],li[[j+2]],li[[j+3]]}];j+=4;,
AppendTo[gs,{li[[j]],li[[j+1]],li[[j+2]]}];j+=3;
]
,
AppendTo[gs,{li[[j]],li[[j+1]]}];j+=2;
]
];
gs
]

GenusSymbolForPerlPreparation[m_]:=UnFlatGS[FlatGenusSymbol[m]]

Examples

GenusSymbol[a] outputs a genus symbol in the form
{
  {2,  {     } },
  {p,   {   {p^v, +/-d },  { },...   } },
   {p,   {   {p^v, +/-d },  { },...   } },
    ...
}
where p are the odd divisors of Det[a] and the constituents {p^v, +/-d} consists of the content p^v and the dimension d with the appropriate +/- sign.

GenusSymbolCompact[a] omits the constituents where the content p^v is 1; thus the initial p is not needed because that can be deduced from the content p^v.  GenusSymbolCompact[a] is used for input into the LISP program that generates Fp-polynomials.

FlatGenusSymbol[a] ,
is used as input to the MonicEisenstenCoefficients Mathematica program. It has the form {n, det, list of constituents}

Example

a=(({{2, 1, 0, 0, 0, 0}, {1, 2, 1, 0, 0, 0}, {0, 1, 2, 1, 0, 0}, {0, 0, 1, 2, 0, 0}, {0, 0, 0, 0, 2, 0}, {0, 0, 0, 0, 0, 2}}));

GenusSymbol[a]

Answer should be {{2,{{1,-4,2},{2,2,1,2}}},{5,{{1,5},{5,1}}}}

GenusSymbolCompact[a]

Answer should be {{2,2,1,2},{5,1}}

FlatGenusSymbol[a]

Answer should be {6,20,5,1,2,2,1,2}

GenusSymbolForPerlPreparation[a]

Answer should be {6,{5,1},{2,2,1,2}}

Example - A6

a=(({{2, 1, 0, 0, 0, 0}, {1, 2, 1, 0, 0, 0}, {0, 1, 2, 1, 0, 0}, {0, 0, 1, 2, 1, 0}, {0, 0, 0, 1, 2, 1}, {0, 0, 0, 0, 1, 2}}));

GenusSymbol[a]

GenusSymbolCompact[a]

FlatGenusSymbol[a]

GenusSymbolForPerlPreparation[a]

Example - D6

a=(({{2, 1, 0, 0, 0, 0}, {1, 2, 1, 0, 0, 0}, {0, 1, 2, 1, 0, 0}, {0, 0, 1, 2, 1, 1}, {0, 0, 0, 1, 2, 0}, {0, 0, 0, 1, 0, 2}}));

GenusSymbol[a]

GenusSymbolCompact[a]

FlatGenusSymbol[a]

GenusSymbolForPerlPreparation[a]

Example

a=(({{2, 1, 0, 0, 0, 0}, {1, 2, 1, 0, 0, 0}, {0, 1, 2, 1, 0, 0}, {0, 0, 1, 4, 1, 1}, {0, 0, 0, 1, 4, 0}, {0, 0, 0, 1, 0, 2}}));Det[a]

GenusSymbol[a]

GenusSymbolCompact[a]

FlatGenusSymbol[a]

GenusSymbolForPerlPreparation[a]

Example

a=(({{2, 1, 0, 0, 0}, {1, 2, 1, 0, 0}, {0, 1, 2, 1, 0}, {0, 0, 1, 4, 1}, {0, 0, 0, 1, 4}}));Det[a]

GenusSymbol[a]

GenusSymbolCompact[a]

FlatGenusSymbol[a]

GenusSymbolForPerlPreparation[a]