Feb 14, 2013

The Secret Formula for Love


Mathematica code:

(* a xkcd-style graph converter from http://mathematica.stackexchange.com/questions/11350/xkcd-style-graphs 
by Simon Woods *)

xkcdStyle = {FontFamily -> "Comic Sans MS", 16};

xkcdLabel[{str_, {x1_, y1_}, {xo_, yo_}}] := 
  Module[{x2, y2}, x2 = x1 + xo; y2 = y1 + yo;
   {Inset[
     Style[str, xkcdStyle], {x2, y2}, {1.2 Sign[x1 - x2], 
      Sign[y1 - y2] Boole[x1 == x2]}], Thick, 
    BezierCurve[{{0.9 x1 + 0.1 x2, 0.9 y1 + 0.1 y2}, {x1, y2}, {x2, 
       y2}}]}];

xkcdRules = {EdgeForm[ef : Except[None]] :> 
    EdgeForm[Flatten@{ef, Thick, Black}], 
   Style[x_, st_] :> Style[x, xkcdStyle], 
   Pane[s_String] :> 
    Pane[Style[s, xkcdStyle]], {h_Hue, l_Line} :> {Thickness[0.02], 
     White, l, Thick, h, l}, 
   Grid[{{g_Graphics, s_String}}] :> Grid[{{g, Style[s, xkcdStyle]}}],
    Rule[PlotLabel, lab_] :> Rule[PlotLabel, Style[lab, xkcdStyle]]};

xkcdShow[p_] := 
 Show[p, AxesStyle -> Thick, LabelStyle -> xkcdStyle] /. xkcdRules

xkcdShow[Labeled[p_, rest__]] := 
 Labeled[Show[p, AxesStyle -> Thick, LabelStyle -> xkcdStyle], 
   rest] /. xkcdRules

(* Mathematica Version 8.0+ *)
xkcdDistort[p_] := 
  Module[{r, ix, iy, rand}, 
   r = ImagePad[Rasterize@p, 10, Padding -> White];
   {ix, iy} = 
    Table[RandomImage[{-1, 1}, ImageDimensions@r]~ImageConvolve~
      GaussianMatrix[10], {2}];
   ImagePad[
    ImageTransformation[
     r, # + 15 {ImageValue[ix, #], ImageValue[iy, #]} &, 
     DataRange -> Full], -5]];

(* for Mathematica version < 7 *)
xkcdDistort[p_] := 
 Module[{r, id, ix, iy, samplepoints, funcs, channels},
  r = ImagePad[Rasterize@p, 10, Padding -> White]; 
  id = Reverse@ImageDimensions[r];
  {ix, iy} = Table[ListInterpolation[ImageData[
      Image@RandomReal[{-1, 1}, id]~ImageConvolve~GaussianMatrix[10]]], {2}]; 
  samplepoints = Table[{x + 15 ix[x, y], y + 15 iy[x, y]}, {x, id[[1]]}, {y, id[[2]]}]; 
  funcs = ListInterpolation[ImageData@#] & /@ ColorSeparate[r]; 
  channels = Apply[#, samplepoints, {2}] & /@ funcs; 
  ImagePad[ColorCombine[Image /@ channels], -10]]


xkcdConvert[x_] := xkcdDistort[xkcdShow[x]]


(* the heart plot *)

xkcdConvert[
 ContourPlot[x^2 + (y - (x^2)^(1/3))^2 == 1, {x, -1, 1}, {y, -1, 2}, 
  ContourStyle -> {Red, Thick}, ContourShading -> Red, 
  AspectRatio -> 1, ImageSize -> 400, Axes -> True, Frame -> False, 
  AxesLabel -> Map[Text@Style[#, 20, Italic] &, {"x", "y"}], 
  AxesStyle -> FontSize -> 15, 
  Epilog -> {Inset[
     Style[x^2 + (y - (x^2)^(1/3))^2 == 1, Medium, Italic], 
     Offset[{0, 0}], Scaled[{-0.1, -5.5}], 1], 
    Inset[Style["xkcd-style graph", xkcdStyle, FontSize -> 12 ], 
     Scaled[{0.15, 0.05}], Automatic]}, 
  PlotLabel -> 
   Style["The Secret Formula for Love", xkcdStyle, 
    FontSize -> 24]]]

No comments:

Post a Comment