# Inserting cones at intersection points two curves

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?

• 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 May 15, 2017 at 12:20

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


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