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 ?

Improve this question
$\endgroup$

2 Answers 2

Reset to default
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

Improve this answer
$\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

Improve this answer
$\endgroup$
1
  • $\begingroup$ Splendid. It rests the last problem xsamuels starts from any sentence to find its equation $\endgroup$ Commented Jun 27, 2016 at 4:00

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.