Before all that natural language processing, there's hypergraph rewriting.

r1 = DiscretizeRegion[
   ParametricRegion[
    {
     (2 + Cos[v])*
      (2 + Cos[u])*
      Cos[v],
     (2 + Cos[v])*
      (2 + Cos[u])*
      Sin[v],
     Sin[u]
     }, {
     {u, 0, 2 Pi},
     {v, 0, 2 Pi}
     }
    ]
   ];
r2 = DiscretizeRegion[
   ParametricRegion[
    {
     (2 + 0.5*Sin[2 u])*
      Cos[u],
     (2 + 0.5*Sin[2 u])*
      Sin[u],
     (1 + 0.5*Sin[2 u] +
         v/(4 (5 - 1))) 5 - 4 (5 - 1)},
    {
     {u, 0, 2 Pi},
     {v, 0, 4 (5 - 1)}
     }
    ]
   ];
r3 = TransformedRegion[
   DiscretizeRegion[
    ParametricRegion[
     {
      2*Cos[u]*(2 + Cos[u])*Cos[v],
      2*(2 + Cos[u])*Sin[v],
      Sin[u]
      },
     {
      {u, 0, 2 Pi},
      {v, 0, 2 Pi}
      }
     ]
    ],
   ScalingTransform[{1, 1, 2.5}]
   ];
r4 = TransformedRegion[
   DiscretizeRegion[
    ParametricRegion[
     {
      (2 + 0.5 + 0.3 Sin[v]) Cos[u],
      (2 + 0.5 + 0.3 Sin[v]) Sin[u],
      2 (v - 2) - 4 + 0.5 Cos[v] + 0.5 Sin[v]
      }, {
      {u, 0, 2 Pi},
      {v, 2, 4.5}
      }
     ]
    ],
   ScalingTransform[{1, 1, 2.5}]
   ];
Graphics3D[{EdgeForm[],
  Lighting -> "Neutral",
  Specularity[White, 10],
  PlotStyle -> Directive[
    Opacity[0.8],
    ColorData[97, "ColorList"][[1]]]
  , r1},
 Boxed -> False,
 ViewPoint -> {0, 0, 5}
 ]
