All  cell’s in this notebook should be executed in succession.

Input for the algorithm is a list Comp5.MX of all non isomorphic simplicial complexes with vertexes [n]={1,2,3,4,5}.  The file Comp5.MX should be in the folder where this notebook is located and can be downloaded using the adress below

https://imi.pmf.kg.ac.rs/pub/m_timotijevic/Comp5.MX

Function ThrQ[K,n] returns False if the simplicial complex K in tne ambient [n] is not Thr and True with apropriate probabillity measure and a Thr otherwise.

Functions Maximal[K] and Dual[K] return the set of maximal simplexes of a complex K and its Alexander dual in the ambient [n].

Maximal[A_]:=Module[{B,n,G},B=Sort[A];
n=Length[B];
G={};
While[Length[B]>0,G=Union[G,{B[[n]]}];B=Complement[B,Subsets[B[[n]]]];n=Length[B]];Sort[G]]
Dual[A_,n_]:=Module[{a111,d111,V111},a111=Complement[Subsets[Table[i,{i,1,n}]],K];d111=Length[a111];V111=Table[k,{k,1,n}];
Table[Complement[V111,a111[[i]]],{i,d111,1,-1}]]

ThrQ[K_,n_]:=Module[{A,x,Vertices,Gl,d,Vec,Var,p0,poz,term,neqGl,res,com,dual,nejednakosti,t,a1},
Vertices=Table[i,{i,1,n}];
Gl=Maximal[K];
d=Length[Gl];
Vec=Table[If[MemberQ[Gl[[i]],j],1,0],{i,1,d},{j,1,n}];
Var=Table[(Subscript[x, i]),{i,1,n}];
p0=True;
poz=Table[p0=p0&&Var[[i]]>0,{i,1,n}][[n]];
term=Sum[Var[[i]],{i,1,n}]==1;
neqGl=Table[term=term&&Dot[Vec[[i]],Var]< a1,{i,1,d}][[d]];
dual=Dual[K,n];
Gl=Maximal[dual];
d=Length[Gl];
com=Table[Complement[Vertices,Gl[[i]]],{i,1,d}];
term=neqGl;
Vec=Table[If[MemberQ[com[[i]],j],1,0],{i,1,d},{j,1,n}];
nejednakosti=If[d==0,term,Table[term=term&&Dot[Vec[[i]],Var]> a1,{i,1,d}][[d]]];
res=Minimize[{a1,nejednakosti&&poz},Join[Var,{a1}]][[2]];
t=a1/.res[[n+1]];
If[NumberQ[t],
{True,{Table[(Subscript[x, i])/.res[[i]],{i,1,n}],a1/.res[[n+1]]}},{False,{}}]]

Below is a code that generates the list NonThr of all non-Thr complexes and Thr of all Thr ones. Returns the number of non Thr and the number of Thr complexes.

First one need to set the ambient set n. This algorithm works for simplicial complexes on 5 vertexes in ambients n=5 and n=6 (simply replace n=5 with n=6 in the next cell).

n=5;
SetDirectory[NotebookDirectory[]]
W=Import["Comp5.MX"];
NonThr={};
Thr={};
For[i=1,i<=Length[W],i++,
K=W[[i]];
Test=ThrQ[K,n];
If[Test[[1]]==False,NonThr=Union[NonThr,{K}],Thr=Union[Thr,{K}]]]
Length[NonThr]
Length[Thr]

Function FixMeasure[K,n] generates a probability measure and a Thr suitable for the construction of geometrical realizations of the Bier spheres of Thr complexes givven by (4.2).

The appropriate realizations are stored on the list Measures and the subsequent loop generates a list REALIZATIONS of coordinates of Bier spheres of complexes on the list Thr.

Following cell has to be executed twice.

FixMeasure[K_,n_]:=Module[{q,A,x,Vertices,Gl,d,Vec,Var,p0,poz,term,neqGl,res,com,dual,nejednakosti,t,a},
Vertices=Table[i,{i,1,n}];
Gl=Maximal[K];
d=Length[Gl];
Vec=Table[If[MemberQ[Gl[[i]],j],1,0],{i,1,d},{j,1,n}];
Var=Table[(Subscript[x, i]),{i,1,n}];
p0=True;
poz=Table[p0=p0&&Var[[i]]≥(1/(10^2)),{i,1,n}][[n]];
term=Sum[Var[[i]],{i,1,n}]==1;
neqGl=Table[term=term&&Dot[Vec[[i]],Var]<= a-(1/(10^2)),{i,1,d}][[d]];
dual=Dual[K,n];
Gl=Maximal[dual];
d=Length[Gl];
com=Table[Complement[Vertices,Gl[[i]]],{i,1,d}];
term=neqGl;
Vec=Table[If[MemberQ[com[[i]],j],1,0],{i,1,d},{j,1,n}];
nejednakosti=If[d==0,term,Table[term=term&&Dot[Vec[[i]],Var]>= a+(1/(10^2)),{i,1,d}][[d]]];
res=Maximize[{1,nejednakosti&&poz},Join[Var,{a}]][[2]];
{Table[(Subscript[x, i])/.res[[i]],{i,1,n}],
a/.res[[n+1]]}]

