11
$\begingroup$

I am plotting the null geodesics for a Schwarzschild surface in Schwarzschild coordinates and would light to insert small future light-cones at the points of intersection to emphasize the tipping over of the lightcones as they did in this figure: enter image description here

The code I have so far is:

p = {-8, -5, 0}
Plot[{(r + 3 Log[Abs[r - 3]] + p), -(r + 3 Log[Abs[r - 3]] + p)}, {r,0, 10},PlotRange -> {0, 10},Ticks -> {{{3, Subscript[r, s]}}, {0}}, AxesLabel -> {r, ct},AxesStyle -> Arrowheads[Small], ImageSize -> Large]

Giving me the following figure: enter image description here

Is there a way to do this in mathematica, or should I just try to do it in paint?

$\endgroup$
0

1 Answer 1

5
$\begingroup$

You should not do it in paint, you should learn to build your own tools, and this can be done in Wolfram Mathematica.

You can add an Epilog to your Plot with a Triangleand a Disk at the correct coordinates.

Epilog -> {Red, 
  Triangle[Map[Plus[{4.8, 1.45}, #] &, {{0, 0}, {0.33, 1}, {-0.33, 1}}]], 
  Pink, Disk[{4.8, 1.45} + {0, 1}, {0.33, 0.1}]}

From your Plot

With[{p = {-8, -5, 0},sol = {4.8, 1.45}},
 Plot[{(r + 3 Log[Abs[r - 3]] + p), -(r + 3 Log[Abs[r - 3]] + p)}, {r,
    0, 10}, PlotRange -> {0, 10}, 
  Ticks -> {{{3, Subscript["r", s]}}, {0}}, AxesLabel -> {r, ct}, 
  AxesStyle -> Arrowheads[Small], ImageSize -> Large, 
  Epilog -> {Red, 
    Triangle[Map[Plus[sol, #] &, {{0, 0}, {0.33, 1}, {-0.33, 1}}]], 
    Pink, Disk[sol + {0, 1}, {0.33, 0.1}]}]
 ]

Mathematica graphics

Obviously you will need to find and define the points and triangle sizes. That also can be done programmatically in Mathematica by finding the intersections and the slopes at the intersections.

Finding Solutions

sols = N@DeleteDuplicates[
    Flatten[
     Quiet@Select[
       Map[
        ReplaceAll[{r, #[[1]], 1/D[#[[1]], r], 1/D[#[[2]], r]}, 
          NSolve[Equal @@ #, r, Reals]] &, 
        Permutations[
         Flatten[{(r + 3 Log[Abs[r - 3]] + 
              p), -(r + 3 Log[Abs[r - 3]] + p)} /. 
           p -> {-8, -5, 0}], {2}]]
       , NumberQ[#[[1, 2]]] &
       ], 1]] /. {Abs'[x_?Negative] -> -1, Abs'[x_?Positive] -> 1}


With[{p = {-8, -5, 0}},
 Plot[{(r + 3 Log[Abs[r - 3]] + p), -(r + 3 Log[Abs[r - 3]] + p)}, {r,
    0, 10}, PlotRange -> {0, 10}, 
  Ticks -> {{{3, Subscript["r", s]}}, {0}}, AxesLabel -> {r, ct}, 
  AxesStyle -> Arrowheads[Small], ImageSize -> Large,
  Epilog -> {
    Darker[Yellow]
    , Table[
     Triangle[
      Map[Plus[sol[[1 ;; 2]], #] &, {{0, 0}, {sol[[3]], 1}, {sol[[4]],
          1}}]], {sol, sols}]
    , Yellow, EdgeForm[Thin]
    , Table[
     Disk[sol[[1 ;; 2]] + {0, 1}, {Abs[Subtract @@ (sol[[{4, 3}]])]/2,
        0.1}], {sol, sols}]
    }]
 ]

Mathematica graphics

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.