
(*-------------------------------------------------- Routines --------------------------------------------------*)

(*Routine generating the remnant sequence for a given element Q. It returns also the positions of the element in the Q-list*)
sequenceneu[Qtemp_]:=Module[{i,positionsliste, tmpsequence},
tmpsequence = Array[0^#&,maxcdegree-mincdegree+1];
positionsliste=Position[fullQlist,Qtemp];
For[i=1,i<= Length[positionsliste],i++,
tmpsequence[[fullcdegreelist[[positionsliste[[i]][[1]]]]-mincdegree+1]]++ 
];
Return[{tmpsequence,positionsliste}];
];

(*Routine that tests wether the given complex is exact or not and returns true or false as well as a possible candidate to fix the complex*)
isexact[complex_]:=Module[{i,kern,exakt,n,fullcomplex},
fullcomplex=complex;
n=Length[fullcomplex];
exakt=1;
kern=fullcomplex[[n]];
For[i=1,i<n,i++,
kern=fullcomplex[[n-i]]-kern;
If[kern<0,
Return[{Superscript["h",n-i+1+mincdegree-1],-kern,False}];kern=0;exakt=0 
];
];
If[exakt==1,Return[{"h",0,True}]];
];

(*Routine that returns all possible cohomology groups to a given complex, taking the dimension of the variety into account*)
CohomsOf[sequence_,startdim_]:=Module[{i,j,result,tempsequence},
result={};
altersum=0;
For[i=1,i<= Length[sequence],i++,
altersum=altersum + (-1)^i*sequence[[i]];
];
altersum=Abs[altersum];
For[i=1-startdim,i<=1-startdim+(Length[equivalencerelations]-Length[equivalencerelations[[1]]]),i++,
If[sequence[[i]]>= altersum,
tempsequence=sequence;
tempsequence[[i]]=tempsequence[[i]]-altersum;
If[isexact[tempsequence][[3]],
AppendTo[result,{h,i-(1-startdim),altersum}];
];
];
];
Return[result]
];

(*Subroutine the converts a set of coordinates into their positions in the coordinate-list, e.g. {u1,u2} -> {1,2}*)
ConvertDenominatiorElement[element_]:=Module[{i,convertedelement},
convertedelement={};
For[i=1,i<= Length[element],i++,
AppendTo[convertedelement,Position[coordinates,element[[i]]][[1]][[1]] ];
];
Return[convertedelement];
];

(*Subroutine: Generates the expression u1>=0 && u2>=0 && u3>=0 && ... from a given set of coordinates {u1,u2,u3,...}*)
ListElementsLargerEqZero[list_]:=Module[{i,temp},
If[list!= {},temp=list[[1]]>= 0,Return[{}]];
For[i=2,i<=Length[list],i++,
temp=temp && list[[i]]>= 0
];
Return[temp]
];

(*Main counting routing: It generates the matrix m, the constant vector b and solves the linear equations m.x=b for non negative integers*)
RationomsOf[DenominatorElement_]:=Module[{i,j,b,m,ConvertedElement},
ConvertedElement=ConvertDenominatiorElement[DenominatorElement];
m=equrel;
For[i=1,i<=Length[equrel],i++,
For[j=1,j<=Length[equrel[[1]]],j++,
If[MemberQ[ConvertedElement,j],
m[[i]][[j]]=-equrel[[i]][[j]],
(*else*) 
m[[i]][[j]]=equrel[[i]][[j]]
];
];
];
b=Array[-Sum[m[[#]][[j]],{j,ConvertedElement}]&,Length[Qcharges]]+Qcharges;
Return[Length[Reduce[m.coordinates==b&&ListElementsLargerEqZero[coordinates],coordinates,Integers]||{"dummy"}]-1]
(*Here the equation is solved. The "dummy" has to be added and removed from the number of solutions in order to avoid that only one solution exists*)
];

(*Converts a list into a string*)
ListToString[listinput_]:=Module[{a,i},
a="";
For[i=1,i<=Length[listinput],i++,
a=StringJoin[a,ToString[listinput[[i]]] ]
];
Return[a];
];

(*------------------------------------------------ Main routines ------------------------------------------------*)
(*------------------------------------------------ Main routines ------------------------------------------------*)(*------------------------------------------------ Main routines ------------------------------------------------*)(*------------------------------------------------ Main routines ------------------------------------------------*)



(*Main routine 1: Generates first the List of all possible Q's and the corresponding c-degrees and afterwards a list of all secondary sequences that may appear*)
GenerateSecondarySequences[varietyin_]:=Module[{i,j,ii,kk},

coordinates=varietyin[[1]];
SR=varietyin[[2]];
equivalencerelations=varietyin[[3]];
dim=Length[coordinates]-Length[equivalencerelations[[1]]];

numberofvertices=Length[coordinates];
equrel=Transpose[equivalencerelations];



(*Generate the lists of Q's and c-degrees*)
Print[DateList[]," ---- Part 1: Creating Q and c-degree lists"];
d=DateList[];
fullQlist=Map[{Union[Flatten[#]],Length[Union[Flatten[#]]]-Length[#]}&,Subsets[SR]];

fullcdegreelist=Delete[fullQlist,{1}][[All,2]];
fullQlist=Delete[fullQlist,{1}] [[All,1,All]];

dneu=DateList[];
Print["Listing done within ",AbsoluteTime[dneu]-AbsoluteTime[d]," seconds"];


maxsequencesize =(Length[SR]-2)+(numberofvertices-1)+1 ;
mincdegree=2-Length[SR];
maxcdegree=numberofvertices-1;

(*Generate the list of possible secondary sequences for all various elements in the Q-list*)
Print[DateList[]," ---- Part 2: Generating remnant sequences"];
d=DateList[];
sortierttupel={};
report=19;
For[i=1,i<= 2^Length[coordinates],i++,
If[fullQlist!={},
report++;
tempQ=fullQlist[[Length[fullQlist]]];
If[!MemberQ[sortierttupel,tempQ,3], (*Tests wether the element is not yet in the list*)
tempsequence=sequenceneu[tempQ][[1]];
tmppositionslist=sequenceneu[tempQ][[2]];
If[MemberQ[sortierttupel,tempsequence,2], (*Tests wether the sequence already appeared earlier *)
AppendTo[sortierttupel[[Position[sortierttupel,tempsequence][[1]][[1]]]][[1]],tempQ]
(*else*),AppendTo[sortierttupel,{{tempQ},tempsequence}]
];
fullQlist=Delete[fullQlist,tmppositionslist];
fullcdegreelist=Delete[fullcdegreelist,tmppositionslist];

If[report==20,
NotebookDelete[temp];
dneu=DateList[];
a=ListToString[{2^Length[SR]-Length[fullQlist]-1," elements from Q-list done within ",AbsoluteTime[dneu]-AbsoluteTime[d]," seconds"}];
report=0;
temp=PrintTemporary[a];
];
];
];
];
sortierttupelsave=sortierttupel;
dneu=DateList[];
Print["Generating done within: ",AbsoluteTime[dneu]-AbsoluteTime[d]," seconds"];
];(*End of routine*)



(*Subroutine of main routine 2: Tests which secondary sequences and their corresponding cohomologies are contributing to the cohomology of the line bundle in question. It also determines via subroutines, how many rationom contribute *)

SubLinebundleCohomologyOf[Qchargesin_]:=Module[{i,j,ii,kk},

Qcharges=Qchargesin;
sortierttupel=sortierttupelsave;

For[ii=1,ii<= Length[sortierttupel],ii++, (*Sortierttupel has the following list structure {{Denominator element},{sequence}}*)
AppendTo[sortierttupel[[ii]],{}];
AppendTo[sortierttupel[[ii]],0];
If[(*1==2&&*)!isexact[sortierttupel[[ii,2]]][[3]],
For[kk=1,kk<=Length[sortierttupel[[ii]][[1]]],kk++,
temprationomsOf=RationomsOf[sortierttupel[[ii]][[1]][[kk]]];
AppendTo[sortierttupel[[ii]][[3]],temprationomsOf];
sortierttupel[[ii]][[4]]=sortierttupel[[ii]][[4]]+temprationomsOf;
];
];
];

];(*End of routine*)

(*Main routine 2: Opens the subroutine above and puts the results together *)

LinebundleCohomologyOf[Qchargesin_]:=Module[{i,j,ii,kk,Resultlistofcohoms,Resultlistofcohomsdual,PossibleResults,PossibleResultsDual,resultvectors,resultvectorsFromDual,output},

Qchargesstring="";
For[i=1,i<= Length[Qchargesin],i++,
If[i!= 1,
Qchargesstring=StringJoin[Qchargesstring, ","]
];
Qchargesstring=StringJoin[Qchargesstring,ToString[Qchargesin[[i]]]]
];

CanonicalDivisor=-Sum[equivalencerelations[[i]],{i,1,Length[equivalencerelations]}];

(*Calculate Cohomologies of the divisor*)
tmp=PrintTemporary["."];
SubLinebundleCohomologyOf[Qchargesin];

(*-------------------------------------- Collecting the Results ------------------------------------------------*)
Resultlistofcohoms={};
(*--------------------- The case of the empty set in the denominator is treated separately ---------------------*)
leer={};
If[RationomsOf[leer]!=0,
AppendTo[Resultlistofcohoms,{{h,0,RationomsOf[leer]}}];
];
(*-------------------------------------------- Case denominator != {} -------------------------------------------*)
For[i=1,i<= Length[sortierttupel],i++,e
If[sortierttupel[[i]][[4]]!=0 && !isexact[sortierttupel[[i]][[2]]][[3]],
cohomresult=Map[{h,#[[2]] , #[[3]]*sortierttupel[[i]][[4]]}&,CohomsOf[sortierttupel[[i]][[2]],mincdegree]];
AppendTo[Resultlistofcohoms,cohomresult]
];
];

output=1;
serredual=0;
unique=1;
resultvector=Array[0*#&,dim+1];

(*Check results for uniqueness and print them in case that they unique*)
For[i=1,i<= Length[Resultlistofcohoms],i++,
If[Length[Resultlistofcohoms[[i]]]!= 1,unique=0]
];
If[unique==1,
For[i=1,i<= Length[Resultlistofcohoms],i++,
resultvector[[Resultlistofcohoms[[i,1,2]]+1]]=resultvector[[Resultlistofcohoms[[i,1,2]]+1]]+Resultlistofcohoms[[i,1,3]]
];
Print[Superscript["h","*"],"(O(",Qchargesstring,"))  =  ",resultvector]; output=0, serredual=1
(*more fancy output for the graphical interface of mathematica*)
(*Print[Superscript["h","\[FilledSmallCircle]"],"(\[ScriptCapitalO](",Qchargesstring,"))  =  ",resultvector]; output=0, serredual=1*)
];



unique=1;
(*Calculate Cohomologies of the Serre dual divisor*)
If[serredual ==1,
NotebookDelete[tmp];
tmp=PrintTemporary[".."];
SubLinebundleCohomologyOf[CanonicalDivisor-Qchargesin];
(*-------------------------------------------- Printing the Results --------------------------------------------*)
Resultlistofcohomsdual={};
(*------------------- The case of the empty set in the denominator is treated separately -----------------------*)
leer={};
If[RationomsOf[leer]!=0,
AppendTo[Resultlistofcohomsdual,{{h,0,RationomsOf[leer]}}];
];
(*-------------------------------------------- Case denominator != {} -------------------------------------------*)
For[i=1,i<= Length[sortierttupel],i++,
If[sortierttupel[[i]][[4]]!=0 && !isexact[sortierttupel[[i]][[2]]][[3]],
cohomresult=Map[{h,#[[2]] , #[[3]]*sortierttupel[[i]][[4]]}&,CohomsOf[sortierttupel[[i]][[2]],mincdegree]];
AppendTo[Resultlistofcohomsdual,cohomresult];
];
];


(*Check the Serre dual divisor for uniqueness. If it is, print the corresponding data for the divisor in question by using Serre duality*)
For[i=1,i<= Length[Resultlistofcohomsdual],i++,
If[Length[Resultlistofcohomsdual[[i]]]!= 1,unique=0]
];

If[unique==1,
For[i=1,i<= Length[Resultlistofcohomsdual],i++,
resultvector[[dim- Resultlistofcohomsdual[[i,1,2]]+1]]=resultvector[[dim-Resultlistofcohomsdual[[i,1,2]]+1]]+Resultlistofcohomsdual[[i,1,3]]
];
Print[Superscript["h","*"],"(O(",Qchargesstring,"))  =  ",resultvector]; output=0
(*more fancy output for the graphical interface of mathematica*)
(*Print[Superscript["h","\[FilledSmallCircle]"],"(\[ScriptCapitalO](",Qchargesstring,"))  =  ",resultvector]; output=0*)
];
];

(*If also the Serre dual is not trivially unique we need to consider all possible combinations and cancel them out*)
(*First generate a list of all possible resulting vectors h^*(O (D)) *)
resultvectors={};
resultvectorsFromDual={};

If[unique==0,
NotebookDelete[tmp];
tmp=PrintTemporary["..."];
PossibleResults=Tuples[Resultlistofcohoms];
PossibleResultsDual=Tuples[Resultlistofcohomsdual];
For[j=1,j<= Length[PossibleResults],j++,
tmpesultvector=Array[0*#&,dim+1];
For[i=1,i<= Length[PossibleResults[[j]]],i++,
tmpesultvector[[ PossibleResults[[j]][[i,2]]+1]]=tmpesultvector[[PossibleResults[[j]][[i,2]]+1]]+PossibleResults[[j]][[i,3]]
];
AppendTo[resultvectors,tmpesultvector];
];


For[j=1,j<= Length[PossibleResultsDual],j++,
tmpesultvector=Array[0*#&,dim+1];
For[i=1,i<= Length[PossibleResultsDual[[j]]],i++,
tmpesultvector[[dim- PossibleResultsDual[[j]][[i,2]]+1]]=tmpesultvector[[dim-PossibleResultsDual[[j]][[i,2]]+1]]+PossibleResultsDual[[j]][[i,3]]
];
AppendTo[resultvectorsFromDual,tmpesultvector];
];
If[Length[Intersection[resultvectors,resultvectorsFromDual]]== 1,
Print[Superscript["h","*"],"(O(",Qchargesstring,"))  =  ",Flatten[Intersection[resultvectors,resultvectorsFromDual]]]; output=0
(*more fancy output for the graphical interface of mathematica*)
(*Print[Superscript["h","\[FilledSmallCircle]"],"(\[ScriptCapitalO](",Qchargesstring,"))  =  ",Flatten[Intersection[resultvectors,resultvectorsFromDual]]]; output=0*)
];
];

If[output==1,
(*------------ Uniqueness could not be achieved: Printing the remaining poossible  results ----------------------*)
Print[Space];
Print["The algorithm does not return a unique solution. Possible solutions are:"];
Print[ Superscript["h","*"],"(O(",Qchargesstring,")) = ", Intersection[resultvectors,resultvectorsFromDual]];
(*more fancy output for the graphical interface of mathematica*)
(*Print[ Superscript["h","\[FilledSmallCircle]"],"(\[ScriptCapitalO](",Qchargesstring,")) = ", Intersection[resultvectors,resultvectorsFromDual]];*)
];
NotebookDelete[tmp];
];(*End of routine*)

(*------------------------------------------------ END OF PROGRAM --------------------------------------------------*)










(*--------------------------------------------------- USER INPUT ---------------------------------------------------*)
(*--------------------------------------------------- USER INPUT ---------------------------------------------------*)(*--------------------------------------------------- USER INPUT ---------------------------------------------------*)(*--------------------------------------------------- USER INPUT ---------------------------------------------------*)


(*----------------------------------------------- Variety defining data ---------------------------------------------*)
P1xP1={
(*Coordinates*){u1,u2,u3,u4},
(*Stanley Reisner*){{u1,u2},{u3,u4}},
(*Equivalence Relations*){{1,0},{1,0},{0,1},{0,1}}
};
dP1={
(*Coordinates*){u1,u2,u3,u4},
(*Stanley Reisner*){{u1,u2},{u3,u4}},
(*Equivalence Relations*){{1,0},{1,0},{1,1},{0,1}}
};
dP2={
(*Coordinates*){u1,u2,u3,u4,u5},
(*Stanley Reisner*){{u1,u2},{u1,u3},{u2,u5},{u3,u4},{u4,u5}},
(*Equivalence Relations*){{1,0,0},{1,0,1},{1,1,0},{0,1,0},{0,0,1}}
};
dP3={
(*Coordinates*){u1,u2,u3,u4,u5,u6},
(*Stanley Reisner*){{u1,u2},{u1,u3},{u1,u6},{u2,u3},{u2,u5},{u3,u4},{u4,u5},{u4,u6},{u5,u6}},
(*Equivalence Relations*){{1,0,0,1},{1,0,1,0},{1,1,0,0},{0,1,0,0},{0,0,1,0},{0,0,0,1}}
};
(*-------------------------------------------------- End definitions ------------------------------------------------*)

(*------------------------------------------------ Start calculations -----------------------------------------------*)

(*----------------------------------------- !!! Start this routine first !!! ----------------------------------------*)
(*----------The routine 'GenerateSecondarySequences' needs to be started for each new variety once -----------------*)

(*---------------------------------*)
  GenerateSecondarySequences[dP3];
(*---------------------------------*)


(*------- Now one can compute the cohomology group dimensions of line bundles on the variety generated above -------*)
(*---- The input of LinbundleCohomologyOf are the charges {Q_ 1,...,Q_r} of the line bundle one is interested in ----*)

(* A dP3 example*)
LinebundleCohomologyOf[{1,120,3,-33}];

(*
(* Some more dP3 examples *)
LinebundleCohomologyOf[{0,0,0,0}];
LinebundleCohomologyOf[{1,2,3,4}];
LinebundleCohomologyOf[{-9,3,6,-7}];
LinebundleCohomologyOf[{-5,-5,-5,-5}];
LinebundleCohomologyOf[{2,3,3,3}];
*)



(*---------------------------------------------- Output results ---------------------------------------------------*)
(*---------------------------------------------- Output results ---------------------------------------------------*)(*---------------------------------------------- Output results ---------------------------------------------------*)(*---------------------------------------------- Output results ---------------------------------------------------*)