Measures=Table[FixMeasure[Thr[[i]],n],{i,1,Length[Thr]}];

REALIZATIONS={};
For[i=1,i≤Length[Thr],i++,
K=Thr[[i]];
Mi=Measures[[i]][[1]];
threshold=Measures[[i]][[2]];
Base=Join[Table[If[i==j,1,0],{i,1,n-1},{j,1,n-1}],{Table[-1,{i,1,n-1}]}];
VerticesK=Table[Base[[i]]/Mi[[i]],{i,1,n}];
a=((1-threshold)/threshold);
VerticesDK=-a VerticesK;
Vertices=Join[VerticesK,VerticesDK];
REALIZATIONS=Join[REALIZATIONS,{Vertices}]]

Function Bier[K,n] generates the bier sphere of a complex K in the ambient [n].
Function PolytopalQ[K,V] returns {1} or {-1} if a triangulation of a sphere described with abstract simplicial complex K and vertexes on the list V is polytopal and {-1,1} otherwise. Function PolytopalQ[K,V] needs all maximal simplexes of the sphere to be properly priented, hence the function Orient[K].

Bier[K_,n_]:=Module[{L,k1,k2,i,j,Sp},L=Dual[K,n];k1=Length[K];k2=Length[L];Sp={};For[i=1,i<k1+1,i++,For[j=1,j<k2+1,j++,If[Intersection[K[[i]],L[[j]]]=={},Sp=Union[Sp,{Union[K[[i]],n+L[[j]]]}]]]];Sp]
Orient[K_]:=Module[{L,k,d,Orijentisan,i,j,A,l,B,pr,ia,iia,c,a,IndA,IndB,Novi},
L=K;
k=Length[K];
d=Length[K[[1]]];
Orijentisan={L[[1]]};
L=Complement[L,{L[[1]]}];
For[i=1,i<k,i++,
j=1;
While[j≤ k-i,
A=L[[j]];
l=1;
While[l≤i,
B=Orijentisan[[l]];
pr=Intersection[A,B];
If[Length[pr]==d-1,Break[],l=l+1]];
If[l==i+1,j=j+1,Break[]]];
ia=Complement[A,pr][[1]];iia=Flatten[Position[A,ia]][[1]];c=0;a=Table[If[i==iia,c=1];A[[i+c]],{i,1,d-1}];
IndA=Signature[a](-1)^iia ;
ia=Complement[B,pr][[1]];iia=Flatten[Position[B,ia]][[1]];c=0;a=Table[If[i==iia,c=1];B[[i+c]],{i,1,d-1}];
IndB=Signature[a](-1)^iia;
If[IndA*IndB==-1,Novi=A,Novi=Join[{A[[2]],A[[1]]},Table[A[[i]],{i,3,d}]]];
Orijentisan=Join[Orijentisan,{Novi}];
L=Complement[L,{A}]];
Orijentisan]
PolytopalQ[K_,Vertices_]:=Module[{L,n,A,Ac,i,p,q,j,X,x,Mat,vrsta},L=Maximal[K];
n=Length[L[[1]]];L=Orient[L];Mat={};For[q=1,q≤Length[L],q++,A=Vertices[[L[[q]]]];
Ac=Complement[Vertices,A];vrsta={};
For[p=1,p<=Length[Ac],p++,X=Ac[[p]];x=Sign[Det[Join[Table[Join[A[[i]],{1}],{i,1,n}],{Join[X,{1}]}]]];vrsta=Join[vrsta,{x}];
];Mat=Join[Mat,{vrsta}]];{MatrixForm[Mat],Complement[Union[Flatten[Mat]],{0}]}]

Final loop of the algorithm generates the lists GeoRealized and gVertices of coordinates of the complexes of the list NonThr and coordinates of geometrical realizations of their Bier spheres by solving the system (4.1).

The code prints the index of a non treshhold complex and status of the attempted realization indicated by the function PolytopalQ.