RegionPlot3D[
 r2,
 PlotPoints -> 100,
 MaxRecursion -> 3,
 ColorFunction -> (ColorData["BrightBands", #3] &),
 Boxed -> False,
 Axes -> False,
 Lighting -> "Neutral"
 ]
Graphics3D[{
  EdgeForm[],
  RGBColor[0.8, 0.8, 0.8],
  Lighting -> "Neutral",
  Specularity[White, 10],
  {RGBColor[1, 0.5, 0.5], r4},
  {RGBColor[0.5, 0.5, 1], r3}
  }, Boxed -> False,
 ViewPoint -> {0, 0, 5}
 ]
spaceRegion = RegionUnion[r3, r4];
evolutionLists = {};
universeCausalGraphr1 = 
 With[{p = RandomPoint[r1, 1000]}, 
  With[{g = 
     TransitiveReductionGraph[
      SimpleGraph[
       Graph[#[[1, 1]] -> #[[2]] & /@ 
         Catenate[
          With[{v = #}, 
             Thread[Framed[v] -> 
               Select[p, (v[[3]] > #[[3]]) && ((# - v)[[1]]^2 + (# - 
                    v)[[2]]^2 + (# - v)[[3]]^2) < 0.5 &]]] & /@ p], 
        VertexStyle -> 
         Directive[Hue[0.11, 1, 0.97], 
          EdgeForm[{Hue[0.11, 1, 0.97], Opacity[1]}]]]]]}, 
   Graph[g, EdgeStyle -> Hue[0, 1, 0.56]]]]
universeCausalGraphr2 = 
 With[{p = RandomPoint[r2, 1000]}, 
  With[{g = 
     TransitiveReductionGraph[
      SimpleGraph[
       Graph[#[[1, 1]] -> #[[2]] & /@ 
         Catenate[
          With[{v = #}, 
             Thread[Framed[v] -> 
               Select[p, (v[[3]] > #[[3]]) && ((# - v)[[1]]^2 + (# - 
                    v)[[2]]^2 + (# - v)[[3]]^2) < 0.5 &]]] & /@ p], 
        VertexStyle -> 
         Directive[Hue[0.11, 1, 0.97], 
          EdgeForm[{Hue[0.11, 1, 0.97], Opacity[1]}]]]]]}, 
   Graph[g, EdgeStyle -> Hue[0, 1, 0.56]]]]
universeCausalGraphr3r4 = 
 With[{p = RandomPoint[spaceRegion, 1000]}, 
  With[{g = 
     TransitiveReductionGraph[
      SimpleGraph[Graph[#[[1, 1]] -> #[[2]] & /@ Catenate[
          With[{v = #},
             Thread[Framed[v] -> Select[p, (v[[3]] > #[[3]]) && (
                    (# - v)[[1]]^2 +
                    (# - v)[[2]]^2 +
                    (# - v)[[3]]^2
                    ) < 0.5 &]
              ]] & /@ p],
        VertexStyle -> Directive[Hue[0.11, 1, 0.97],
          EdgeForm[{Hue[0.11, 1, 0.97], Opacity[1]}]
          ]]]]},
   Graph[g, EdgeStyle -> Hue[0, 1, 0.56]]]]
AppendTo[evolutionLists, {universeCausalGraph}];
maxEvolutionSteps = 5;
Do[lastCausalGraph = evolutionLists[[-1, -1]];
 newCausalGraph = With[{
    p = VertexList[lastCausalGraph] /. Framed[pt_] :> pt}, 
   With[{g = 
      TransitiveReductionGraph[
       SimpleGraph[Graph[#[[1, 1]] -> #[[2]] & /@ Catenate[
           With[{v = #},
              Thread[Framed[v] -> Select[p,
                 (v[[3]] > #[[3]]) && (
                    (# - v)[[1]]^2 +
                    (# - v)[[2]]^2 +
                    (# - v)[[3]]^2
                    ) < 0.5 &]]] & /@ p],
         VertexStyle -> Directive[
           Hue[0.11, 1, 0.97],
           EdgeForm[{
             Hue[0.11, 1, 0.97],
             Opacity[1]}]
           ]]]]},
    Graph[g, EdgeStyle -> Hue[0, 1, 0.56]]]];
 AppendTo[evolutionLists, {newCausalGraph}],
 {i, 1, maxEvolutionSteps - 1}]
visualize[evolutionLists[[4, -1]], {1, 1}]
Options[causalGraphPlot] = {VertexSize -> 0.05, 
   EdgeStyle -> Arrowheads[0.02]};
causalGraphPlot[causalGraph_, options : OptionsPattern[]] := Module[
  {edges, coords, vertices},
  edges = EdgeList[causalGraph];
  coords = PropertyValue[causalGraph, VertexCoordinates];
  vertices = PropertyValue[causalGraph, VertexList];
  Graph[vertices,
   edges,
   VertexCoordinates -> coords,
   VertexSize -> OptionValue[VertexSize],
   EdgeStyle -> OptionValue[EdgeStyle],
   ImageSize -> Medium,
   PlotRangePadding -> Scaled[0.1],
   ImagePadding -> 20,
   GraphLayout -> {"LayeredDigraphEmbedding", "Orientation" -> Top}
   ]]
causalGraphPlot[evolutionLists[[4, -1]]]
causalGraphPlot[evolutionLists[[4, -1]], VertexSize -> 0.03, 
 EdgeStyle -> {Black, Arrowheads[0.01]}]

Because we have @James Boyd who participates in everything from differential equations to quantum computing enthusiastically.

@James Boyd is also that librarian with the periodic table and yes, we see that part of the discrete model of spacetime.

We are able to make it work because the more perturbations we introduce, the more vertices from the singularity neighborhood go outside of the event horizon to null infinity.

Your hypothesis is so robust in discrete models of spacetime.

It suggests further work, we need to do an investigation of the strong censorship hypothesis.

Many thanks to @Yorick Zeschke who comes from afar making it a positive learning environment.

This decrease in the number of fake naked singularities with an increase in the number of "sprinkled points" in the Wolfram Model..space is just a large collection of discrete points connected by patterns of connections, sprinkled so we can see future null infinity, the event horizons, the singularities.

With the energy-momenta tensor, it is only natural.

Map[
 Graph3D[#,
   VertexCoordinates -> VertexList[#],
   VertexSize -> 20] &,
 {
  universeCausalGraphr1,
  universeCausalGraphr2,
  universeCausalGraphr3r4
  }
 ]

That's nice, Nikola..like playing those sounds generated with Wolfram Language. @Chase Marangu Because we came down to the sunset at 12:30am because it's the polar sunset with the 2 hour long nights, that was our Claire de Lune.

graphNum = graphAndSingularityNumbers[[i, 1]];
singularityNum = graphAndSingularityNumbers[[i, 2, 1]];
graph = evolutionLists[[graphNum]][[-1]];
futureNullInfinity = 
  findFutureNullInfinity[evolutionLists[[graphNum]]];
vertexLengths = AssociationMap[
   Length[
     VertexOutComponent[graph, #]] &,
   VertexList[graph]
   ];
highlightedGraph = HighlightGraph[graph,
   {Style[n1[[1]], Blue],
    Style[singularityNum, Red],
    Style[futureNullInfinity, Green]}];
vertexStyles = {n1[[1]] -> Blue,
   singularityNum -> Red,
   futureNullInfinity -> Green};
edgeStyles = {DirectedEdge[n1[[1]],
     singularityNum] -> Directive[Red, Thick, Arrowheads[Large]],
   DirectedEdge[n1[[1]], futureNullInfinity] -> 
    Directive[Green, Dashed, Arrowheads[Large]]};
Graph[highlightedGraph,
 VertexLabels -> Normal[vertexLengths],
 VertexSize -> {n1[[1]] -> 0.3, singularityNum -> 0.3, 
   futureNullInfinity -> 0.3},
 VertexStyle -> vertexStyles,
 EdgeStyle -> edgeStyles,
 ImageSize -> Medium,
 PlotRangePadding -> Scaled[0.1],
 ImagePadding -> 20]

Anyway it's been a fun roller coaster following the @Nikola Bukowiecka path, woo hoo!