Inserting cones at intersection points two curves

Question

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:

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:

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

Answer 1

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}]}]
 ]

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}]
    }]
 ]