obtain a list of values

Question

I used the method to find solutions on the graph t1 and t2

Clear[q, r]
q[t1_, t2_] := 
 0.25*(2*(Cos[t1] - Cos[t2])/(t2 - t1) - 2*Sin[t1])^4 + 
  0.25 (-Cos[t1] + (Sin[t2] - Sin[t1])/(t2 - t1))^4
r[t1_, t2_, En_] := 
 0.25` ((2 (Cos[t1] - Cos[t2]))/(-t1 + t2) - 2 Sin[t2])^4 + 
  0.25` (-Cos[t2] + (-Sin[t1] + Sin[t2])/(-t1 + t2))^4 - En
Show[{ContourPlot[{q[t1, t2] == 1, r[t1, t2, 0.4] == 0}, {t1, -\[Pi], 
    2*\[Pi]}, {t2, 0, 10 \[Pi]}, 
   ContourStyle -> {Lighter[Brown, .7], GrayLevel[.7]}], 
  ContourPlot[
   q[t1, t2] == 1, {t1, -\[Pi], 2*\[Pi]}, {t2, 0, 10 \[Pi]}, 
   ContourStyle -> None, 
   MeshFunctions -> Function[{t1, t2}, r[t1, t2, 0.4]], Mesh -> {{0}},
    MeshStyle -> Directive[Red, AbsolutePointSize[4.5]]]}]

Please, Could you tell me, Can I get the node values (red dots) in the form of values of t1 and t2 or how I can make a plot E(t2)?

Ee[t1_, t2_] := 0.25 ((2 (Cos[t1] - Cos[t2]))/(-t1 + t2) - 2 Sin[t2])^4 + 
  0.25 (-Cos[t2] + (-Sin[t1] + Sin[t2])/(-t1 + t2))^4

Sjoerd Smit · Answer 1 · 2016-10-19T13:51:19.150

If you literally want the points that show up in the plot, try and rip them out of the GraphicsComplex that pops up in the FullForm of your plot. Here's an example:

Clear[q, r];
q[t1_, t2_] := 
 0.25*(2*(Cos[t1] - Cos[t2])/(t2 - t1) - 2*Sin[t1])^4 + 
  0.25 (-Cos[t1] + (Sin[t2] - Sin[t1])/(t2 - t1))^4;
r[t1_, t2_, En_] := 
 0.25` ((2 (Cos[t1] - Cos[t2]))/(-t1 + t2) - 2 Sin[t2])^4 + 
  0.25` (-Cos[t2] + (-Sin[t1] + Sin[t2])/(-t1 + t2))^4 - En;
Module[{plot = 
 Show[{ContourPlot[{q[t1, t2] == 1, 
   r[t1, t2, 0.4] == 0}, {t1, -\[Pi], 2*\[Pi]}, {t2, 0, 10 \[Pi]},
   ContourStyle -> {Lighter[Brown, .7], GrayLevel[.7]}], 
 ContourPlot[
  q[t1, t2] == 1, {t1, -\[Pi], 2*\[Pi]}, {t2, 0, 10 \[Pi]}, 
  ContourStyle -> None, 
  MeshFunctions -> Function[{t1, t2}, r[t1, t2, 0.4]], 
  Mesh -> {{0}}, 
  MeshStyle -> Directive[Red, AbsolutePointSize[4.5]]]}],
points , index
},
points = plot[[1, 2, 1]];
index = Flatten@
  Cases[
    plot[[1, 2, 2]], 
    Point[{x___?NumberQ}] :> {x}, {0, \[Infinity]}];
    points[[index]]
]

I did some manual inspection to find out where the points you're interested in are hiding in the plot, but with some smart pattern matching you can probably generalise this example.

Sorry to hear that. I added left out the function definitions before because I was in kind of a hurry, but I now added them for convenience. For me this code now definitely works in a fresh kernel. — Sjoerd Smit, Oct 19 '16 at 13:53

Nicholas G · Answer 2 · 2016-10-18T15:36:10.187

0

Here is what I did, I think it does what you want but I am not sure I get the same number of points, a smaller step might get more (reduce .02 to something smaller for a much greater delay):

sols1 = DeleteDuplicates@{t1, t2} /.Table[
FindRoot[{q[t1, t2] == 1, 
     r[t1, t2, 0.4] == 0}, {{t1, z1}, {t2, z2}}],
   {z1, -\[Pi], 2*\[Pi], .02}, {z2, 0, 10 \[Pi], .02}];

After that long calculation, I show the points:

    Show@Graphics[
      Point@sols1,
      Axes -> True,
      PlotRange -> {{-\[Pi], 2 \[Pi]}, {0, 10 \[Pi]}},
      AspectRatio->1]

and I get:

edited Oct 18 '16 at 15:36

answered Oct 18 '16 at 15:09

Nicholas G

1,981
10
15

1

This works, but the plot-based approach seems much more efficient. – anderstood Nov 02 '16 at 20:04

score 0 · Answer 3 · answered Nov 02 '16 at 20:02

Simply save the graph as plot (plot = Show[...) and extract the points with:

pts = Cases[Normal@plot, Point[a_] :> a, Infinity]
ListPlot[pts]

Mathematica graphics

You can then refine the points using FindRoot and the initial conditions given by the plot, with

Table[{t1, t2} /. FindRoot[{q[t1, t2] - 1, r[t1, t2, 0.4]},
  {{t1, pts[[i, 1]]}, {t2, pts[[i, 2]]}}, AccuracyGoal -> Infinity], 
  {i, Length@pts}]

obtain a list of values

3 Answers3