Message Boards Message Boards

[WSS22] Investigating the weak censorship hypothesis in the Wolfram Model

2 Replies

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.

r1

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

r2

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.

r3r4

Your hypothesis is so robust in discrete models of spacetime.

Universe R1

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

Universe R2

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

Universe R3R4

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.

Universe R3R4 Labels

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.

Universe R1R2R3R4 Causal Graph

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]

Spatial Graph

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

POSTED BY: Dean Gladish

enter image description here -- you have earned Featured Contributor Badge enter image description here Your exceptional post has been selected for our editorial column Staff Picks http://wolfr.am/StaffPicks and Your Profile is now distinguished by a Featured Contributor Badge and is displayed on the Featured Contributor Board. Thank you!

POSTED BY: Moderation Team
Reply to this discussion
Community posts can be styled and formatted using the Markdown syntax.
Reply Preview
Attachments
Remove
or Discard

Group Abstract Group Abstract