La ecuación del logo de Batman en Mathematica

Hace ya unas semanas apareció por internet una imagen con una ecuación cuyas soluciones tenían como representación gráfica, en teoría, el logo de Batman. Aquí la tenemos:

Hasta donde yo sé el tema comenzó en Reddit. Blogs de todo el mundo se hicieron eco de este asunto, y durante un tiempo se dudó de la veracidad del mismo: ¿de verdad las soluciones de esa ecuación representaban el logo de Batman?

Pues sí. Y fue en StackExchange donde se encargaron de comprobarlo, representando de forma aislada cada una de las partes de la misma y explicándolas todas muy claramente.

Lo que vamos a hacer en este post es explicar cómo realizar esta representación en Mathematica. Los datos los he tomado de este post de Playing with Mathematica (por cierto, blog muy recomendable para los interesados en este programa), donde Sol Lederman (que también lleva Wild About Math) nos comenta el trabajo de Heike Gramberg en este sentido publicado en este grupo de Google.

Heike divide la ecuación en seis partes (los seis paréntesis grandes que aparecen en la imagen), define cada una de ellas por separado y después las representa todas juntas. Nosotros vamos a seguir el mismo camino.

Parte1

Código Mathematica:

pl1 = ContourPlot[((x/7)^2 + (y/3)^2 – 1) == 0, {x, -8, 8}, {y, -5,
5}, RegionFunction -> ((Abs[#1] > 3 && #2 > -(3 Sqrt[33])/7) &)]

Representación:

Parte 2

Código Mathematica:

pl2 = ContourPlot[(Abs[x/2] – ((3 Sqrt[33] – 7)/112) x^2 – 3 +
Sqrt[1 – (Abs[Abs[x] – 2] – 1)^2] – y) == 0, {x, -7, 7}, {y, -3,
3}]

Representación:

Parte 3

Código Mathematica:

pl3 = ContourPlot[(9 – 8 Abs[x] – y) == 0, {x, -7, 7}, {y, -3, 3},
RegionFunction -> ((3/4 < Abs[#] < 1) &)]

Representación:

Parte 4

Código Mathematica:

pl4 = ContourPlot[(3 Abs[x] + 3/4 – y) == 0, {x, -7, 7}, {y, -3, 3},
RegionFunction -> ((1/2 < Abs[#1] < 3/4) &)]

Representación:

Parte 5

Código Mathematica:

pl5 = ContourPlot[(9/4 – y) == 0, {x, -7, 7}, {y, -3, 3},
RegionFunction -> ((Abs[#1] < 1/2) &)]

Representación:

Parte 6

Código Mathematica:

pl6 = ContourPlot[((6 Sqrt[10])/
7 + (3/2 – Abs[x]/2) – (6 Sqrt[10])/14 Sqrt[
4 – (Abs[x] – 1)^2] – y) == 0, {x, -7, 7}, {y, -3, 3},
RegionFunction -> ((Abs[#1] > 1) &)]

Representación:

Logo Batman

Mostrando ahora en Mathematica las seis partes juntas con

Show[{pl1, pl2, pl3, pl4, pl5, pl6}]

obtenemos la siguiente representación:

que se parece bastante al contorno del logo de Batman.

Aunque, como proponen en un comentario en StackExchange, se consigue el logo más directamente con el código

Plot[{With[{w = 3*Sqrt[1 – (x/7)^2], l = (6/7)*Sqrt[10] + (3 + x)/2 – (3/7)*Sqrt[10]*Sqrt[4 – (x + 1)^2], h = (1/2)*(3*(Abs[x – 1/2] + Abs[x + 1/2] + 6) – 11*(Abs[x – 3/4] + Abs[x + 3/4])), r = (6/7)*Sqrt[10] + (3 – x)/2 – (3/7)*Sqrt[10]*Sqrt[4 – (x – 1)^2]}, w + (l – w)*UnitStep[x + 3] + (h – l)*UnitStep[x + 1] + (r – h)*UnitStep[x – 1] + (w – r)*UnitStep[x – 3]], (1/2)*(3*Sqrt[1 – (x/7)^2] + Sqrt[1 – (Abs[Abs[x] – 2] – 1)^2] + Abs[x/2] – ((3*Sqrt[33] – 7)/112)*x^2 – 3)*((x + 4)/Abs[x + 4] – (x – 4)/Abs[x – 4]) – 3*Sqrt[1 – (x/7)^2]}, {x, -7, 7}, AspectRatio -> Automatic, Axes -> None, Frame -> True, PlotStyle -> GrayLevel[0]]

que nos da la siguiente representación:

Y digo yo que si le añadimos a la primera representación la elipse

pl7 = ContourPlot[((x/8)^2 + (y/3.5)^2 – 1) == 0, {x, -8, 8}, {y, -5,
5}]

nos queda lo siguiente:

Y con un pelín de Paint obtenemos esto

que se parece mucho más a

Ha quedado bien, ¿verdad?