10
$\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$
  • $\begingroup$ There are things to do after your question is answered. It's a good idea to stay vigilant for some time, better approaches may come later improving over previous replies. Experienced users may point alternatives, caveats or limitations. New users should test answers before voting and wait 24 hours before accepting the best one. Participation is essential for the site, please come back to do your part tomorrow $\endgroup$ – rhermans May 15 '17 at 12:20
4
$\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, privacy policy and cookie policy

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