0
$\begingroup$

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

enter image description here

$\endgroup$
  • $\begingroup$ See also here and here. $\endgroup$ – corey979 Oct 18 '16 at 17:06
1
$\begingroup$

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.

$\endgroup$
  • $\begingroup$ 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. $\endgroup$ – Sjoerd Smit Oct 19 '16 at 13:53
0
$\begingroup$

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:

enter image description here

$\endgroup$
  • 1
    $\begingroup$ This works, but the plot-based approach seems much more efficient. $\endgroup$ – anderstood Nov 2 '16 at 20:04
0
$\begingroup$

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}]
$\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.