It's not really a typical math question. Today, while studying graphs, I suddenly got inquisitive about whether there exists a function that could possibly draw a heart-shaped graph. Out of sheer curiosity, I clicked on Google, which took me to this page.
The page seems informative, and I am glad to learn certain new things! Now I am interested in drawing them by my own using Mathematica. So my question is: is it possible to draw them in Mathematica? If yes, please show me how.
9 Answers
You can plot Taubin's heart surface using ContourPlot3D:
ContourPlot3D[(2 x^2 + y^2 + z^2 - 1)^3 - (1/10) x^2 z^3 - y^2 z^3 == 0,
{x, -1.5, 1.5}, {y, -1.5, 1.5}, {z, -1.5, 1.5},
Mesh -> None, ContourStyle -> Opacity[0.8, Red]]
Consider the map $T \colon \mathbb R^2 \rightarrow \mathbb R^2, \ (x,y) \mapsto (x, y+ \sqrt{|x|})$. With a little examination, you can see that this will define a warping on the plane that will map the unit circle to a heart shaped curve:
So if you know that a parametrization for the circle is $(\cos(t),\ \sin(t)),\ t\in [-\pi,\pi]$, then the parametrization for its heart-shaped image would be $(\cos(t),\ \sin(t) + \sqrt{|\cos(t)|}),\ t\in [-\pi,\pi]$. You can plot the curve with the following Mathematica code:
ParametricPlot[{Cos[t], Sin[t] + Sqrt[Abs[Cos[t]]]}, {t, -Pi, Pi}]
A somewhat late addition (I only found my yellowed notebooks containing these just now):
$$\left(2(1+\cos\,\varphi)\sin^3 t\qquad 2\cos\,\theta\;\sin^2 t \sin\,\varphi+\sin\,\theta\cos\,t\left(\cos\,2t-2\cos\,\varphi\;\sin^2 t-3\right)\right)^T$$
is a two-parameter family of curves that generate heart shapes for some values of $\theta$ and $\varphi$. They were derived from projections of a skewed version of the nephroid.
Here for instance is the case $\theta=\pi/4,\quad \varphi=\pi/2$:
The following inputs will plot the following 6 hearts in the picture below respectively.
ContourPlot[(x^2 + y^2 - 1)^3 - x^2 y^3 == 0, {x, -1.5, 1.5}, {y, -1.5, 1.5}, MaxRecursion -> 5]
ContourPlot[x^2 + (y - (2 (x^2 + Abs[x] - 6))/(3 (x^2 + Abs[x] + 2)))^2 == 36, {x, -9, 9}, {y, -9, 9}, MaxRecursion -> 5]
ContourPlot[x^2 + (5/4 y - Sqrt[Abs[x]])^2 == 1, {x, -1.5, 1.5}, {y, -1.5, 1.5},MaxRecursion -> 5]
ContourPlot[0 == (Sqrt[1 - (Abs[x/5] - 1)^2] - y/5 + 3/4) (ArcCos[1 - Abs[x/5]] - \[Pi] - y/5 + 3/4), {x, -12, 12}, {y, -12, 12}, MaxRecursion -> 5]
PolarPlot[2 - 2 Sin[\[Theta]] + Sin[\[Theta]] Sqrt[Abs[Cos[\[Theta]]]]/(Sin[\[Theta]] + 1.4), {\[Theta], -2 \[Pi], 2 \[Pi]}, MaxRecursion -> 5]
ContourPlot3D[(x^2 + (9 y^2)/4 + z^2 - 1)^3 - x^2 z^3 - (9 y^2 z^3)/80 == 0, {x, -1.5, 1.5}, {y, -1.5, 1.5}, {z, -1.5, 1.5}]
I also came up with my own strictly algebraic equation that will plot the letters AB inside of a heart for my significant other. The equation is...
$ \left(\left(\left(\left| y\right| -\frac{29}{20}\right)^2+(x-1)^2\right)^2+18 \left(\left(\left| y\right| -\frac{29}{20}\right)^2+\left(x-\frac{219}{100}\right)^2\right)-8 \left(\left(x-\frac{5}{2}\right)^3-3 \left(x-\frac{39}{20}\right) \left(\left| y\right| -\frac{147}{100}\right)^2\right)-27\right) $ $ \left(\left(\left(x+\frac{7}{4}\right)^2+\left(\frac{2 y}{3}+\frac{1}{4}\right)^2\right)^2+\frac{9}{2} \left(\left(x+\frac{7}{4}\right)^2+\left(\frac{2 y}{3}+\frac{1}{4}\right)^2\right)-4 \left(\left(\frac{2 y}{3}+\frac{1}{4}\right)^3-\left(x+\frac{7}{4}\right)^2 \left(2 y+\frac{3}{2}\right)\right)-\frac{27}{16}\right) $ $ \left(\left(\left(x+\frac{7}{4}\right)^2+\left(\frac{2 y}{3}+\frac{3}{4}\right)^2\right)^2+18 \left(\left(x+\frac{7}{4}\right)^2+\left(\frac{2 y}{3}+\frac{3}{4}\right)^2\right)-8 \left(\left(\frac{2 y}{3}+\frac{3}{4}\right)^3-\left(x+\frac{7}{4}\right)^2 \left(2 y+\frac{9}{4}\right)\right)-27\right) $ $ \sqrt{\frac{\left| \sqrt{\left(\frac{2 y}{3}+2\right)^2+\left(x+\frac{11}{4}\right)^2}+\sqrt{\left(\frac{2 y}{3}+2\right)^2+\left(x+\frac{3}{4}\right)^2}-\frac{5}{2}\right| }{\sqrt{\left(x+\frac{11}{4}\right)^2+\left(\frac{2 y}{3}+2\right)^2}+\sqrt{\left(x+\frac{3}{4}\right)^2+\left(\frac{2 y}{3}+2\right)^2}-\frac{5}{2}}} \sqrt{\frac{\left| \sqrt{(y-2)^2+\left(x-\frac{9}{20}\right)^2}+\sqrt{(y+2)^2+\left(x-\frac{9}{20}\right)^2}-\frac{21}{5}\right| }{\sqrt{\left(x-\frac{9}{20}\right)^2+(y-2)^2}+\sqrt{\left(x-\frac{9}{20}\right)^2+(y+2)^2}-\frac{21}{5}}} $ $ \left(\sqrt{\left(-x-\frac{11}{4}\right)^2+\left(\frac{2 y}{3}+\frac{7}{4}\right)^2}+\sqrt{\left(-x-\frac{3}{4}\right)^2+\left(\frac{2 y}{3}+\frac{7}{4}\right)^2}-\frac{5}{2}\right) $ $ \left(\sqrt{\left(x-\frac{1}{2}\right)^2+(y-2)^2}+\sqrt{\left(x-\frac{1}{2}\right)^2+(y+2)^2}-\frac{21}{5}\right) $ $ \left(\left((\left| y\right| +1)^2+(x-2)^2\right)^2-19 \left((\left| y\right| +1)^2-(x-2)^2\right)\right) $ $ \left(\left(-\sqrt{\left| \frac{x}{2}\right| }+\frac{3 y}{10}+\frac{9}{10}\right)^2+\frac{x^2}{20}-5\right) = 0 $
The mathematica code is...
ContourPlot[0 == (x^2/20 + ((3 y)/10 + 9/10 - Sqrt[Abs[x/2]])^2 -
5) ((((2 y)/3 + 1/4)^2 + (x + 7/4)^2)^2 +
9/2 (((2 y)/3 + 1/4)^2 + (x + 7/4)^2) - 27/16 -
4 (((2 y)/3 + 1/4)^3 - (2 y + 3/2) (x + 7/4)^2)) (((x + 7/
4)^2 + ((2 y)/3 + 3/4)^2)^2 +
18 ((x + 7/4)^2 + ((2 y)/3 + 3/4)^2) - 27 -
8 (((2 y)/3 + 3/4)^3 - (2 y + 9/4) (x + 7/4)^2)) (Sqrt[((2 y)/
3 + 7/4)^2 + (-x - 11/4)^2] +
Sqrt[((2 y)/3 + 7/4)^2 + (-x - 3/4)^2] - 5/
2) \[Sqrt](Abs[
Sqrt[((2 y)/3 + 2)^2 + (x + 11/4)^2] +
Sqrt[((2 y)/3 + 2)^2 + (x + 3/4)^2] - 5/
2]/(Sqrt[((2 y)/3 + 2)^2 + (x + 11/4)^2] +
Sqrt[((2 y)/3 + 2)^2 + (x + 3/4)^2] - 5/
2)) ((((Abs[y] + 1)^2 + (x - 2)^2)^2 -
19 ((Abs[y] + 1)^2 - (x - 2)^2))) (((x - 1)^2 + (Abs[y] - 29/
20)^2)^2 + 18 ((x - 219/100)^2 + (Abs[y] - 29/20)^2) - 27 -
8 ((x - 5/2)^3 - 3 (x - 39/20) (Abs[y] - 147/100)^2)) (Sqrt[(x -
1/2)^2 + (y - 2)^2] + Sqrt[(x - 1/2)^2 + (y + 2)^2] - 21/
5) (Sqrt[
Abs[Sqrt[(x - 9/20)^2 + (y - 2)^2] +
Sqrt[(x - 9/20)^2 + (y + 2)^2] - 21/5]/(
Sqrt[(x - 9/20)^2 + (y - 2)^2] + Sqrt[(x - 9/20)^2 + (y + 2)^2] -
21/5)]), {x, -12, 12}, {y, -12, 12}, MaxRecursion -> 7]
and the graph is...
When using the ContourPlot function in Mathematica there are issues and you may get some noise. So your image may not be as clean as mine. Also it will take a while to plot it at MaxRecursion->7 so stand by.
Inigo Quilez has found a polar plot of a heart that doesn't require any of trigonometric functions:
polar plot r = (0.322515 * abs(theta)^3 - 2.22907 * abs(theta)^2 + 4.13803 * abs(theta))/(6.0 - 1.59155 * abs(theta)), theta=-pi to pi
A three-dimensional space curve with the shape of a red heart:
The Mathematica code for the image above is:
ParametricPlot3D[{Cos[u]*(4*Sqrt[1 - v^2]*Sin[Abs[u]]^Abs[u]), v,
Sin[u]*(4*Sqrt[1 - v^2]*Sin[Abs[u]]^Abs[u])},
{u, -Pi, Pi}, {v, -1, 1}, Axes -> None, Mesh -> False,
Boxed -> False,
PlotStyle -> {Red, Specularity[White, 10]}]
3D red heart with Mesh and lines:
Mathematica code for the image above:
ParametricPlot3D[{Cos[u]*(4*Sqrt[1 - v^2]*Sin[Abs[u]]^Abs[u]), v,
Sin[u]*(4*Sqrt[1 - v^2]*Sin[Abs[u]]^Abs[u])}, {u, -Pi,
Pi}, {v, -0.97, 0.97}, PlotPoints -> 50, Axes -> None,
Boxed -> False,
PlotStyle ->
Directive[Glow[Red], Specularity[White, 30], Opacity[0.15]],
Mesh -> 50, Background -> Black, MeshStyle -> {Blue, Red},
Lighting -> {{"Directional", Yellow, {{1.5, 1.5, 5}, {1.5, 1.5, 0}},
Pi/6}}]
A variation on the use of the Taubin heart surface with hue:
Mathematica code for the last image above:
ContourPlot3D[(-1/10) x^2 z^3 -
y^2 z^3 + (2 x^2 + y^2 + z^2 - 1)^3 == 0, {x, -1.2, 1.2}, {y, -1.4,
1.4}, {z, -1.5, 1.5}, Mesh -> False, PlotPoints -> 60,
Axes -> None, Boxed -> False,
ContourStyle -> Directive[Opacity[0.5], Red],
ColorFunction -> Function[{x, y, z, f}, Hue[z]]]
For more customized heart images, see the post in my website/blog:
This is really about plotting polar plots, parametric plots and implicitly defined functions in Mathematica.
This is the info on how to draw polar plots
Parametric plots
This provides info on implicit plots
Here is a screen shot from this equation on Wolfram Alpha. I don't have a license for Mathematica.
(x^2+y^2-1)^3 = x^2
