6
$\begingroup$

Samuel Inverse Graphing Calculator (http://www.xamuel.com/inverse-graphing-calculator.php) is a amazing tool. Whichever be your language, you can transform a sentence in an equation. I hav try with Yo. Here is the result --- after a copy since it gives only an image ---

f[x_, y_] := (y - 3 - Abs[x - 3])^2 ((x - 3)^2 + (y - 3) + 
 Sqrt[y^2 - 6 y + 9]^2)^2 ((x - 6)^2 + (y - 3)^2 - 1)^2 + (y^2 - 
6 y + 8 + Sqrt[y^4 - 12 y^3 + 52 y^2 - 96 y + 64])^2

Now I have tried to plot the contour of f[x, y]. Here is the best result I have been able to obtain with

ContourPlot[f[x, y] == 17.2, {x, 1, 7.4}, {y, 1.5, 5}]

It is far to be satisfacing. How to obtain the nice figures of xsamuels? An other question would be to know how he does to obtain the equation from the strings ?

$\endgroup$
9
$\begingroup$

First you should note that you copied the function down incorrectly. It should be

f[x_, y_] := (y - 3 - Abs[x - 3])^2 ((x - 3)^2 + (y - 3 + 
   Sqrt[y^2 - 6 y + 9])^2)^2 ((x - 6)^2 + (y - 3)^2 - 1)^2 + 
   (y^2 - 6 y + 8 + Sqrt[y^4 - 12 y^3 + 52 y^2 - 96 y + 64])^2

The function does not cross zero at the position of the lines, it only touches. For example here's a cross section at $y=2.5$

Plot[f[x, 2.5], {x, 1, 7.4}, PlotRange -> {0, 1000}]

enter image description here

ContourPlot struggles to find the zero contour because of this. There's a good description of this problem somewhere on the site but I can't find it.

As an alternative you could try something like this. First I use Reduce to solve for the position of the zero contour:

a = List @@ LogicalExpand@Reduce[f[x, y] == 0, {x, y}, Reals]

(* {x == 5 && y == 3, x == 7 && y == 3, x == 3 && 2 <= y && y <= 3, 
 y == 6 - x && x < 3 && 2 <= x, y == x && 3 < x && x <= 4, 
 y == 3 - Sqrt[-35 + 12 x - x^2] && 5 < x && x < 7, 
 y == 3 + Sqrt[-35 + 12 x - x^2] && 5 < x && x < 7} *)

Then for each term I extract the equalities (which will be a plottable contour) and the inequalities (which will be used as a region function)

b = {DeleteCases[#, Except[_Equal]], 
 Function @@ {{x, y}, DeleteCases[#, _Equal]}} & /@ a;

Finally plot each contour individually and combine with Show

Show[ContourPlot[#1, {x, 1, 7.4}, {y, 1.5, 5}, 
    RegionFunction -> #2] & @@@ b, AspectRatio -> Automatic]

enter image description here

$\endgroup$
5
$\begingroup$

Really just to amplify Simon Woods excellent answer: transforming $f(x,y)$ to a more manageable range (here with log):

Plot3D[Log[1 + f[x, y]], {x, 1, 8}, {y, 1.5, 5}, PlotPoints -> 50, 
 MaxRecursion -> 5, MeshFunctions -> {#3 &}, Mesh -> {{0.0005}}, 
 MeshStyle -> {Red, Thickness[0.03]}, Background -> Black, 
 Axes -> False, Boxed -> False, 
 PlotStyle -> {LightBlue, Opacity[0.6]}]

enter image description here

$\endgroup$
  • $\begingroup$ Splendid. It rests the last problem xsamuels starts from any sentence to find its equation $\endgroup$ – cyrille.piatecki Jun 27 '16 at 4:00

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.