🗎 Code for the
hyperspherical inflationary universe spacetime diagrams
(* | Closed & inflationary universe | Simon Tyran, Vienna | flrw.yukterez.net | *) set = {"GlobalAdaptive", "MaxErrorIncreases"->100, Method->"GaussKronrodRule"}; (* Integration Rule *) n = 100; (* Recursion Depth *) int[f_, {x_, xmin_, xmax_}] := (* Integral *) NIntegrate[f, {x, xmin, xmax}, Method->set, MaxRecursion->n, WorkingPrecision->wp]; if[F_] := If[ΩΛ<=0, Nothing, If[ΩK>0, Nothing, F]] (* Event Horizon Check *) wp = 34; (* Working Precision *) im = 320; (* Image Size *) tmax = 500 Gyr; (* Integration Limit *) ηmax = 40; (* Conformal Plot Range *) prmax = 50; ptmax = 40; (* Regular Plot Range *) c = 299792458 m/sek; (* Lightspeed *) G = 667384*^-16 m^3 kg^-1 sek^-2; (* Newton Constant *) Gyr = 10^7*36525*24*3600 sek; (* Billion Years *) Glyr = Gyr*c; (* Billion Lightyears *) Mpc = 30856775777948584200000 m; (* Megaparsec *) kB = 13806488*^-30 kg m^2/sek^2/K; (* Boltzmann Constant *) h = 662606957*^-42 kg m^2/sek; (* Planck Constant *) ρc[H_] := 3H^2/8/π/G; (* Critical Density *) ρR = 8π^5 kB^4 T^4/15/c^5/h^3; (* Radiation Density *) ρΛ = ρc[H0] ΩΛ; (* Dark Energy Density *) T = 2725/1000 K; (* CMB Temperature *) kg = m = sek = 1; (* SI Units *) ΩR = 0; (* Radiation Proportion including Neutrinos *) ΩM = 0; (* Matter Proportion including Dark Matter *) ΩΛ = 2; (* Dark Energy Proportion *) ΩT = ΩR+ΩM+ΩΛ; (* Total Density over Critical Density *) ΩK = 1-ΩT; (* Curvature Density *) rK = c/H0/Sqrt[-ΩK]; (* Curvature Radius *) H0 = 67150 m/Mpc/sek; (* Hubble Constant *) H[a_] := H0 Sqrt[ΩK/a^2+ΩΛ]; (* Hubble Parameter *) Η[t_] := H0 Tanh[H0 t Sqrt[ΩΛ]] Sqrt[ΩΛ]; (* Η ≠ H, Η[t] is the Greek Letter *) a0 = Sqrt[1-1/ΩΛ]; (* Initial Scale Factor *) a[t_] := Sqrt[1-1/ΩΛ] Cosh[H0 t Sqrt[ΩΛ]]; (* Scale Factor a by Time t *) т[a_] := int[1/A/H[A], {A, 0, a}]; (* Time t by Scale Factor a *) rP[t_] := a[t] int[c/a[т], {т, 0, t}]; (* Proper Particle Horizon by t *) rp[a_] := a int[c/A^2/H[A], {A, a0, a}]; (* Proper Particle Horizon by a *) RP[t_] := int[c/a[т], {т, 0, t}]; (* Comoving Particle Horizon by t *) Rp[a_] := int[c/A^2/H[A], {A, a0, a}]; (* Comoving Particle Horizon by a *) rE[t_] := if[a[t] int[c/a[т], {т, t, tmax}]]; (* Proper Event Horizon by t *) re[α_] := if[α int[c/A^2/H[A], {A, α, a[tmax]}]]; (* Proper Event Horizon by a *) RE[t_] := if[int[c/a[т], {т, t, tmax}]]; (* Comoving Event Horizon by t *) Rε[α_] := if[int[c/A^2/H[A], {A, α, a[tmax]}]]; (* Comoving Event Horizon by a *) rL[t0_, t_] := a[t] int[c/a[т], {т, t, t0}]; (* Proper Light Cone by t *) rl[a0_, a_] := a int[c/A^2/H[A], {A, a, a0}]; (* Proper Light Cone by a *) RL[t0_, t_] := int[c/a[т], {т, t, t0}]; (* Comoving Light Cone by t *) Rl[a0_, a_] := int[c/A^2/H[A], {A, a, a0}]; (* Comoving Light Cone by a *) rH[t_] := c/Η[t]; (* Proper Hubble Radius by t *) rh[a_] := c/H[a]; (* Proper Hubble Radius by a *) RH[t_] := c/Η[t]; (* Comoving Hubble Radius by t *) Rh[a_] := c/H[a]/a; (* Comoving Hubble Radius by a *) t0 = Re[t/.FindRoot[a[t]-1, {t, 10 Gyr}]]; ti = t Gyr; τi = τ Gyr; "t0"->t0/Gyr "Gyr" (* Current Time *) f = N[Join[{{0, a0}}, (* Scale Factor by Comoving Particle Horizon *) ParallelTable[{Rp[Ã]/Glyr, Ã}, {Ã, a0 + 1/100, 100, 1/100}], ParallelTable[{Rp[Ã]/Glyr, Ã}, {Ã, 101, 1000, 1}]]] ā = Quiet[Interpolation[f]]; Ť[η_] := Quiet[FindRoot[RP[τ Gyr]/Glyr-η, (* t by η *) {τ, 1}, WorkingPrecision->wp, MaxIterations->1000][[1, 2]]] (* ţ = Quiet[Interpolation[Join[{{0, 0}}, ParallelTable[{((Sin[η π/ηmax-π/2]+1) ηmax/2), Ť[((Sin[η π/ηmax-π/2]+1) ηmax/2)]}, {η, ηmax/im, ηmax, ηmax/im}]]]]; *) rpN = Rp[1]/Glyr; Rpn = Rp[tmax]/Glyr; "PROPER DISTANCES, f(t)" pt = Quiet[Plot[ {rH[τi]/Glyr, rP[τi]/Glyr, rE[τi]/Glyr, π rK a[τi]/Glyr}, {τ, 0, ptmax}, Frame->True, AspectRatio->prmax/ptmax, FrameTicks->None, PlotRange->{{0, ptmax}, {0, prmax}}, PlotStyle->{{Thickness[0.005]}, {Darker[Green], Thickness[0.005]}, {Purple, Thickness[0.005]}, {Red, Thickness[0.005]}}, ImageSize->im, Filling->Top, FillingStyle->Opacity[0.1], ImagePadding->1, GridLines->{{}, {}}]]; plot1[t_] := Rasterize[Grid[{{Rotate[Quiet[Show[Plot[ {rL[ti, τi]/Glyr, -rL[ti, τi]/Glyr}, {τ, 0, ptmax}, Frame->True, AspectRatio->prmax/ptmax, FrameTicks->None, PlotRange->{{0, ptmax}, {0, prmax}}, PlotStyle->{{Orange, Thickness[0.005]}, {{Orange, Thickness[0.005]}, Dashed}}, ImageSize->im, Filling->Top, FillingStyle->Opacity[0.1], ImagePadding->1, GridLines->{{}, {}}], pt]], 90 Degree]}}]]; Do[Print[plot1[t]], {t, {t0/Gyr}}] plot2 = Rasterize[Grid[{{Rotate[Quiet[Plot[ Join[{0}, Table[a[τ Gyr] n^(7/2)/250, {n, 4, 55, 1}]], {τ, 0, ptmax}, Frame->True, AspectRatio->prmax/ptmax, FrameTicks->None, PlotRange->{{0, ptmax}, {0, prmax}}, PlotStyle->Table[{Dashing->Large, Thickness[0.005], Gray}, {n, 1, 100}], ImageSize->im, ImagePadding->1]], 90 Degree]}}]] "COMOVING DISTANCES, f(t)" ct = Quiet[Plot[ {RH[τi]/Glyr, RP[τi]/Glyr, RE[τi]/Glyr, π rK/Glyr}, {τ, 0, ptmax}, Frame->True, AspectRatio->prmax/ptmax, FrameTicks->None, PlotRange->{{0, ptmax}, {0, prmax}}, PlotStyle->{{Thickness[0.005]}, {Darker[Green], Thickness[0.005]}, {Purple, Thickness[0.005]}, {Red, Thickness[0.005]}}, ImageSize->im, Filling->Top, FillingStyle->Opacity[0.1], ImagePadding->1, GridLines->{{}, {}}]]; plot3[t_] := Rasterize[Grid[{{Rotate[Quiet[Show[Plot[ {RL[ti, τi]/Glyr, -RL[ti, τi]/Glyr}, {τ, 0, ptmax}, Frame->True, AspectRatio->prmax/ptmax, FrameTicks->None, PlotRange->{{0, ptmax}, {0, prmax}}, PlotStyle->{{Orange, Thickness[0.005]}, {{Orange, Thickness[0.005]}, Dashed}}, ImageSize->im, Filling->Top, FillingStyle->Opacity[0.1], ImagePadding->1, GridLines->{{}, {}}], ct]], 90 Degree]}}]]; Do[Print[plot3[t]], {t, {t0/Gyr}}] plot4 = Rasterize[Grid[{{Rotate[Quiet[Plot[ Join[{0}, Table[n, {n, 10, 100, 10}]], {τ, 0, ptmax}, Frame->True, AspectRatio->prmax/ptmax, FrameTicks->None, PlotRange->{{0, ptmax}, {0, prmax}}, PlotStyle->Table[{Dashing->Large, Thickness[0.005], Gray}, {n, 1, 100}], ImageSize->im, ImagePadding->1]], 90 Degree]}}]] "PROPER DISTANCES, f(a)" pa = Quiet[Plot[ {rh[α]/Glyr, rp[α]/Glyr, re[α]/Glyr, π rK α/Glyr}, {α, a0, prmax Gyr/t0}, Frame->True, AspectRatio->prmax/ptmax, FrameTicks->None, PlotRange->{{a0, prmax Gyr/t0}, {0, prmax}}, PlotStyle->{{Thickness[0.005]}, {Darker[Green], Thickness[0.005]}, {Purple, Thickness[0.005]}, {Red, Thickness[0.005]}}, ImageSize->im, Filling->Top, FillingStyle->Opacity[0.1], ImagePadding->1, GridLines->{{}, {}}]]; plot5[å_] := Rasterize[Grid[{{Rotate[Quiet[Show[Plot[ {rl[å, α]/Glyr, -rl[å, α]/Glyr}, {α, a0, prmax Gyr/t0}, Frame->True, AspectRatio->prmax/ptmax, FrameTicks->None, PlotRange->{{a0, prmax Gyr/t0}, {0, prmax}}, PlotStyle->{{Orange, Thickness[0.005]}, {{Orange, Thickness[0.005]}, Dashed}}, ImageSize->im, Filling->Top, FillingStyle->Opacity[0.1], ImagePadding->1, GridLines->{{}, {}}], pa]], 90 Degree]}}]]; Do[Print[plot5[å]], {å, {1}}] plot6 = Rasterize[Grid[{{Rotate[Quiet[Plot[ Join[{0}, Table[α n^(7/2)/250, {n, 4, 55, 1}]], {α, a0, prmax Gyr/t0}, Frame->True, AspectRatio->prmax/ptmax, FrameTicks->None, PlotRange->{{a0, prmax Gyr/t0}, {0, prmax}}, PlotStyle->Table[{Dashing->Large, Thickness[0.005], Gray}, {n, 1, 100}], ImageSize->im, ImagePadding->1]], 90 Degree]}}]] "COMOVING DISTANCES, f(a)" ca = Quiet[Plot[ {Rh[α]/Glyr, Rp[α]/Glyr, Rε[α]/Glyr, π rK/Glyr}, {α, a0, prmax Gyr/t0}, Frame->True, AspectRatio->prmax/ptmax, FrameTicks->None, PlotRange->{{a0, prmax Gyr/t0}, {0, prmax}}, PlotStyle->{{Thickness[0.005]}, {Darker[Green], Thickness[0.005]}, {Purple, Thickness[0.005]}, {Red, Thickness[0.005]}}, ImageSize->im, Filling->Top, FillingStyle->Opacity[0.1], ImagePadding->1, GridLines->{{}, {}}]]; plot7[å_] := Rasterize[Grid[{{Rotate[Quiet[Show[Plot[ {Rl[å, α]/Glyr, -Rl[å, α]/Glyr}, {α, a0, prmax Gyr/t0}, Frame->True, AspectRatio->prmax/ptmax, FrameTicks->None, PlotRange->{{a0, prmax Gyr/t0}, {0, prmax}}, PlotStyle->{{Orange, Thickness[0.005]}, {{Orange, Thickness[0.005]}, Dashed}}, ImageSize->im, Filling->Top, FillingStyle->Opacity[0.1], ImagePadding->1, GridLines->{{}, {}}], ca]], 90 Degree]}}]]; Do[Print[plot7[å]], {å, {1}}] plot8 = Rasterize[Grid[{{Rotate[Quiet[Plot[ Join[{0}, Table[n, {n, 10, 100, 10}]], {α, a0, prmax Gyr/t0}, Frame->True, AspectRatio->prmax/ptmax, FrameTicks->None, PlotRange->{{a0, prmax Gyr/t0}, {0, prmax}}, PlotStyle->Table[{Dashing->Large, Thickness[0.005], Gray}, {n, 1, 100}], ImageSize->im, ImagePadding->1]], 90 Degree]}}]] "CONFORMAL DIAGRAM, f(η)" cη = Quiet[Plot[ {Rh[ā[Ct]]/Glyr, Ct, If[Rpn>Ct, Rε[ā[Ct]]/Glyr, 0], π rK/Glyr}, {Ct, 0, ηmax}, Frame->True, AspectRatio->prmax/ηmax, FrameTicks->None, PlotRange->{{0, ηmax}, {0, prmax}}, PlotStyle->{{Thickness[0.005]}, {Darker[Green], Thickness[0.005]}, {Purple, Thickness[0.005]}, {Red, Thickness[0.005]}}, ImageSize->im, Filling->Top, FillingStyle->Opacity[0.1], ImagePadding->1, GridLines->{{}, {}}]]; plot9[η_] := Rasterize[Grid[{{Rotate[Quiet[Show[Plot[ {η-Ct, Ct-η}, {Ct, 0, ηmax}, Frame->True, AspectRatio->prmax/ηmax, FrameTicks->None, PlotRange->{{0, ηmax}, {0, prmax}}, PlotStyle->{{Orange, Thickness[0.005]}, {{Orange, Thickness[0.005]}, Dashed}}, ImageSize->im, Filling->Top, FillingStyle->Opacity[0.1], ImagePadding->1, GridLines->{{}, {}}], cη]], 90 Degree]}}]]; Do[Print[plot9[η]], {η, {rpN}}] plot10 = Rasterize[Grid[{{Rotate[Quiet[Plot[ Join[{0}, Table[n, {n, 10, 100, 10}]], {Ct, 0, ηmax}, Frame->True, AspectRatio->prmax/ηmax, FrameTicks->None, PlotRange->{{0, ηmax}, {0, prmax}}, PlotStyle->Table[{Dashing->Large, Thickness[0.005], Gray}, {n, 1, 100}], ImageSize->im, ImagePadding->1]], 90 Degree]}}]] s[text_] := Style[text, FontFamily->"Lucida Console", FontSize->36]