WormholeParadoxSimulation.nb

(* Content-type: application/vnd.wolfram.mathematica *)

(*** Wolfram Notebook File ***)
(* http://www.wolfram.com/nb *)

(* CreatedBy='Mathematica 13.1' *)

(*CacheID: 234*)
(* Internal cache information:
NotebookFileLineBreakTest
NotebookFileLineBreakTest
NotebookDataPosition[       158,          7]
NotebookDataLength[     56813,       1376]
NotebookOptionsPosition[     54244,       1331]
NotebookOutlinePosition[     54675,       1348]
CellTagsIndexPosition[     54632,       1345]
WindowFrame->Normal*)

(* Beginning of Notebook Content *)
Notebook[{

Cell[CellGroupData[{
Cell["Wormhole Time Machines and Multiple Histories", "Title",
 TextAlignment->Center,ExpressionUUID->"128c8a38-260f-4a0b-bee1-61dd7f591347"],

Cell[CellGroupData[{

Cell["Barak Shoshany", "Chapter",
 TextAlignment->Center,
 FontSize->24,ExpressionUUID->"b5fedb32-5b86-4e0f-89fe-39dfc90f809e"],

Cell[TextData[ButtonBox["bshoshany@brocku.ca",
 BaseStyle->"Hyperlink",
 ButtonData->{
   URL["mailto:bshoshany@brocku.ca"], None},
 ButtonNote->"mailto:bshoshany@brocku.ca"]], "Text",
 TextAlignment->Center,ExpressionUUID->"1eedf2d6-82ab-4a78-b665-ece06c2d6eb5"],

Cell["https://baraksh.com/", "Text",
 TextAlignment->Center,ExpressionUUID->"0f3fefd7-1097-4235-b05f-66649dbe2102"],

Cell["https://orcid.org/0000-0003-2222-127X", "Text",
 TextAlignment->Center,ExpressionUUID->"ee2eb3ff-67cb-4a5e-997e-4c3308a3e731"],

Cell["https://github.com/bshoshany", "Text",
 TextAlignment->Center,ExpressionUUID->"983c837d-ef43-44b9-9655-a75bd8a9fa08"]
}, Open  ]],

Cell[CellGroupData[{

Cell["Jared Wogan", "Chapter",
 TextAlignment->Center,
 FontSize->24,ExpressionUUID->"2fbcbe8b-25e2-4792-865e-42e11a0fee5b"],

Cell[TextData[ButtonBox["jared.wogan@gmail.com",
 BaseStyle->"Hyperlink",
 ButtonData->{
   URL["mailto:jared.wogan@gmail.com"], None},
 ButtonNote->"mailto:jared.wogan@gmail.com"]], "Text",
 TextAlignment->Center,ExpressionUUID->"97abd20c-4a3c-4e3a-be9f-16fabdf6f02d"],

Cell["https://jaredwogan.ca/", "Text",
 TextAlignment->Center,ExpressionUUID->"f0f80c1b-b452-4de7-8181-92a290cdf885"],

Cell["https://orcid.org/0000-0002-0737-5492", "Text",
 TextAlignment->Center,ExpressionUUID->"153119a9-d132-4123-8f69-85801a69dc0d"],

Cell["https://github.com/JaredWogan", "Text",
 TextAlignment->Center,ExpressionUUID->"e9305b93-be80-4b6c-a1df-1c431e3a03db"],

Cell[TextData[StyleBox["Department of Physics, Brock University, 1812 Sir \
Isaac Brock Way, St. Catharines, Ontario, L2S 3A1, Canada",
 FontSize->14]], "Text",
 TextAlignment->Center,ExpressionUUID->"b03cb2e9-03d8-487e-83e0-7e23f62de090"],

Cell[TextData[{
 StyleBox["For more information, please see our paper ",
  FontSize->18],
 StyleBox[ButtonBox["\"Wormhole Time Machines and Multiple Histories\"",
  BaseStyle->"Hyperlink",
  ButtonData->{
    URL["https://arxiv.org/abs/2110.02448"], None},
  ButtonNote->"https://arxiv.org/abs/2110.02448"],
  FontSize->18],
 StyleBox[".",
  FontSize->18]
}], "Text",
 TextAlignment->Center,ExpressionUUID->"5c7de40a-f19e-4389-8010-06181f49f26e"],

Cell[CellGroupData[{

Cell[BoxData[
 RowBox[{"DynamicModule", "[", 
  RowBox[{
   RowBox[{"{", 
    RowBox[{"padNumber", ",", "padDegrees", ",", 
     RowBox[{"tmax", "=", "2.5"}], ",", 
     RowBox[{"tmin", "=", 
      RowBox[{"-", "1.5"}]}], ",", 
     RowBox[{"xmax", "=", "2"}], ",", 
     RowBox[{"xmin", "=", 
      RowBox[{"-", "2"}]}], ",", 
     RowBox[{"ymax", "=", "0.25"}], ",", 
     RowBox[{"ymin", "=", 
      RowBox[{"-", "0.25"}]}], ",", 
     RowBox[{"initialTemperature", "=", "750"}], ",", "collisionTemperature", 
     ",", "minimumTemperature", ",", 
     RowBox[{"b", "=", "0.45"}], ",", 
     RowBox[{"l", "=", "1.2"}], ",", 
     RowBox[{"v", "=", "0.6"}], ",", 
     RowBox[{"a", "=", 
      RowBox[{"-", "0.5"}]}], ",", "\[Phi]", ",", 
     RowBox[{"tl", "=", "0.5"}], ",", 
     RowBox[{"t0", "=", "1"}], ",", 
     RowBox[{"history", "=", "1"}], ",", "particleTemperature", ",", 
     "colourFunction1", ",", "colourFunction2", ",", "colourFunction3", ",", 
     RowBox[{"persistentWormhole", "=", "True"}], ",", 
     RowBox[{"multipleHistories", "=", "False"}], ",", "bump1", ",", "bump2", 
     ",", "wormhole", ",", "radial1", ",", "radial2", ",", "geodesicPlot", 
     ",", "singleHistory", ",", "multipleHistory", ",", "graphics"}], "}"}], 
   ",", 
   RowBox[{
    RowBox[{
     RowBox[{"padNumber", "[", "n_", "]"}], ":=", 
     RowBox[{"PaddedForm", "[", 
      RowBox[{
       RowBox[{"N", "[", "n", "]"}], ",", 
       RowBox[{"{", 
        RowBox[{"3", ",", "2"}], "}"}], ",", 
       RowBox[{"NumberPadding", "\[Rule]", 
        RowBox[{"{", 
         RowBox[{"\"\<\>\"", ",", "\"\<0\>\""}], "}"}]}], ",", 
       RowBox[{"NumberSigns", "\[Rule]", 
        RowBox[{"{", 
         RowBox[{"\"\<-\>\"", ",", "\"\<+\>\""}], "}"}]}]}], "]"}]}], ";", 
    RowBox[{
     RowBox[{"padDegrees", "[", "n_", "]"}], ":=", 
     RowBox[{"PaddedForm", "[", 
      RowBox[{
       RowBox[{"IntegerPart", "[", 
        RowBox[{"N", "[", "n", "]"}], "]"}], ",", 
       RowBox[{"{", 
        RowBox[{"3", ",", "0"}], "}"}], ",", 
       RowBox[{"NumberPadding", "\[Rule]", 
        RowBox[{"{", 
         RowBox[{"\"\< \>\"", ",", "\"\<0\>\""}], "}"}]}], ",", 
       RowBox[{"NumberSigns", "\[Rule]", 
        RowBox[{"{", 
         RowBox[{"\"\<-\>\"", ",", "\"\<+\>\""}], "}"}]}]}], "]"}]}], ";", 
    RowBox[{"\[Phi]", "=", 
     RowBox[{"Dynamic", "[", 
      RowBox[{"a", " ", "\[Pi]"}], "]"}]}], ";", 
    RowBox[{
     RowBox[{"particleTemperature", "[", 
      RowBox[{"initialT_", ",", "t_"}], "]"}], ":=", 
     RowBox[{"N", "[", 
      SuperscriptBox[
       RowBox[{"(", 
        RowBox[{
         FractionBox["t", 
          RowBox[{"3", " ", 
           SuperscriptBox["10", "8"]}]], "+", 
         FractionBox["1", 
          SuperscriptBox["initialT", "0.5"]]}], ")"}], 
       RowBox[{"-", 
        FractionBox["1", "0.5"]}]], "]"}]}], ";", 
    RowBox[{"collisionTemperature", "=", 
     RowBox[{"Dynamic", "[", 
      RowBox[{"Mean", "[", 
       RowBox[{"{", 
        RowBox[{
         RowBox[{"particleTemperature", "[", 
          RowBox[{"initialTemperature", ",", 
           RowBox[{
            FractionBox[
             RowBox[{"l", "-", "v"}], "v"], "-", "tmin"}]}], "]"}], ",", 
         RowBox[{"particleTemperature", "[", 
          RowBox[{"initialTemperature", ",", 
           RowBox[{
            FractionBox["l", "v"], "+", 
            FractionBox[
             RowBox[{"l", "-", "v"}], "v"], "-", "tmin"}]}], "]"}]}], "}"}], 
       "]"}], "]"}]}], ";", 
    RowBox[{"minimumTemperature", "=", 
     RowBox[{"Dynamic", "[", 
      RowBox[{"particleTemperature", "[", 
       RowBox[{
        RowBox[{
        "collisionTemperature", "\[LeftDoubleBracket]", "1", 
         "\[RightDoubleBracket]"}], ",", 
        RowBox[{"tmax", "-", 
         FractionBox[
          RowBox[{"l", "-", "v"}], "v"], "-", "tmin"}]}], "]"}], "]"}]}], ";", 
    RowBox[{
     RowBox[{"colourFunction1", "[", "t_", "]"}], ":=", 
     RowBox[{"Blend", "[", 
      RowBox[{
       RowBox[{"{", 
        RowBox[{"Blue", ",", "Yellow", ",", "Orange", ",", "Red"}], "}"}], 
       ",", 
       RowBox[{"Rescale", "[", 
        RowBox[{
         RowBox[{"particleTemperature", "[", 
          RowBox[{"initialTemperature", ",", 
           RowBox[{"t", "-", "tmin"}]}], "]"}], ",", 
         RowBox[{"{", 
          RowBox[{
           RowBox[{
           "minimumTemperature", "\[LeftDoubleBracket]", "1", 
            "\[RightDoubleBracket]"}], ",", "initialTemperature"}], "}"}]}], 
        "]"}]}], "]"}]}], ";", 
    RowBox[{
     RowBox[{"colourFunction2", "[", "t_", "]"}], ":=", 
     RowBox[{"Blend", "[", 
      RowBox[{
       RowBox[{"{", 
        RowBox[{"Blue", ",", "Yellow", ",", "Orange", ",", "Red"}], "}"}], 
       ",", 
       RowBox[{"Rescale", "[", 
        RowBox[{
         RowBox[{"particleTemperature", "[", 
          RowBox[{
           RowBox[{
           "collisionTemperature", "\[LeftDoubleBracket]", "1", 
            "\[RightDoubleBracket]"}], ",", 
           RowBox[{"t", "-", 
            FractionBox[
             RowBox[{"l", "-", "v"}], "v"], "-", "tmin"}]}], "]"}], ",", 
         RowBox[{"{", 
          RowBox[{
           RowBox[{
           "minimumTemperature", "\[LeftDoubleBracket]", "1", 
            "\[RightDoubleBracket]"}], ",", "initialTemperature"}], "}"}]}], 
        "]"}]}], "]"}]}], ";", 
    RowBox[{
     RowBox[{"colourFunction3", "[", "t_", "]"}], ":=", 
     RowBox[{"Blend", "[", 
      RowBox[{
       RowBox[{"{", 
        RowBox[{"Blue", ",", "Yellow", ",", "Orange", ",", "Red"}], "}"}], 
       ",", 
       RowBox[{"Rescale", "[", 
        RowBox[{
         RowBox[{"particleTemperature", "[", 
          RowBox[{"initialTemperature", ",", 
           RowBox[{"t", "-", "tmin", "+", 
            FractionBox["l", "v"]}]}], "]"}], ",", 
         RowBox[{"{", 
          RowBox[{
           RowBox[{
           "minimumTemperature", "\[LeftDoubleBracket]", "1", 
            "\[RightDoubleBracket]"}], ",", "initialTemperature"}], "}"}]}], 
        "]"}]}], "]"}]}], ";", 
    RowBox[{
     RowBox[{"bump1", "[", "t_", "]"}], ":=", 
     RowBox[{"Piecewise", "[", 
      RowBox[{"{", 
       RowBox[{
        RowBox[{"{", 
         RowBox[{"0.0001", ",", 
          RowBox[{
           RowBox[{"Abs", "[", 
            RowBox[{
             SuperscriptBox["tl", "2"], "-", 
             SuperscriptBox[
              RowBox[{"(", 
               RowBox[{"t", "-", "t0"}], ")"}], "2"]}], "]"}], "<", 
           "0.01"}]}], "}"}], ",", 
        RowBox[{"{", 
         RowBox[{
          RowBox[{"b", " ", 
           RowBox[{"Exp", "[", 
            RowBox[{
             FractionBox["1", 
              SuperscriptBox["tl", "2"]], "-", 
             FractionBox["1", 
              RowBox[{
               SuperscriptBox["tl", "2"], "-", 
               SuperscriptBox[
                RowBox[{"(", 
                 RowBox[{"t", "-", "t0"}], ")"}], "2"]}]]}], "]"}]}], ",", 
          RowBox[{
           RowBox[{
            RowBox[{"t0", "-", "tl"}], "<", "t"}], "&&", 
           RowBox[{"t", "<", 
            RowBox[{"t0", "+", "tl"}]}]}]}], "}"}], ",", 
        RowBox[{"{", 
         RowBox[{"0.0001", ",", "True"}], "}"}]}], "}"}], "]"}]}], ";", 
    RowBox[{
     RowBox[{"bump2", "[", "t_", "]"}], ":=", 
     RowBox[{"bump1", "[", 
      RowBox[{"t", "+", "2"}], "]"}]}], ";", 
    RowBox[{
     RowBox[{"radial1", "[", "t_", "]"}], ":=", 
     RowBox[{"Dynamic", "[", 
      RowBox[{"If", "[", 
       RowBox[{"persistentWormhole", ",", 
        SqrtBox[
         RowBox[{
          SuperscriptBox["b", "2"], "+", 
          SuperscriptBox[
           RowBox[{"(", 
            RowBox[{"l", "-", 
             RowBox[{"v", " ", "t"}]}], ")"}], "2"]}]], ",", 
        SqrtBox[
         RowBox[{
          SuperscriptBox[
           RowBox[{"(", 
            RowBox[{
             RowBox[{"bump1", "[", "t", "]"}], "+", 
             RowBox[{"bump2", "[", "t", "]"}]}], ")"}], "2"], "+", 
          SuperscriptBox[
           RowBox[{"(", 
            RowBox[{"l", "-", 
             RowBox[{"v", " ", "t"}]}], ")"}], "2"]}]]}], "]"}], "]"}]}], ";", 
    RowBox[{
     RowBox[{"radial2", "[", "t_", "]"}], ":=", 
     RowBox[{"Dynamic", "[", 
      RowBox[{"If", "[", 
       RowBox[{"persistentWormhole", ",", 
        SqrtBox[
         RowBox[{
          SuperscriptBox["b", "2"], "+", 
          SuperscriptBox[
           RowBox[{"(", 
            RowBox[{"v", " ", 
             RowBox[{"(", 
              RowBox[{"t", "+", "2", "-", 
               FractionBox["l", "v"]}], ")"}]}], ")"}], "2"]}]], ",", 
        SqrtBox[
         RowBox[{
          SuperscriptBox[
           RowBox[{"(", 
            RowBox[{
             RowBox[{"bump1", "[", "t", "]"}], "+", 
             RowBox[{"bump2", "[", "t", "]"}]}], ")"}], "2"], "+", 
          SuperscriptBox[
           RowBox[{"(", 
            RowBox[{"v", " ", 
             RowBox[{"(", 
              RowBox[{"t", "+", "2", "-", 
               FractionBox["l", "v"]}], ")"}]}], ")"}], "2"]}]]}], "]"}], 
      "]"}]}], ";", 
    RowBox[{
     RowBox[{"geodesicPlot", "[", 
      RowBox[{
      "geodesic_", ",", "phiOffset_", ",", "t1_", ",", "t2_", ",", 
       "colours_"}], "]"}], ":=", 
     RowBox[{"Dynamic", "[", 
      RowBox[{"If", "[", 
       RowBox[{
        RowBox[{
         RowBox[{"t1", "\[LeftDoubleBracket]", "1", "\[RightDoubleBracket]"}],
          ">", "tmax"}], ",", 
        RowBox[{"{", "}"}], ",", 
        RowBox[{"ParametricPlot3D", "[", 
         RowBox[{
          RowBox[{"{", 
           RowBox[{
            RowBox[{
             RowBox[{
              RowBox[{"geodesic", "[", "t", "]"}], "\[LeftDoubleBracket]", 
              "1", "\[RightDoubleBracket]"}], " ", 
             RowBox[{"Cos", "[", "phiOffset", "]"}]}], ",", 
            RowBox[{
             RowBox[{
              RowBox[{"geodesic", "[", "t", "]"}], "\[LeftDoubleBracket]", 
              "1", "\[RightDoubleBracket]"}], " ", 
             RowBox[{"Sin", "[", "phiOffset", "]"}]}], ",", "t"}], "}"}], ",", 
          RowBox[{"{", 
           RowBox[{"t", ",", 
            RowBox[{
            "t1", "\[LeftDoubleBracket]", "1", "\[RightDoubleBracket]"}], ",", 
            RowBox[{
            "t2", "\[LeftDoubleBracket]", "1", "\[RightDoubleBracket]"}]}], 
           "}"}], ",", 
          RowBox[{"ColorFunction", "\[Rule]", "colours"}], ",", 
          RowBox[{"ColorFunctionScaling", "\[Rule]", "False"}]}], "]"}]}], 
       "]"}], "]"}]}], ";", 
    RowBox[{"wormhole", "=", 
     RowBox[{"Dynamic", "[", 
      RowBox[{"If", "[", 
       RowBox[{"persistentWormhole", ",", 
        RowBox[{"Graphics3D", "[", 
         RowBox[{"{", 
          RowBox[{
           RowBox[{"Opacity", "[", 
            RowBox[{"0.2", ",", "Green"}], "]"}], ",", 
           RowBox[{"Cylinder", "[", 
            RowBox[{
             RowBox[{"{", 
              RowBox[{
               RowBox[{"{", 
                RowBox[{"0", ",", "0", ",", 
                 RowBox[{"tmin", "-", "1"}]}], "}"}], ",", 
               RowBox[{"{", 
                RowBox[{"0", ",", "0", ",", 
                 RowBox[{"tmax", "+", "1"}]}], "}"}]}], "}"}], ",", "b"}], 
            "]"}]}], "}"}], "]"}], ",", 
        RowBox[{"{", 
         RowBox[{
          RowBox[{"RevolutionPlot3D", "[", 
           RowBox[{
            RowBox[{"{", 
             RowBox[{
              RowBox[{"bump1", "[", "t", "]"}], ",", "t"}], "}"}], ",", 
            RowBox[{"{", 
             RowBox[{"t", ",", 
              RowBox[{"t0", "-", "tl"}], ",", 
              RowBox[{"t0", "+", "tl"}]}], "}"}], ",", 
            RowBox[{"Mesh", "\[Rule]", "None"}]}], "]"}], ",", 
          RowBox[{"RevolutionPlot3D", "[", 
           RowBox[{
            RowBox[{"{", 
             RowBox[{
              RowBox[{"bump1", "[", "t", "]"}], ",", 
              RowBox[{"t", "-", "2"}]}], "}"}], ",", 
            RowBox[{"{", 
             RowBox[{"t", ",", 
              RowBox[{"t0", "-", "tl"}], ",", 
              RowBox[{"t0", "+", "tl"}]}], "}"}], ",", 
            RowBox[{"Mesh", "\[Rule]", "None"}]}], "]"}]}], "}"}]}], "]"}], 
      "]"}]}], ";", 
    RowBox[{"singleHistory", "=", 
     RowBox[{"Dynamic", "[", 
      RowBox[{"If", "[", 
       RowBox[{
        RowBox[{
         RowBox[{"(", 
          RowBox[{
           RowBox[{
            RowBox[{"Abs", "[", 
             FractionBox["l", 
              RowBox[{"t0", "+", "tl"}]], "]"}], "<", "v"}], "&&", 
           RowBox[{
            RowBox[{"Abs", "[", 
             FractionBox["l", 
              RowBox[{"t0", "-", "tl"}]], "]"}], ">", "v"}]}], ")"}], "||", 
         "persistentWormhole"}], ",", 
        RowBox[{"{", 
         RowBox[{
          RowBox[{
           RowBox[{"geodesicPlot", "[", 
            RowBox[{"radial1", ",", "0", ",", 
             RowBox[{"Dynamic", "[", "tmin", "]"}], ",", 
             RowBox[{"Dynamic", "[", 
              FractionBox[
               RowBox[{"l", "-", "v"}], "v"], "]"}], ",", "colourFunction1"}],
             "]"}], "\[LeftDoubleBracket]", "1", "\[RightDoubleBracket]"}], 
          ",", 
          RowBox[{
           RowBox[{"geodesicPlot", "[", 
            RowBox[{"radial1", ",", "0", ",", 
             RowBox[{"Dynamic", "[", 
              FractionBox[
               RowBox[{"l", "-", "v"}], "v"], "]"}], ",", 
             RowBox[{"Dynamic", "[", 
              FractionBox["l", "v"], "]"}], ",", 
             RowBox[{"Function", "[", 
              RowBox[{
               RowBox[{"{", "}"}], ",", "Gray"}], "]"}]}], "]"}], 
           "\[LeftDoubleBracket]", "1", "\[RightDoubleBracket]"}], ",", 
          RowBox[{
           RowBox[{"geodesicPlot", "[", 
            RowBox[{"radial2", ",", "0", ",", 
             RowBox[{"Dynamic", "[", 
              RowBox[{
               FractionBox["l", "v"], "-", "2"}], "]"}], ",", 
             RowBox[{"Dynamic", "[", 
              FractionBox[
               RowBox[{"l", "-", "v"}], "v"], "]"}], ",", 
             RowBox[{"Function", "[", 
              RowBox[{
               RowBox[{"{", "t", "}"}], ",", "Gray"}], "]"}]}], "]"}], 
           "\[LeftDoubleBracket]", "1", "\[RightDoubleBracket]"}], ",", 
          RowBox[{
           RowBox[{"geodesicPlot", "[", 
            RowBox[{"radial2", ",", "0", ",", 
             RowBox[{"Dynamic", "[", 
              FractionBox[
               RowBox[{"l", "-", "v"}], "v"], "]"}], ",", 
             RowBox[{"Dynamic", "[", "tmax", "]"}], ",", 
             RowBox[{"Function", "[", 
              RowBox[{
               RowBox[{"{", "t", "}"}], ",", "Gray"}], "]"}]}], "]"}], 
           "\[LeftDoubleBracket]", "1", "\[RightDoubleBracket]"}]}], "}"}], 
        ",", 
        RowBox[{"{", 
         RowBox[{
          RowBox[{
           RowBox[{"geodesicPlot", "[", 
            RowBox[{"radial1", ",", "0", ",", 
             RowBox[{"Dynamic", "[", "tmin", "]"}], ",", 
             RowBox[{"Dynamic", "[", 
              FractionBox["l", "v"], "]"}], ",", "colourFunction1"}], "]"}], 
           "\[LeftDoubleBracket]", "1", "\[RightDoubleBracket]"}], ",", 
          RowBox[{"If", "[", 
           RowBox[{
            RowBox[{
             FractionBox["l", "v"], "\[LessEqual]", "tmax"}], ",", 
            RowBox[{
             RowBox[{"geodesicPlot", "[", 
              RowBox[{"radial1", ",", "\[Pi]", ",", 
               RowBox[{"Dynamic", "[", 
                FractionBox["l", "v"], "]"}], ",", 
               RowBox[{"Dynamic", "[", "tmax", "]"}], ",", "colourFunction1"}]
               , "]"}], "\[LeftDoubleBracket]", "1", 
             "\[RightDoubleBracket]"}], ",", 
            RowBox[{"{", "}"}]}], "]"}]}], "}"}]}], "]"}], "]"}]}], ";", 
    RowBox[{"multipleHistory", "=", 
     RowBox[{"Dynamic", "[", 
      RowBox[{"If", "[", 
       RowBox[{
        RowBox[{
         RowBox[{"(", 
          RowBox[{
           RowBox[{
            RowBox[{"Abs", "[", 
             FractionBox["l", 
              RowBox[{"t0", "+", "tl"}]], "]"}], "<", "v"}], "&&", 
           RowBox[{
            RowBox[{"Abs", "[", 
             FractionBox["l", 
              RowBox[{"t0", "-", "tl"}]], "]"}], ">", "v"}]}], ")"}], "||", 
         "persistentWormhole"}], ",", 
        RowBox[{"{", 
         RowBox[{
          RowBox[{"{", 
           RowBox[{
            RowBox[{
             RowBox[{"geodesicPlot", "[", 
              RowBox[{"radial1", ",", "0", ",", 
               RowBox[{"Dynamic", "[", "tmin", "]"}], ",", 
               RowBox[{"Dynamic", "[", 
                FractionBox[
                 RowBox[{"l", "-", "v"}], "v"], "]"}], ",", 
               "colourFunction1"}], "]"}], "\[LeftDoubleBracket]", "1", 
             "\[RightDoubleBracket]"}], ",", 
            RowBox[{
             RowBox[{"geodesicPlot", "[", 
              RowBox[{"radial1", ",", "0", ",", 
               RowBox[{"Dynamic", "[", 
                FractionBox[
                 RowBox[{"l", "-", "v"}], "v"], "]"}], ",", 
               RowBox[{"Dynamic", "[", 
                FractionBox["l", "v"], "]"}], ",", "colourFunction1"}], "]"}],
              "\[LeftDoubleBracket]", "1", "\[RightDoubleBracket]"}]}], "}"}],
           ",", 
          RowBox[{"{", 
           RowBox[{
            RowBox[{
             RowBox[{"geodesicPlot", "[", 
              RowBox[{"radial1", ",", "0", ",", 
               RowBox[{"Dynamic", "[", "tmin", "]"}], ",", 
               RowBox[{"Dynamic", "[", 
                FractionBox[
                 RowBox[{"l", "-", "v"}], "v"], "]"}], ",", 
               "colourFunction1"}], "]"}], "\[LeftDoubleBracket]", "1", 
             "\[RightDoubleBracket]"}], ",", 
            RowBox[{
             RowBox[{"geodesicPlot", "[", 
              RowBox[{"radial1", ",", "0", ",", 
               RowBox[{"Dynamic", "[", 
                FractionBox[
                 RowBox[{"l", "-", "v"}], "v"], "]"}], ",", 
               RowBox[{"Dynamic", "[", 
                FractionBox["l", "v"], "]"}], ",", "colourFunction2"}], "]"}],
              "\[LeftDoubleBracket]", "1", "\[RightDoubleBracket]"}], ",", 
            RowBox[{
             RowBox[{"geodesicPlot", "[", 
              RowBox[{"radial2", ",", "0", ",", 
               RowBox[{"Dynamic", "[", 
                RowBox[{
                 FractionBox["l", "v"], "-", "2"}], "]"}], ",", 
               RowBox[{"Dynamic", "[", 
                FractionBox[
                 RowBox[{"l", "-", "v"}], "v"], "]"}], ",", 
               "colourFunction3"}], "]"}], "\[LeftDoubleBracket]", "1", 
             "\[RightDoubleBracket]"}], ",", 
            RowBox[{
             RowBox[{"geodesicPlot", "[", 
              RowBox[{"radial2", ",", "0", ",", 
               RowBox[{"Dynamic", "[", 
                FractionBox[
                 RowBox[{"l", "-", "v"}], "v"], "]"}], ",", 
               RowBox[{"Dynamic", "[", "tmax", "]"}], ",", 
               "colourFunction2"}], "]"}], "\[LeftDoubleBracket]", "1", 
             "\[RightDoubleBracket]"}]}], "}"}]}], "}"}], ",", 
        RowBox[{"{", 
         RowBox[{
          RowBox[{"{", 
           RowBox[{
            RowBox[{
             RowBox[{"geodesicPlot", "[", 
              RowBox[{"radial1", ",", "0", ",", 
               RowBox[{"Dynamic", "[", "tmin", "]"}], ",", 
               RowBox[{"Dynamic", "[", 
                FractionBox["l", "v"], "]"}], ",", "colourFunction1"}], "]"}],
              "\[LeftDoubleBracket]", "1", "\[RightDoubleBracket]"}], ",", 
            RowBox[{
             RowBox[{"geodesicPlot", "[", 
              RowBox[{"radial1", ",", "\[Pi]", ",", 
               RowBox[{"Dynamic", "[", 
                FractionBox["l", "v"], "]"}], ",", 
               RowBox[{"Dynamic", "[", "tmax", "]"}], ",", 
               "colourFunction1"}], "]"}], "\[LeftDoubleBracket]", "1", 
             "\[RightDoubleBracket]"}]}], "}"}], ",", 
          RowBox[{"{", 
           RowBox[{
            RowBox[{
             RowBox[{"geodesicPlot", "[", 
              RowBox[{"radial1", ",", "0", ",", 
               RowBox[{"Dynamic", "[", "tmin", "]"}], ",", 
               RowBox[{"Dynamic", "[", 
                FractionBox["l", "v"], "]"}], ",", "colourFunction1"}], "]"}],
              "\[LeftDoubleBracket]", "1", "\[RightDoubleBracket]"}], ",", 
            RowBox[{
             RowBox[{"geodesicPlot", "[", 
              RowBox[{"radial1", ",", "\[Pi]", ",", 
               RowBox[{"Dynamic", "[", 
                FractionBox["l", "v"], "]"}], ",", 
               RowBox[{"Dynamic", "[", "tmax", "]"}], ",", 
               "colourFunction1"}], "]"}], "\[LeftDoubleBracket]", "1", 
             "\[RightDoubleBracket]"}]}], "}"}]}], "}"}]}], "]"}], "]"}]}], 
    ";", 
    RowBox[{
     RowBox[{"graphics", "[", "h_", "]"}], ":=", 
     RowBox[{"Dynamic", "[", 
      RowBox[{"Deploy", "[", 
       RowBox[{"Pane", "[", 
        RowBox[{"ImageCrop", "[", 
         RowBox[{"Show", "[", 
          RowBox[{
           RowBox[{
           "wormhole", "\[LeftDoubleBracket]", "1", "\[RightDoubleBracket]"}],
            ",", 
           RowBox[{"If", "[", 
            RowBox[{
             RowBox[{"!", "multipleHistories"}], ",", 
             RowBox[{
             "singleHistory", "\[LeftDoubleBracket]", "1", 
              "\[RightDoubleBracket]"}], ",", 
             RowBox[{
              RowBox[{
              "multipleHistory", "\[LeftDoubleBracket]", "1", 
               "\[RightDoubleBracket]"}], "\[LeftDoubleBracket]", "h", 
              "\[RightDoubleBracket]"}]}], "]"}], ",", 
           RowBox[{"ImageSize", "\[Rule]", 
            RowBox[{"{", 
             RowBox[{"400", ",", "400"}], "}"}]}], ",", 
           RowBox[{"Axes", "\[Rule]", "False"}], ",", 
           RowBox[{"Boxed", "\[Rule]", "False"}], ",", 
           RowBox[{"ImagePadding", "\[Rule]", "None"}], ",", 
           RowBox[{"PlotRange", "\[Rule]", 
            RowBox[{"{", 
             RowBox[{
              RowBox[{"{", 
               RowBox[{"xmin", ",", "xmax"}], "}"}], ",", 
              RowBox[{"{", 
               RowBox[{
                RowBox[{"ymin", "-", "b"}], ",", 
                RowBox[{"ymax", "+", "b"}]}], "}"}], ",", 
              RowBox[{"{", 
               RowBox[{"tmin", ",", "tmax"}], "}"}]}], "}"}]}], ",", 
           RowBox[{"ViewPoint", "\[Rule]", 
            RowBox[{"{", 
             RowBox[{
              RowBox[{"1.3", " ", 
               RowBox[{"Cos", "[", 
                RowBox[{
                "\[Phi]", "\[LeftDoubleBracket]", "1", 
                 "\[RightDoubleBracket]"}], "]"}]}], ",", 
              RowBox[{
               RowBox[{"-", "2.4"}], " ", 
               RowBox[{"Sin", "[", 
                RowBox[{
                "\[Phi]", "\[LeftDoubleBracket]", "1", 
                 "\[RightDoubleBracket]"}], "]"}]}], ",", "1"}], "}"}]}], ",", 
           RowBox[{"ViewVertical", "\[Rule]", 
            RowBox[{"{", 
             RowBox[{"0", ",", "0", ",", "1"}], "}"}]}], ",", 
           RowBox[{"ViewAngle", "\[Rule]", "Automatic"}]}], "]"}], "]"}], 
        "]"}], "]"}], "]"}]}], ";", 
    RowBox[{"Dynamic", "[", 
     RowBox[{"Column", "[", 
      RowBox[{
       RowBox[{"{", 
        RowBox[{
         RowBox[{"Row", "[", 
          RowBox[{"{", 
           RowBox[{
            RowBox[{"Row", "[", 
             RowBox[{"{", 
              RowBox[{
               RowBox[{"Column", "[", 
                RowBox[{
                 RowBox[{"{", 
                  RowBox[{
                  "\"\<Initial Position: \>\"", ",", "\"\<Velocity: \>\"", 
                   ",", "\"\<Viewing Angle: \>\""}], "}"}], ",", "Right", ",", 
                 RowBox[{"Spacings", "\[Rule]", "1.2"}]}], "]"}], ",", 
               RowBox[{"Column", "[", 
                RowBox[{
                 RowBox[{"{", 
                  RowBox[{
                   RowBox[{"Row", "[", 
                    RowBox[{"{", 
                    RowBox[{
                    RowBox[{"Slider", "[", 
                    RowBox[{
                    RowBox[{"Dynamic", "[", "l", "]"}], ",", 
                    RowBox[{"{", 
                    RowBox[{
                    RowBox[{"Dynamic", "[", "0.01", "]"}], ",", "2"}], 
                    "}"}]}], "]"}], ",", 
                    RowBox[{"Dynamic", "[", 
                    RowBox[{"padNumber", "[", "l", "]"}], "]"}]}], "}"}], 
                    "]"}], ",", 
                   RowBox[{"Row", "[", 
                    RowBox[{"{", 
                    RowBox[{
                    RowBox[{"Slider", "[", 
                    RowBox[{
                    RowBox[{"Dynamic", "[", "v", "]"}], ",", 
                    RowBox[{"{", 
                    RowBox[{"0.01", ",", "1"}], "}"}]}], "]"}], ",", 
                    RowBox[{"Dynamic", "[", 
                    RowBox[{"padNumber", "[", "v", "]"}], "]"}]}], "}"}], 
                    "]"}], ",", 
                   RowBox[{"Row", "[", 
                    RowBox[{"{", 
                    RowBox[{
                    RowBox[{"Slider", "[", 
                    RowBox[{
                    RowBox[{"Dynamic", "[", "a", "]"}], ",", 
                    RowBox[{"{", 
                    RowBox[{
                    RowBox[{"-", "1"}], ",", "1"}], "}"}]}], "]"}], ",", 
                    RowBox[{"Dynamic", "[", 
                    RowBox[{"padDegrees", "[", 
                    RowBox[{"a", " ", "180"}], "]"}], "]"}], ",", 
                    "\"\<\[Degree]\>\""}], "}"}], "]"}]}], "}"}], ",", "Left",
                  ",", 
                 RowBox[{"Spacings", "\[Rule]", "1"}]}], "]"}]}], "}"}], 
             "]"}], ",", 
            RowBox[{"Row", "[", 
             RowBox[{"{", "\"\<  \>\"", "}"}], "]"}], ",", 
            RowBox[{"Row", "[", 
             RowBox[{"{", 
              RowBox[{
               RowBox[{"Column", "[", 
                RowBox[{
                 RowBox[{"{", 
                  RowBox[{"\"\<\>\"", ",", "\"\<Wormhole Radius: \>\"", ",", 
                   RowBox[{"If", "[", 
                    RowBox[{
                    RowBox[{"!", "persistentWormhole"}], ",", 
                    "\"\<Activation Time: \>\""}], "]"}], ",", 
                   RowBox[{"If", "[", 
                    RowBox[{
                    RowBox[{"!", "persistentWormhole"}], ",", 
                    "\"\<Activation Duration: \>\""}], "]"}]}], "}"}], ",", 
                 "Right", ",", 
                 RowBox[{"Spacings", "\[Rule]", "1.2"}]}], "]"}], ",", 
               RowBox[{"Column", "[", 
                RowBox[{
                 RowBox[{"{", 
                  RowBox[{
                   RowBox[{"RadioButtonBar", "[", 
                    RowBox[{
                    RowBox[{"Dynamic", "[", "multipleHistories", "]"}], ",", 
                    RowBox[{"{", 
                    RowBox[{
                    RowBox[{"False", "\[Rule]", "\"\<Single History\>\""}], 
                    ",", 
                    RowBox[{
                    "True", "\[Rule]", "\"\<Multiple Histories\>\""}]}], 
                    "}"}], ",", 
                    RowBox[{"Appearance", "\[Rule]", "\"\<Vertical\>\""}]}], 
                    "]"}], ",", 
                   RowBox[{"Row", "[", 
                    RowBox[{"{", 
                    RowBox[{
                    RowBox[{"Slider", "[", 
                    RowBox[{
                    RowBox[{"Dynamic", "[", "b", "]"}], ",", 
                    RowBox[{"{", 
                    RowBox[{"0.1", ",", "1"}], "}"}]}], "]"}], ",", 
                    RowBox[{"Dynamic", "[", 
                    RowBox[{"padNumber", "[", "b", "]"}], "]"}]}], "}"}], 
                    "]"}], ",", 
                   RowBox[{"If", "[", 
                    RowBox[{
                    RowBox[{"!", "persistentWormhole"}], ",", 
                    RowBox[{"Row", "[", 
                    RowBox[{"{", 
                    RowBox[{
                    RowBox[{"Slider", "[", 
                    RowBox[{
                    RowBox[{"Dynamic", "[", "t0", "]"}], ",", 
                    RowBox[{"{", 
                    RowBox[{"0", ",", "2"}], "}"}]}], "]"}], ",", 
                    RowBox[{"Dynamic", "[", 
                    RowBox[{"padNumber", "[", "t0", "]"}], "]"}]}], "}"}], 
                    "]"}]}], "]"}], ",", 
                   RowBox[{"If", "[", 
                    RowBox[{
                    RowBox[{"!", "persistentWormhole"}], ",", 
                    RowBox[{"Row", "[", 
                    RowBox[{"{", 
                    RowBox[{
                    RowBox[{"Slider", "[", 
                    RowBox[{
                    RowBox[{"Dynamic", "[", "tl", "]"}], ",", 
                    RowBox[{"{", 
                    RowBox[{"0.2", ",", "0.99"}], "}"}]}], "]"}], ",", 
                    RowBox[{"Dynamic", "[", 
                    RowBox[{"padNumber", "[", "tl", "]"}], "]"}]}], "}"}], 
                    "]"}]}], "]"}]}], "}"}], ",", "Left", ",", 
                 RowBox[{"Spacings", "\[Rule]", "1"}]}], "]"}]}], "}"}], 
             "]"}]}], "}"}], "]"}], ",", 
         RowBox[{"Row", "[", 
          RowBox[{"{", 
           RowBox[{
            RowBox[{"graphics", "[", "1", "]"}], ",", 
            RowBox[{"If", "[", 
             RowBox[{"multipleHistories", ",", 
              RowBox[{"Sequence", "@@", 
               RowBox[{"{", 
                RowBox[{"\"\<          \>\"", ",", 
                 RowBox[{"graphics", "[", "2", "]"}]}], "}"}]}]}], "]"}]}], 
           "}"}], "]"}]}], "}"}], ",", "Center"}], "]"}], "]"}]}]}], 
  "]"}]], "Input",
 CellLabel->"In[1]:=",ExpressionUUID->"aa53ef7f-35ca-4091-98e1-7bfb54074807"],

Cell[BoxData[
 DynamicModuleBox[{$CellContext`padNumber$$, $CellContext`padDegrees$$, \
$CellContext`tmax$$ = 2.5, $CellContext`tmin$$ = -1.5, $CellContext`xmax$$ = 
  2, $CellContext`xmin$$ = -2, $CellContext`ymax$$ = 
  0.25, $CellContext`ymin$$ = -0.25, $CellContext`initialTemperature$$ = 
  750, $CellContext`collisionTemperature$$ = Dynamic[
   Mean[{
     $CellContext`particleTemperature$$[$CellContext`initialTemperature$$, \
($CellContext`l$$ - $CellContext`v$$)/$CellContext`v$$ - $CellContext`tmin$$], 
     $CellContext`particleTemperature$$[$CellContext`initialTemperature$$, \
$CellContext`l$$/$CellContext`v$$ + ($CellContext`l$$ - \
$CellContext`v$$)/$CellContext`v$$ - $CellContext`tmin$$]}]], \
$CellContext`minimumTemperature$$ = Dynamic[
   $CellContext`particleTemperature$$[
    Part[$CellContext`collisionTemperature$$, 
     1], $CellContext`tmax$$ - ($CellContext`l$$ - \
$CellContext`v$$)/$CellContext`v$$ - $CellContext`tmin$$]], $CellContext`b$$ =
   0.45, $CellContext`l$$ = 1.2, $CellContext`v$$ = 
  0.6, $CellContext`a$$ = -0.5, $CellContext`\[Phi]$$ = 
  Dynamic[$CellContext`a$$ Pi], $CellContext`tl$$ = 0.5, $CellContext`t0$$ = 
  1, $CellContext`history$$ = 
  1, $CellContext`particleTemperature$$, $CellContext`colourFunction1$$, \
$CellContext`colourFunction2$$, $CellContext`colourFunction3$$, \
$CellContext`persistentWormhole$$ = True, $CellContext`multipleHistories$$ = 
  False, $CellContext`bump1$$, $CellContext`bump2$$, $CellContext`wormhole$$ =
   Dynamic[
   If[$CellContext`persistentWormhole$$, 
    Graphics3D[{
      Opacity[0.2, Green], 
      Cylinder[{{0, 0, $CellContext`tmin$$ - 1}, {
        0, 0, $CellContext`tmax$$ + 1}}, $CellContext`b$$]}], {
     RevolutionPlot3D[{
       $CellContext`bump1$$[$CellContext`t], $CellContext`t}, \
{$CellContext`t, $CellContext`t0$$ - $CellContext`tl$$, $CellContext`t0$$ + \
$CellContext`tl$$}, Mesh -> None], 
     RevolutionPlot3D[{
       $CellContext`bump1$$[$CellContext`t], $CellContext`t - 
       2}, {$CellContext`t, $CellContext`t0$$ - $CellContext`tl$$, \
$CellContext`t0$$ + $CellContext`tl$$}, Mesh -> 
      None]}]], $CellContext`radial1$$, $CellContext`radial2$$, \
$CellContext`geodesicPlot$$, $CellContext`singleHistory$$ = Dynamic[
   If[
    Or[
     And[Abs[$CellContext`l$$/($CellContext`t0$$ + $CellContext`tl$$)] < \
$CellContext`v$$, 
      Abs[$CellContext`l$$/($CellContext`t0$$ - $CellContext`tl$$)] > \
$CellContext`v$$], $CellContext`persistentWormhole$$], {
     Part[
      $CellContext`geodesicPlot$$[$CellContext`radial1$$, 0, 
       Dynamic[$CellContext`tmin$$], 
       Dynamic[($CellContext`l$$ - $CellContext`v$$)/$CellContext`v$$], \
$CellContext`colourFunction1$$], 1], 
     Part[
      $CellContext`geodesicPlot$$[$CellContext`radial1$$, 0, 
       Dynamic[($CellContext`l$$ - $CellContext`v$$)/$CellContext`v$$], 
       Dynamic[$CellContext`l$$/$CellContext`v$$], 
       Function[{}, Gray]], 1], 
     Part[
      $CellContext`geodesicPlot$$[$CellContext`radial2$$, 0, 
       Dynamic[$CellContext`l$$/$CellContext`v$$ - 2], 
       Dynamic[($CellContext`l$$ - $CellContext`v$$)/$CellContext`v$$], 
       Function[{$CellContext`t}, Gray]], 1], 
     Part[
      $CellContext`geodesicPlot$$[$CellContext`radial2$$, 0, 
       Dynamic[($CellContext`l$$ - $CellContext`v$$)/$CellContext`v$$], 
       Dynamic[$CellContext`tmax$$], 
       Function[{$CellContext`t}, Gray]], 1]}, {
     Part[
      $CellContext`geodesicPlot$$[$CellContext`radial1$$, 0, 
       Dynamic[$CellContext`tmin$$], 
       Dynamic[$CellContext`l$$/$CellContext`v$$], \
$CellContext`colourFunction1$$], 1], 
     If[$CellContext`l$$/$CellContext`v$$ <= $CellContext`tmax$$, 
      Part[
       $CellContext`geodesicPlot$$[$CellContext`radial1$$, Pi, 
        Dynamic[$CellContext`l$$/$CellContext`v$$], 
        Dynamic[$CellContext`tmax$$], $CellContext`colourFunction1$$], 
       1], {}]}]], $CellContext`multipleHistory$$ = Dynamic[
   If[
    Or[
     And[Abs[$CellContext`l$$/($CellContext`t0$$ + $CellContext`tl$$)] < \
$CellContext`v$$, 
      Abs[$CellContext`l$$/($CellContext`t0$$ - $CellContext`tl$$)] > \
$CellContext`v$$], $CellContext`persistentWormhole$$], {{
      Part[
       $CellContext`geodesicPlot$$[$CellContext`radial1$$, 0, 
        Dynamic[$CellContext`tmin$$], 
        Dynamic[($CellContext`l$$ - $CellContext`v$$)/$CellContext`v$$], \
$CellContext`colourFunction1$$], 1], 
      Part[
       $CellContext`geodesicPlot$$[$CellContext`radial1$$, 0, 
        Dynamic[($CellContext`l$$ - $CellContext`v$$)/$CellContext`v$$], 
        Dynamic[$CellContext`l$$/$CellContext`v$$], \
$CellContext`colourFunction1$$], 1]}, {
      Part[
       $CellContext`geodesicPlot$$[$CellContext`radial1$$, 0, 
        Dynamic[$CellContext`tmin$$], 
        Dynamic[($CellContext`l$$ - $CellContext`v$$)/$CellContext`v$$], \
$CellContext`colourFunction1$$], 1], 
      Part[
       $CellContext`geodesicPlot$$[$CellContext`radial1$$, 0, 
        Dynamic[($CellContext`l$$ - $CellContext`v$$)/$CellContext`v$$], 
        Dynamic[$CellContext`l$$/$CellContext`v$$], \
$CellContext`colourFunction2$$], 1], 
      Part[
       $CellContext`geodesicPlot$$[$CellContext`radial2$$, 0, 
        Dynamic[$CellContext`l$$/$CellContext`v$$ - 2], 
        Dynamic[($CellContext`l$$ - $CellContext`v$$)/$CellContext`v$$], \
$CellContext`colourFunction3$$], 1], 
      Part[
       $CellContext`geodesicPlot$$[$CellContext`radial2$$, 0, 
        Dynamic[($CellContext`l$$ - $CellContext`v$$)/$CellContext`v$$], 
        Dynamic[$CellContext`tmax$$], $CellContext`colourFunction2$$], 1]}}, {{
      Part[
       $CellContext`geodesicPlot$$[$CellContext`radial1$$, 0, 
        Dynamic[$CellContext`tmin$$], 
        Dynamic[$CellContext`l$$/$CellContext`v$$], \
$CellContext`colourFunction1$$], 1], 
      Part[
       $CellContext`geodesicPlot$$[$CellContext`radial1$$, Pi, 
        Dynamic[$CellContext`l$$/$CellContext`v$$], 
        Dynamic[$CellContext`tmax$$], $CellContext`colourFunction1$$], 1]}, {
      Part[
       $CellContext`geodesicPlot$$[$CellContext`radial1$$, 0, 
        Dynamic[$CellContext`tmin$$], 
        Dynamic[$CellContext`l$$/$CellContext`v$$], \
$CellContext`colourFunction1$$], 1], 
      Part[
       $CellContext`geodesicPlot$$[$CellContext`radial1$$, Pi, 
        Dynamic[$CellContext`l$$/$CellContext`v$$], 
        Dynamic[$CellContext`tmax$$], $CellContext`colourFunction1$$], 
       1]}}]], $CellContext`graphics$$}, 
  DynamicBox[ToBoxes[
    Column[{
      Row[{
        Row[{
          
          Column[{"Initial Position: ", "Velocity: ", "Viewing Angle: "}, 
           Right, Spacings -> 1.2], 
          Column[{
            Row[{
              Slider[
               Dynamic[$CellContext`l$$], {
                Dynamic[0.01], 2}], 
              Dynamic[
               $CellContext`padNumber$$[$CellContext`l$$]]}], 
            Row[{
              Slider[
               Dynamic[$CellContext`v$$], {0.01, 1}], 
              Dynamic[
               $CellContext`padNumber$$[$CellContext`v$$]]}], 
            Row[{
              Slider[
               Dynamic[$CellContext`a$$], {-1, 1}], 
              Dynamic[
               $CellContext`padDegrees$$[$CellContext`a$$ 180]], 
              "\[Degree]"}]}, Left, Spacings -> 1]}], 
        Row[{"  "}], 
        Row[{
          Column[{"", "Wormhole Radius: ", 
            If[
             Not[$CellContext`persistentWormhole$$], "Activation Time: "], 
            If[
             Not[$CellContext`persistentWormhole$$], 
             "Activation Duration: "]}, Right, Spacings -> 1.2], 
          Column[{
            RadioButtonBar[
             Dynamic[$CellContext`multipleHistories$$], {
             False -> "Single History", True -> "Multiple Histories"}, 
             Appearance -> "Vertical"], 
            Row[{
              Slider[
               Dynamic[$CellContext`b$$], {0.1, 1}], 
              Dynamic[
               $CellContext`padNumber$$[$CellContext`b$$]]}], 
            If[
             Not[$CellContext`persistentWormhole$$], 
             Row[{
               Slider[
                Dynamic[$CellContext`t0$$], {0, 2}], 
               Dynamic[
                $CellContext`padNumber$$[$CellContext`t0$$]]}]], 
            If[
             Not[$CellContext`persistentWormhole$$], 
             Row[{
               Slider[
                Dynamic[$CellContext`tl$$], {0.2, 0.99}], 
               Dynamic[
                $CellContext`padNumber$$[$CellContext`tl$$]]}]]}, Left, 
           Spacings -> 1]}]}], 
      Row[{
        $CellContext`graphics$$[1], 
        If[$CellContext`multipleHistories$$, 
         Apply[Sequence, {"          ", 
           $CellContext`graphics$$[2]}]]}]}, Center], StandardForm],
   ImageSizeCache->{747., {234.734033203125, 240.465966796875}}],
  DynamicModuleValues:>{{DownValues[$CellContext`padNumber$$] = {HoldPattern[
         $CellContext`padNumber$$[
          Pattern[$CellContext`n, 
           Blank[]]]] :> PaddedForm[
         N[$CellContext`n], {3, 2}, NumberPadding -> {"", "0"}, 
         NumberSigns -> {"-", "+"}]}}, {
    DownValues[$CellContext`padDegrees$$] = {HoldPattern[
         $CellContext`padDegrees$$[
          Pattern[$CellContext`n, 
           Blank[]]]] :> PaddedForm[
         IntegerPart[
          N[$CellContext`n]], {3, 0}, NumberPadding -> {" ", "0"}, 
         NumberSigns -> {"-", "+"}]}}, {
    DownValues[$CellContext`particleTemperature$$] = {HoldPattern[
         $CellContext`particleTemperature$$[
          Pattern[$CellContext`initialT, 
           Blank[]], 
          Pattern[$CellContext`t, 
           Blank[]]]] :> 
       N[($CellContext`t/(3 10^8) + 
          1/$CellContext`initialT^0.5)^(-(1/0.5))]}}, {
    DownValues[$CellContext`colourFunction1$$] = {HoldPattern[
         $CellContext`colourFunction1$$[
          Pattern[$CellContext`t$, 
           Blank[]]]] :> Blend[{Blue, Yellow, Orange, Red}, 
         Rescale[
          $CellContext`particleTemperature$$[$CellContext`initialTemperature$$\
, $CellContext`t$ - $CellContext`tmin$$], {
           
           Part[$CellContext`minimumTemperature$$, 
            1], $CellContext`initialTemperature$$}]]}}, {
    DownValues[$CellContext`colourFunction2$$] = {HoldPattern[
         $CellContext`colourFunction2$$[
          Pattern[$CellContext`t$, 
           Blank[]]]] :> Blend[{Blue, Yellow, Orange, Red}, 
         Rescale[
          $CellContext`particleTemperature$$[
           
           Part[$CellContext`collisionTemperature$$, 
            1], $CellContext`t$ - ($CellContext`l$$ - \
$CellContext`v$$)/$CellContext`v$$ - $CellContext`tmin$$], {
           
           Part[$CellContext`minimumTemperature$$, 
            1], $CellContext`initialTemperature$$}]]}}, {
    DownValues[$CellContext`colourFunction3$$] = {HoldPattern[
         $CellContext`colourFunction3$$[
          Pattern[$CellContext`t$, 
           Blank[]]]] :> Blend[{Blue, Yellow, Orange, Red}, 
         Rescale[
          $CellContext`particleTemperature$$[$CellContext`initialTemperature$$\
, $CellContext`t$ - $CellContext`tmin$$ + $CellContext`l$$/$CellContext`v$$], {
           
           Part[$CellContext`minimumTemperature$$, 
            1], $CellContext`initialTemperature$$}]]}}, {
    DownValues[$CellContext`bump1$$] = {HoldPattern[
         $CellContext`bump1$$[
          Pattern[$CellContext`t$, 
           Blank[]]]] :> 
       Piecewise[{{
          0.0001, Abs[$CellContext`tl$$^2 - ($CellContext`t$ - \
$CellContext`t0$$)^2] < 0.01}, {$CellContext`b$$ 
           Exp[1/$CellContext`tl$$^2 - 
             1/($CellContext`tl$$^2 - ($CellContext`t$ - \
$CellContext`t0$$)^2)], 
           
           And[$CellContext`t0$$ - $CellContext`tl$$ < $CellContext`t$, \
$CellContext`t$ < $CellContext`t0$$ + $CellContext`tl$$]}, {
          0.0001, True}}]}}, {DownValues[$CellContext`bump2$$] = {HoldPattern[
         $CellContext`bump2$$[
          Pattern[$CellContext`t$, 
           Blank[]]]] :> $CellContext`bump1$$[$CellContext`t$ + 2]}}, {
    DownValues[$CellContext`radial1$$] = {HoldPattern[
         $CellContext`radial1$$[
          Pattern[$CellContext`t$, 
           Blank[]]]] :> Dynamic[
         If[$CellContext`persistentWormhole$$, 
          
          Sqrt[$CellContext`b$$^2 + ($CellContext`l$$ - $CellContext`v$$ \
$CellContext`t$)^2], 
          
          Sqrt[($CellContext`bump1$$[$CellContext`t$] + \
$CellContext`bump2$$[$CellContext`t$])^2 + ($CellContext`l$$ - \
$CellContext`v$$ $CellContext`t$)^2]]]}}, {
    DownValues[$CellContext`radial2$$] = {HoldPattern[
         $CellContext`radial2$$[
          Pattern[$CellContext`t$, 
           Blank[]]]] :> Dynamic[
         If[$CellContext`persistentWormhole$$, 
          
          Sqrt[$CellContext`b$$^2 + ($CellContext`v$$ ($CellContext`t$ + 
              2 - $CellContext`l$$/$CellContext`v$$))^2], 
          
          Sqrt[($CellContext`bump1$$[$CellContext`t$] + \
$CellContext`bump2$$[$CellContext`t$])^2 + ($CellContext`v$$ ($CellContext`t$ + 
              2 - $CellContext`l$$/$CellContext`v$$))^2]]]}}, {
    DownValues[$CellContext`geodesicPlot$$] = {HoldPattern[
         $CellContext`geodesicPlot$$[
          Pattern[$CellContext`geodesic$, 
           Blank[]], 
          Pattern[$CellContext`phiOffset$, 
           Blank[]], 
          Pattern[$CellContext`t1$, 
           Blank[]], 
          Pattern[$CellContext`t2$, 
           Blank[]], 
          Pattern[$CellContext`colours$, 
           Blank[]]]] :> Dynamic[
         If[Part[$CellContext`t1$, 1] > $CellContext`tmax$$, {}, 
          ParametricPlot3D[{Part[
              $CellContext`geodesic$[$CellContext`t], 1] 
            Cos[$CellContext`phiOffset$], Part[
              $CellContext`geodesic$[$CellContext`t], 1] 
            Sin[$CellContext`phiOffset$], $CellContext`t}, {$CellContext`t, 
            Part[$CellContext`t1$, 1], 
            Part[$CellContext`t2$, 1]}, 
           ColorFunction -> $CellContext`colours$, ColorFunctionScaling -> 
           False]]]}}, {DownValues[$CellContext`graphics$$] = {HoldPattern[
         $CellContext`graphics$$[
          Pattern[$CellContext`h$, 
           Blank[]]]] :> Dynamic[
         Deploy[
          Pane[
           ImageCrop[
            Show[
             Part[$CellContext`wormhole$$, 1], 
             If[
              Not[$CellContext`multipleHistories$$], 
              Part[$CellContext`singleHistory$$, 1], 
              Part[
               Part[$CellContext`multipleHistory$$, 1], $CellContext`h$]], 
             ImageSize -> {400, 400}, Axes -> False, Boxed -> False, 
             ImagePadding -> None, 
             PlotRange -> {{$CellContext`xmin$$, $CellContext`xmax$$}, \
{$CellContext`ymin$$ - $CellContext`b$$, $CellContext`ymax$$ + \
$CellContext`b$$}, {$CellContext`tmin$$, $CellContext`tmax$$}}, 
             ViewPoint -> {1.3 Cos[
                 Part[$CellContext`\[Phi]$$, 1]], (-2.4) Sin[
                 Part[$CellContext`\[Phi]$$, 1]], 1}, 
             ViewVertical -> {0, 0, 1}, ViewAngle -> 
             Automatic]]]]]}}}]], "Output",
 CellLabel->"Out[1]=",ExpressionUUID->"9851d958-78ef-4a26-be6b-c6d5e0f4d386"]
}, {2}]],

Cell[TextData[{
 "The wormhole is represented by a green cylinder. Shown is a slice of the \
Morris-Thorne traversable wormhole spacetime with time ",
 Cell[BoxData[
  FormBox[
   TemplateBox[<|"boxes" -> FormBox[
       StyleBox["t", "TI"], TraditionalForm], "errors" -> {}, "input" -> "t", 
     "state" -> "Boxes"|>,
    "TeXAssistantTemplate"], TraditionalForm]],ExpressionUUID->
  "b8baa661-d8de-4eee-9732-c7b5a6cb01b8"],
 " as the vertical axis, the radial coordinate ",
 Cell[BoxData[
  FormBox[
   TemplateBox[<|"boxes" -> FormBox[
       RowBox[{
         StyleBox["r", "TI"], "\[Element]", 
         RowBox[{"[", 
           RowBox[{
             SubscriptBox[
              StyleBox["b", "TI"], "0"], ",", "\[Infinity]"}], ")"}]}], 
       TraditionalForm], "errors" -> {}, "input" -> 
     "r\\in\\left[b_{0},\\infty\\right)", "state" -> "Boxes"|>,
    "TeXAssistantTemplate"], TraditionalForm]],ExpressionUUID->
  "46e089e8-8955-4f1e-94aa-0686ee7c6228"],
 " orthogonal to the ",
 Cell[BoxData[
  FormBox[
   TemplateBox[<|"boxes" -> FormBox[
       StyleBox["t", "TI"], TraditionalForm], "errors" -> {}, "input" -> "t", 
     "state" -> "Boxes"|>,
    "TeXAssistantTemplate"], TraditionalForm]],ExpressionUUID->
  "644e88f3-2a83-485f-8736-896ad62fc938"],
 " axis, and the azimuthal angle ",
 Cell[BoxData[
  FormBox[
   TemplateBox[<|
    "boxes" -> FormBox["\[Phi]", TraditionalForm], "errors" -> {}, "input" -> 
     "\\phi", "state" -> "Boxes"|>,
    "TeXAssistantTemplate"], TraditionalForm]],ExpressionUUID->
  "87d61720-32f9-4c67-9b56-6ab3777ed128"],
 " going around the ",
 Cell[BoxData[
  FormBox[
   TemplateBox[<|"boxes" -> FormBox[
       StyleBox["t", "TI"], TraditionalForm], "errors" -> {}, "input" -> "t", 
     "state" -> "Boxes"|>,
    "TeXAssistantTemplate"], TraditionalForm]],ExpressionUUID->
  "a44d6999-e9b3-449a-af8b-29f951c682f2"],
 " axis. The polar angle ",
 Cell[BoxData[
  FormBox[
   TemplateBox[<|
    "boxes" -> FormBox["\[Theta]", TraditionalForm], "errors" -> {}, "input" -> 
     "\\theta", "state" -> "Boxes"|>,
    "TeXAssistantTemplate"], TraditionalForm]],ExpressionUUID->
  "d43686dc-c078-45d4-baa1-f4ec7a2af858"],
 " is suppressed, such that ",
 StyleBox["each circle in the cylinder represents a sphere",
  FontWeight->"Bold"],
 " at a particular instance in time. Note that in the Morris-Thorne \
spacetime, the region ",
 Cell[BoxData[
  FormBox[
   TemplateBox[<|"boxes" -> FormBox[
       RowBox[{
         StyleBox["r", "TI"], "\[Element]", 
         RowBox[{"[", 
           RowBox[{"0", ",", 
             SubscriptBox[
              StyleBox["b", "TI"], "0"]}], ")"}]}], TraditionalForm], 
     "errors" -> {}, "input" -> "r\\in\\left[0,b_{0}\\right)", "state" -> 
     "Boxes"|>,
    "TeXAssistantTemplate"], TraditionalForm]],ExpressionUUID->
  "a966c11e-9548-4f3c-8650-154ab04644a8"],
 " \[Dash] the interior of the cylinder in the plot \[Dash] is inaccessible."
}], "Text",ExpressionUUID->"3a4272e0-42e0-4307-9aed-ffb40e6d346f"],

Cell["\<\
The incoming and outgoing paths of the object are calculated using the \
geodesic equations. The colors along the paths indicate temperature, with red \
being the hottest. The object starts at the red temperature and approaches \
the wormhole. Upon traversal, the object exits the wormhole in the past, in \
the opposite spatial direction, and then collides with its past self.\
\>", "Text",ExpressionUUID->"cf56bd8d-9659-4d57-aea4-92a2d97fe774"],

Cell[TextData[{
 "With a ",
 StyleBox["single history",
  FontWeight->"Bold"],
 ", a paradox will always arise. This is indicated by the fact that some of \
the path is colored gray, which means there is no consistent choice of \
temperature along the path, hence there is a consistency paradox. By \
switching to ",
 StyleBox["multiple histories",
  FontWeight->"Bold"],
 ", we resolve the paradox. Two histories will be shown on the screen, with \
the first history on the left and the second (new) history on the right. The \
gray lines will disappear, and there will be a fully consistent temperature \
evolution along the paths, thus we have resolved the paradox."
}], "Text",ExpressionUUID->"74cd1ec7-149b-47e9-b5a4-91993f02053b"],

Cell[TextData[{
 "Copyright (c) 2023 Barak Shoshany and Jared Wogan. Licensed under the MIT \
license; please see the file ",
 StyleBox["LICENSE.txt", "Input"],
 " in the ",
 ButtonBox["GitHub repository",
  BaseStyle->"Hyperlink",
  ButtonData->{
    URL["https://github.com/bshoshany/WormholeParadoxSimulation"], None},
  ButtonNote->"https://github.com/bshoshany/WormholeParadoxSimulation"],
 " for more information."
}], "Text",ExpressionUUID->"41c5156a-917a-4f15-9be5-49f1e9e1573a"],

Cell["Please cite this work as follows:", "Text",ExpressionUUID->"32026af9-3b5e-427a-a8cd-c0d2bd0b99d0"],

Cell[TextData[{
 "Barak Shoshany and Jared Wogan, \[OpenCurlyDoubleQuote]Wormhole Time \
Machines and Multiple Histories\[CloseCurlyDoubleQuote], ",
 ButtonBox["Gen. Relativ. Gravit. 55, 44 (2023)",
  BaseStyle->"Hyperlink",
  ButtonData->{
    URL["https://link.springer.com/article/10.1007/s10714-023-03094-8"], None},
  ButtonNote->"https://link.springer.com/article/10.1007/s10714-023-03094-8"],
 ", ",
 ButtonBox["doi:10.1007/s10714-023-03094-8",
  BaseStyle->"Hyperlink",
  ButtonData->{
    URL["https://doi.org/10.1007/s10714-023-03094-8"], None},
  ButtonNote->"https://doi.org/10.1007/s10714-023-03094-8"],
 ", ",
 ButtonBox["arXiv:2110.02448",
  BaseStyle->"Hyperlink",
  ButtonData->{
    URL["https://arxiv.org/abs/2110.02448"], None},
  ButtonNote->"https://arxiv.org/abs/2110.02448"],
 " (February 2023)"
}], "Item",ExpressionUUID->"37babc3c-a6ba-4770-a12f-8f70f68483f8"],

Cell["You can also use the following BibTeX entry:", "Text",ExpressionUUID->"ddd0e633-4724-4d52-a786-dd91f877c626"],

Cell["\<\
@article{Shoshany_Wogan_2021,
    archiveprefix = {arXiv},
    author        = {Barak Shoshany and Jared Wogan},
    doi           = {10.1007/s10714-023-03094-8},
    eprint        = {2110.02448},
    journal       = {Gen. Relativ. Gravit.},
    number        = {44},
    title         = {{Wormhole Time Machines and Multiple Histories}},
    volume        = {55},
    year          = {2023}
}\
\>", "Program",ExpressionUUID->"c88abe10-8de6-4881-ad91-5b72da34c22d"]
}, Open  ]]
}, Open  ]]
},
WindowSize->{961, 1043},
WindowMargins->{{-6, Automatic}, {Automatic, -1}},
TrackCellChangeTimes->False,
FrontEndVersion->"13.2 for Microsoft Windows (64-bit) (January 30, 2023)",
StyleDefinitions->"Default.nb",
ExpressionUUID->"6344bb1f-01e3-4f15-8782-86356f021f97"
]
(* End of Notebook Content *)

(* Internal cache information *)
(*CellTagsOutline
CellTagsIndex->{}
*)
(*CellTagsIndex
CellTagsIndex->{}
*)
(*NotebookFileOutline
Notebook[{
Cell[CellGroupData[{
Cell[580, 22, 141, 1, 98, "Title",ExpressionUUID->"128c8a38-260f-4a0b-bee1-61dd7f591347"],
Cell[CellGroupData[{
Cell[746, 27, 127, 2, 56, "Chapter",ExpressionUUID->"b5fedb32-5b86-4e0f-89fe-39dfc90f809e"],
Cell[876, 31, 263, 5, 35, "Text",ExpressionUUID->"1eedf2d6-82ab-4a78-b665-ece06c2d6eb5"],
Cell[1142, 38, 115, 1, 35, "Text",ExpressionUUID->"0f3fefd7-1097-4235-b05f-66649dbe2102"],
Cell[1260, 41, 132, 1, 35, "Text",ExpressionUUID->"ee2eb3ff-67cb-4a5e-997e-4c3308a3e731"],
Cell[1395, 44, 123, 1, 35, "Text",ExpressionUUID->"983c837d-ef43-44b9-9655-a75bd8a9fa08"]
}, Open  ]],
Cell[CellGroupData[{
Cell[1555, 50, 124, 2, 56, "Chapter",ExpressionUUID->"2fbcbe8b-25e2-4792-865e-42e11a0fee5b"],
Cell[1682, 54, 269, 5, 35, "Text",ExpressionUUID->"97abd20c-4a3c-4e3a-be9f-16fabdf6f02d"],
Cell[1954, 61, 117, 1, 35, "Text",ExpressionUUID->"f0f80c1b-b452-4de7-8181-92a290cdf885"],
Cell[2074, 64, 132, 1, 35, "Text",ExpressionUUID->"153119a9-d132-4123-8f69-85801a69dc0d"],
Cell[2209, 67, 124, 1, 35, "Text",ExpressionUUID->"e9305b93-be80-4b6c-a1df-1c431e3a03db"],
Cell[2336, 70, 239, 3, 33, "Text",ExpressionUUID->"b03cb2e9-03d8-487e-83e0-7e23f62de090"],
Cell[2578, 75, 446, 12, 38, "Text",ExpressionUUID->"5c7de40a-f19e-4389-8010-06181f49f26e"],
Cell[CellGroupData[{
Cell[3049, 91, 29689, 742, 1999, "Input",ExpressionUUID->"aa53ef7f-35ca-4091-98e1-7bfb54074807"],
Cell[32741, 835, 15189, 336, 494, "Output",ExpressionUUID->"9851d958-78ef-4a26-be6b-c6d5e0f4d386"]
}, {2}]],
Cell[47942, 1174, 2994, 75, 110, "Text",ExpressionUUID->"3a4272e0-42e0-4307-9aed-ffb40e6d346f"],
Cell[50939, 1251, 456, 6, 81, "Text",ExpressionUUID->"cf56bd8d-9659-4d57-aea4-92a2d97fe774"],
Cell[51398, 1259, 736, 14, 127, "Text",ExpressionUUID->"74cd1ec7-149b-47e9-b5a4-91993f02053b"],
Cell[52137, 1275, 487, 11, 58, "Text",ExpressionUUID->"41c5156a-917a-4f15-9be5-49f1e9e1573a"],
Cell[52627, 1288, 104, 0, 35, "Text",ExpressionUUID->"32026af9-3b5e-427a-a8cd-c0d2bd0b99d0"],
Cell[52734, 1290, 886, 21, 53, "Item",ExpressionUUID->"37babc3c-a6ba-4770-a12f-8f70f68483f8"],
Cell[53623, 1313, 115, 0, 35, "Text",ExpressionUUID->"ddd0e633-4724-4d52-a786-dd91f877c626"],
Cell[53741, 1315, 475, 12, 219, "Program",ExpressionUUID->"c88abe10-8de6-4881-ad91-5b72da34c22d"]
}, Open  ]]
}, Open  ]]
}
]
*)