8
$\begingroup$

I've read Cool Graphs of Implicit Equations recently. In the article, it mentioned a software GrafEq which can draw graphs of arbitrary implicit equations. For example,

enter image description here

And I've tried several equations in Mathematica, it failed to give a same graph.

ContourPlot[Exp[Sin[x] + Cos[y]] == Sin[Exp[x + y]], {x, -10, 10}, {y, -10, 10}]

enter image description here

And in GrafEq's page, it says:

“ All software packages, except [GrafEq 2.09], produced erroneous graphical results. ... [GrafEq 2.09] demonstrated its graphical sophistication over all the other packages investigated.” — Michael J. Bossé and N. R. Nandakumar, The College Mathematics Journal

(The other software packages were MathCad 8, Mathematica 4, Maple V, MATLAB 5.3, and Derive 4.11.)

I want to know if I missed some techniques in Mathematica which can handle these equation drawing? Or it's really a 'weakness' of Mathematica in this area?


Edit:

In the link: http://www.peda.com/grafeq/description.html:

The program also features successive refinement plotting, which deletes regions of the plane that do not contain solutions, revealing the regions that do contain solutions. Plotting is completed by proving which pixels contain solutions. This technique enables the graphing of implicit relations, in which no single variable can be readily isolated. Such relations cannot be graphed at all by the typical computer graphing utility or graphics calculator. Successive refinement plotting also permits the plotting of singularities.

It seems it judges pixel by pixel, if the pixel's (x,y) is the solution of the equation, then it will be colored. Then what Mathematica's method to draw such equations? Does it have a similar mode we can choose when drawing such graph?

Now, I think I should make my questions clear:

  1. How Mathematica handle such drawings.
  2. How GrafEq handle that, I think I've got some clues, but not sure.
  3. How to get the same result with Mathematcia?
