Cech and Vietoris-Rips simplicial complexes

This Mathematica demonstration computes and displays Cech and Vietoris-Rips simplicial complexes.

To run this code, you need to click “Enable Dynamics” or select the menu option ”Evaluation -> Dynamic Updating Enabled”. Click and drag on the “filtration parameter” toggle to change the ball size. You can drag a vertex to a different spot in the plane using your mouse. Hold command and click on an empty spot to add a new vertex; hold command and click on a vertex to remove that vertex.

DrawBalls[boolBalls_,vertices_,r_]:=
If[boolBalls,Table[{Hue[0.55,1,.95,.6],Disk[vertices[[i]],r/2]},{i,Length[vertices]}],{Hue[0],Point[vertices[[1]]]}]

DrawOneSimplices[vertices_,edgeMatrix_,r_]:=
Union[Flatten[Table[ If[i<j && edgeMatrix[[i,j]]≤ r,{AbsoluteThickness[1.8],Line[{vertices[[i]],vertices[[j]]}]},Disk[vertices[[i]],0.03]],{i,Length[vertices]},{j,i,Length[vertices]}]]]

DrawTwoSimplices[boolCech_,vertices_,edgeMatrix_,r_]:=
If[boolCech,
Union[Flatten[Table[ If[edgeMatrix[[i,j]] ≤ r && edgeMatrix[[i,k]] ≤ r && edgeMatrix[[j,k]] ≤ r && TripleIntersection[vertices[[i]],vertices[[j]],vertices[[k]], r/2],{Hue[1,.9,.6,.6],EdgeForm[Black],Polygon[{vertices[[i]],vertices[[j]],vertices[[k]]}]},Disk[vertices[[i]],0.03]],{i,Length[vertices]},{j,i+1,Length[vertices]}, {k,j+1,Length[vertices]}],2]],Union[Flatten[Table[ If[edgeMatrix[[i,j]] ≤ r&& edgeMatrix[[i,k]] ≤ r && edgeMatrix[[j,k]] ≤ r,{Hue[1,.9,.6,.6],EdgeForm[Black],Polygon[{vertices[[i]],vertices[[j]],vertices[[k]]}]},Disk[vertices[[i]],0.03]],{i,Length[vertices]},{j,i+1,Length[vertices]}, {k,j+1,Length[vertices]}],2]]]

(* Returns true if all three balls about the three points with radius r intersect. This is equivalent to all three points being contained in some ball of radius r. *)
TripleIntersection[pt1_, pt2_, pt3_, r_]:=
EuclideanDistance[(pt1 + pt2)/2, pt3]≤ r ||EuclideanDistance[(pt1 + pt3)/2, pt2]≤ r  || EuclideanDistance[(pt2 + pt3)/2, pt1]≤ r  || circumradius[pt1, pt2, pt3] ≤ r

(* Returns the radius of the unique ball passing through all three points. *)
circumradius[pt1_,pt2_,pt3_]:=
Sqrt[Det[{{Norm[pt1]^2,Last[pt1],1},{Norm[pt2]^2,Last[pt2],1},{Norm[pt3]^2,Last[pt3],1}}]^2
 +Det[{{Norm[pt1]^2,First[pt1],1},{Norm[pt2]^2,First[pt2],1},{Norm[pt3]^2,First[pt3],1}}]^2
 -4*Det[{{First[pt1],Last[pt1],1},{First[pt2],Last[pt2],1},{First[pt3],Last[pt3],1}}]*-Det[{{Norm[pt1]^2,First[pt1],Last[pt1]},{Norm[pt2]^2,First[pt2],Last[pt2]},{Norm[pt3]^2,First[pt3],Last[pt3]}}]
]/(2*Abs[Det[{{First[pt1],Last[pt1],1},{First[pt2],Last[pt2],1},{First[pt3],Last[pt3],1}}]]);

Demo[verticesInitial_,maxFiltration_]:=
Manipulate[
Module[{n,edgeMatrix},
n=Length[vertices];
edgeMatrix=Table[EuclideanDistance[vertices[[i]],vertices[[j]]],{i,Length[vertices]},{j, Length[vertices]}];
Graphics[{
DrawBalls[boolBalls,vertices,r],
DrawTwoSimplices[boolCech,vertices,edgeMatrix, r],
DrawOneSimplices[vertices,edgeMatrix, r]},
PlotRange->{{-1.3,1.3},{-.8,.9}},PlotRangeClipping->False, ImageSize->800]],
{{vertices,verticesInitial},{-1.1,-1.6},{1.1,1.6},Locator, LocatorAutoCreate->True,Appearance->None},
Delimiter,Style["Cech and Vietors-Rips simplicial complexes",12,Bold],
{{boolBalls,True,"Draw balls"},{True,False}},
{{boolCech,True,"Select/deselect for Cech/Vietoris-Rips"},{True,False}},
{{r,0.28,"Filtration parameter"},0,maxFiltration,Appearance->"Labeled"}]

verticesInitial = {{-0.738,0.025},{-0.397,-0.115},{-0.62,-0.1},{0.026,-0.165},{0.328,0.04},{0.3,0.55},{0.402,0.35},{-0.16,0.595},{0.01,0.795},{0.122,0.7},{-0.524,0.67},{-0.368,0.55},{-0.568,0.48},{-0.745,0.3},{-0.826,0.545},{-0.8,-0.14},{-0.212,-0.265},{-0.612,-0.33},{0.358,-0.115},{0.514,0.195},{-0.433,-0.515}};

Demo[verticesInitial,0.82]