GeoRealized={};
gVertices={};
P=Permutations[{1,2,3,4,5}];

ForAnalysis=NonThr;
ForComparation=Thr;
GeoVertices=REALIZATIONS;
Idexes={};

While[Length[ForAnalysis]>0&&Length[ForComparation]>0,
newRealized={};
newREALIZATIONS={};
For[Ind=1,Ind≤Length[ForAnalysis],Ind++,
K1=ForAnalysis[[Ind]];
ii=Position[NonThr,K1][[1]][[1]];
vl=Length[Union[Flatten[K1]]];
first=True;
WK={};
For[p=1,p≤Length[P],p++,
per=P[[p]];
K=Sort[Table[Sort[per[[K1[[i]]]]],{i,1,Length[K1]}]];
WK=Union[WK,{K}]];
For[p=1,p≤Length[WK],p++,
K=WK[[p]];
Appropriate=Union[Select[ForComparation,Length[Union[Complement[#,K],Complement[K,#]]]==1&]];
For[im=1,im≤Length[Appropriate],im++,
L=Appropriate[[im]];
AppropriateL=Union[Flatten[Position[ForComparation,L]]];
For[kk=1,kk≤Length[AppropriateL],kk++,
Vertices=GeoVertices[[AppropriateL[[kk]]]];
dis=Table[Norm[Vertices[[i]]],{i,1,2n}];
m=Max[dis];
BL=Bier[L,n];
BK=Bier[K,n];
Sim=Union[Flatten[Union[Complement[BK,BL],Complement[BL,BK]]]];
Middle=Sum[Vertices[[Sim[[i]]]],{i,1,Length[Sim]}]/Length[Sim];
d=N[Norm[Middle]];
d=Round[(1/d)+1];
Middle=d*Middle;
tVertices=Table[Vertices[[i]]+20m Middle,{i,1,Length[Vertices]}];
VVertices=Table[If[MemberQ[Sim,i],(Subscript[v, i])tVertices[[i]],tVertices[[i]]],{i,1,2n}];
KK=Maximal[BK];
KK=Orient[KK];
Equailties={};
For[i=1,i<=Length[KK],i++,
A=VVertices[[KK[[i]]]];
Ac=Complement[VVertices,A];
For[j=1,j≤Length[Ac],j++,
X=Ac[[j]];
x=Det[Join[Table[Join[A[[i]],{1}],{i,1,n-1}],{Join[X,{1}]}]];
Equailties=Union[Equailties,{x}]];];
Term=True;
For[i=1,i≤Length[Sim],i++,
Term=Term&&(Subscript[v, Sim[[i]]])>0];
Term1=True;
For[i=1,i≤Length[Equailties],i++,
Term1=Term1&&Equailties[[i]]≥0];
If[Term1==False,
Term1=True;
For[i=1,i≤Length[Equailties],i++,
Term1=Term1&&Equailties[[i]]<=0];];
Term=Term&&Term1;
res=NMinimize[{Sum[(Subscript[v, Sim[[i]]]),{i,1,Length[Sim]}],Term},Table[(Subscript[v, Sim[[i]]]),{i,1,Length[Sim]}]][[2]];
res=Table[(Subscript[v, Sim[[i]]])/.res[[i]],{i,1,Length[Sim]}];
If[NumberQ[res[[1]]]==True,
k=0;
NVertices=Table[If[MemberQ[Sim,i],k=k+1;res[[k]] tVertices[[i]],tVertices[[i]]],{i,1,2n}];
NVertices=Table[NVertices[[i]]-20m Middle,{i,1,2n}];
Middle=Sum[NVertices[[i]],{i,1,2n}]/(2n);
NVertices=Table[NVertices[[i]]-Middle,{i,1,2n}];
ss=PolytopalQ[BK,NVertices][[2]];
If[Length[ss]==1,
newRealized=Join[newRealized,{K}];
newREALIZATIONS=Join[newREALIZATIONS,{NVertices}];
If[first==True,first=False;
GeoRealized=Join[GeoRealized,{K}];
gVertices=Join[gVertices,{NVertices}];
Idexes=Union[Idexes,{ii}]];
Print["k=", ii, " Realization: ",ss],Print["k=", ii, " Bad sollution: ",ss]],Print["k=", ii, "   Unsuccsessful!!!"]];
]]]];
ForAnalysis=NonThr[[Complement[Table[i,{i,1,Length[NonThr]}],Idexes]]];
ForComparation=newRealized;
GeoVertices=newREALIZATIONS;]