$\endgroup$
  • $\begingroup$ I hope you understand you changed the meaning of your question completely with your last edit. You may at least say so, for the people that has been working for an hour trying to help you deserve that. $\endgroup$ – Dr. belisarius Dec 20 '14 at 8:53
  • $\begingroup$ @belisarius: Thanks for your answer and your suggestion. I'm also trying hard to figure out the answer. So when I find the new clues, I think I should share it to others. I think this will be helpful to get the answer quick. $\endgroup$ – diverger Dec 20 '14 at 8:58
  • $\begingroup$ @belisarius: I just want to know: 1>. How Mathematica handle such drawings. 2>. How GrafEq handle that (I think I've got some clues, see the editing. 3>. How to get the same result with Mathematcia? $\endgroup$ – diverger Dec 20 '14 at 9:01
  • $\begingroup$ Releated link, mathematica.stackexchange.com/questions/19590/… $\endgroup$ – chyanog Dec 22 '14 at 1:51
  • $\begingroup$ Anybody curious about the machinery of GrafEq should look at Tupper's paper and thesis. $\endgroup$ – J. M. will be back soon Mar 28 '17 at 16:05
11
$\begingroup$

In principle the same method could be used in Mathematica. The problem boils down to determining if a solution to $a=b$ exists somewhere inside each pixel. Here's an oversimplified approach where I calculate $a-b$ for 100 random points within the pixel and see if there are both positive and negative values. If there are, there must be a zero crossing somewhere inside the pixel.

pixelContainsSolution[x0_, y0_] :=
 (Max[#] > 0 && Min[#] < 0) &[
  Exp[Sin[#1] + Cos[#2]] - Sin[Exp[#1 + #2]] & @@@ 
   Transpose[{x0, y0} + RandomReal[{-0.05, 0.05}, {2, 100}]]]

Image[1 - Table[Boole@pixelContainsSolution[x, y],
   {x, -10, 10, 0.1}, {y, -10, 10, 0.1}]]

enter image description here

It's pretty slow - to obtain a nice high resolution plot in a reasonable amount of time would need some optimisations.

Edit

Example of faster code:

data = Compile[{}, Block[{x = Range[-10, 10, 0.0025]},
        Exp[Outer[Plus, Sin[x], Cos[x]]] - Sin[Exp[Outer[Plus, x, x]]]]][];

Developer`PartitionMap[Sign[Max[#] Min[#]] &, data, {20, 20}] // Image
$\endgroup$
  • $\begingroup$ The second block of code produces a pretty respectable version of this image, more or less the same as the red one in the question. I would say Simon has a proof-of-concept that Mathematica can do whatever this GraphEq can do -- except it can also do plots that are not contour plots... and lots of other math. $\endgroup$ – Kellen Myers Dec 21 '14 at 3:39
  • $\begingroup$ @Simon: Can you use your method to plot $sin(sin(x)+cos(y))=cos(sin(x*y)+cos(x))$? I tried, but failed. I'm not very familiar with Mathematica. $\endgroup$ – diverger Dec 21 '14 at 12:06
9
$\begingroup$

That's the best I could go with Mathematica 10.0.2, with PlotPoints->50 and MaxRecursion->4.

ContourPlot[
 E^(Sin[x] + Cos[y]) == Sin[E^(x + y)], {x, -10, 10}, {y, -10, 10}, 
 Axes -> True, ImageSize -> Large, PlotPoints -> 50, 
 MaxRecursion -> 4]

The rendering took about 1 hour with Mathematica eating all my 16Gb Ram. (I'll never try something like this again!)

enter image description here

EDIT

Following Mr.Wizard comment here's a better plot and a better solution. It took just 1m 12s but the Ram utilization peaked to 13GB (beware!):

ContourPlot[
 E^(Sin[x] + Cos[y]) == Sin[E^(x + y)], {x, -10, 10}, {y, -10, 10}, 
 Axes -> True, ImageSize -> Large, PlotPoints -> 2000, 
 MaxRecursion -> 0]

enter image description here

$\endgroup$
  • $\begingroup$ +1 for the computational expense to demonstrate a result $\endgroup$ – Mr.Wizard Dec 21 '14 at 9:24
  • $\begingroup$ Incidentally I get a fairly similar result much faster with: ContourPlot[E^(Sin[x] + Cos[y]) == Sin[E^(x + y)], {x, -10, 10}, {y, -10, 10}, Axes -> True, ImageSize -> Large, MaxRecursion -> 0, PlotPoints -> 1000] $\endgroup$ – Mr.Wizard Dec 21 '14 at 9:41
  • $\begingroup$ @Mr.Wizard I can confirm your result. So I've learned that MaxRecursion is useless in this case and it just slows down the calculation and eat memory. Even MaxRecursion -> 0, PlotPoints -> 2000 works in a reasonable time (1m 12s) but with a peak of 13GB of Ram used (!). $\endgroup$ – Luca M Dec 21 '14 at 10:02
7
$\begingroup$

The following is a answer to the original question, without accounting for the last edit.

The red plot is nice,but I'm not sure what they are trying to show. Inside the solid colored regions the frequency is very high, but the function isn't constant, as an easy check can show:

f[x_, y_] := Exp[Sin[x] + Cos[y]] - Sin[Exp[x + y]]
GraphicsRow[{Plot[f[x, 5], {x, -10, 10}],  Plot[f[x, 5], {x, 4.999, 5}]}]

Mathematica graphics Mathematica graphics

So the red plot is just a simplification of the real one which is better shown in the Mathematica output.

$\endgroup$
  • 1
    $\begingroup$ I think you've misunderstood the plot. As your first plot shows, $f$ has a very large number of zero crossings in the solid region. Therefore, ideally a very large number of contours should be drawn there. If you draw a very large number of contours in a small area, it looks like a solid region, as the red plot correctly shows. It's the Mathematica plot which incorrectly suggests that, for example, there are no zero crossings in the neighbourhood of $(4,2)$. $\endgroup$ – Rahul Dec 20 '14 at 9:59
  • $\begingroup$ @Rahul A solid filling represents in my book a constant valued function. Increasing PlotPoints and MaxRecursion makes Mma performs better, as always $\endgroup$ – Dr. belisarius Dec 21 '14 at 0:57
5
$\begingroup$
data=Compile[{},With[{y=Range[-10,10,0.006]},
  Table[UnitStep[(E^(Sin[x]+Cos[y])-Sin[E^(x+y)])],{x,y}]]][];//AbsoluteTiming
ArrayPlot[data,DataReversed->True]

enter image description here

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