# Tag Info

474

The code below attempts to apply the XKCD style to a variety of plots and charts. The idea is to first apply cartoon-like styles to the graphics objects (thick lines, silly font etc), and then to apply a distortion using image processing. The final function is xkcdConvert which is simply applied to a standard plot or chart. The font style and size are set ...

449

I have to confess that I see this as a proper challenge, as I am usually quite creative in finding/combining functions to provide a desired behavior. So I will give it another try. which is generated using box[x_, x1_, x2_, a_, b_] := Tanh[a (x - x1)] + Tanh[-b (x - x2)]; ex[z_, z0_, s_] := Exp[-(z - z0)^2/s] (*and*) r[z_, x_] := (*body*).4 (1.0 - .4 ex[...

329

Mostly thanks to Belisarius's elegant wrapping, you can do h[fun_, divisor_, color_, at_] := Module[{k}, k = BSplineFunction[Table[fun@x + RandomReal[{-0.1, 0.1}/divisor], {x, 0.01, 10, .1}]]; ParametricPlot[k[x], {x,0.1,0.9}, PlotStyle->{color, AbsoluteThickness@at}, Axes-> None]]; Show[{ h[{#, 1.5 + 10 (Sin[#]^2/Sqrt[#]) Exp[-(# - 5)^2/2]} &...

221

This might get me suspended from the site butt I cannot resist. The shape you are looking for can probably be approximated (depending how anal you want to be about the outcome) by two assymetric probability distributions. The obvious choices would be a Poasson or a log normal distribution. I will use the latter as it is continuous. Now the bummer is that ...

181

I did a very simple (in fact over-simple) snowflake simulator with CellularAutomaton years before. It's based on the hexagonal grid: and range-1 rules: Initial code First we'll need some functions to display our snowflakes: Clear[vertexFunc] vertexFunc = Compile[{{para, _Real, 1}}, Module[{center, ratio}, center = para[[1 ;; 2]]; ratio = para[[...

118

Parametric Buttocks Manipulator Manipulate[ ParametricPlot3D[{ (e u^p + (1 + (c - a u) (u - 1)) Cos[t]^2) Sin[t], (e u^p + (1 + (d - b u) (u - 1)) Cos[t]^2) Cos[t], 2 u}, {t, -0.2, Pi + 0.2}, {u, 0, 1.1}, Lighting -> "Neutral", Mesh -> None, PlotStyle -> Directive[Specularity, RGBColor[0.92, 0.85, 0.73]], Axes -> False], {{a, 7},...

102

Time to join in the fun. version 2 Result Method I produce the basic plot with ticks and labels: Plot[{x/2, (x + Sin[x])/2.2}, {x, 0, 2 Pi}, MaxRecursion -> 0, PlotPoints -> 30, Axes -> False, Frame -> {True, True, False, False}, FrameTicks -> {{{0.2, "Start", 0.07}, {3, "lunch", 0.05}, {6, "Finish", 0.06}}, None}, PlotLabel -> ...

100

Amusingly enough, the images above actually arose as an accidental by-product of browsing inane YouTube conspiracy theory videos. I happened across a rather beautiful video of a "mirror cube" device produced by a man in Germany named Ben Palmer, who apparently produced it in an attempt to bring recognition to a philosopher named Walter Russell (the first ...

97

Update: This function has been updated to compatible with version 12.x and made available on Wolfram Function Repository as ResourceFunction["Graphics3DSketch"]: https://resources.wolframcloud.com/FunctionRepository/resources/Graphics3DSketch Yes we can. The following DashedGraphics3D[ ] function is designed to convert ordinary Graphics3D object to the "...

97

Here's a quick take on it: Clear[spiralize]; spiralize[p_, d_:10, r_:4, f_:0.8, s_:1, t_:0.005]:=Module[{m,rr=r}, m = Mean @ p[]; Graphics[{EdgeForm[Thickness[t]],FaceForm[White], NestList[GeometricTransformation[ GeometricTransformation[#, RotationTransform[rr++s \[Degree],m]], ScalingTransform[{f,f},m] ]&...

97

Here is one way to come up with "mandalas" -- we generate a segment and then by appropriate number of rotations we produce a "mandala". Here is an example function of a random seed segment generation: Clear[MakeSeedSegment] MakeSeedSegment[radius_, angle_, n_Integer: 10, connectingFunc_: Polygon, keepGridPoints_: False] := Block[{t}, t = Table[ ...

89

I'm very late to the party, but here's a convenient xkcd guy generator: This was generated as: With[{ h = xkcdGuy[-10, "hat", 0.2, {20, -90}, {-57, -10}, {-20, 0}, {20, 0}], n = xkcdGuy[0, "none", -0.2, {-10, 0}, {50, 10}, {-20, 0}, {20, 0}]}, Graphics[{First@n, Rotate[Translate[First@h, {3.3, 0}], 10 Degree]}] ] // xkcdConvert using Simon's ...

84

How to make your eyes hurt Mike asked whether it is possible to recreate the image he posted in his question. Although I haven't searched the web whether the equations for the above image are published somewhere, I will show how you can create such kind of image by pure inspection. By inspecting Mike's original image, one recognizes the following things: ...

82

Version 11.1 introduces MengerMesh: MengerMesh This seems the most natural to me: carpet[n_] := Nest[ArrayFlatten[{{#, #, #}, {#, 0, #}, {#, #, #}}] &, 1, n] ArrayPlot[carpet @ 5, PixelConstrained -> 1] Shorter (in InputForm), but perhaps harder to read and slightly slower, though speed hardly matters given the geometric memory usage: carpet[...

81

To implement datenwolf's suggestion to perturb curves with Perlin noise to give that "hand-drawn" look and feel, here's one way to use one-dimensional Perlin noise for the perturbation: fBm = With[{permutations = Apply[Join, ConstantArray[RandomSample[Range[0, 255]], 2]]}, Compile[{{x, _Real}}, Module[{xf = Floor[x], xi, xa, u, i, j}, xi = Mod[...

76

========== update =========== Remember guys how we can cut out a snowflake from a sheet of paper carving 12th folded part? Like the image below. So I decided to write an app to imitate the process. It also can be used to make random snowflakes (similar to to @bill s' but with reflection to imitate real cutting paper process and reflective symmetry of ...

76

A simple algorithm that measures the distance of existing disks from a new, candidate disk, while decreasing radius size. The following two functions generate a random point in the unit disk and measures the distance to all existing disks. randomPoint = Compile[{{r, _Real}}, Module[ {u = RandomReal@{0, 1 - 2 r}, a = RandomReal@{0, 2 Pi}}, {Sqrt@u*Cos[...

74

replacing RandomReal function in István's code with u = RandomVariate[UniformDistribution[{0,1 - ((1 - 2 min)/(max - min) (r - min) + 2 min)}]] leads to non-uniform distribution Randomization for the angle can also be non-uniform: randomPoint = Compile[{{r, _Real}}, Module[{u = RandomVariate[ UniformDistribution[{0, 1 ...

73

My original code was crashing when you used too many digits because apparently Mathematica can handle only so many different font sizes. To fix it, I had to borrow george2079's PDF trick to turn each character into a vectorised graphics primitive. I couldn't have solved this issue myself, so give his answer an upvote please. The rest of the code is still my ...

68

Edit: Added the reversal and some refinements ω = 1; posP[t_, φ_] := Sin[ω t + φ] {Cos[φ], Sin[φ]} posL[φ_] := {-#, #} &@{Cos[φ], Sin[φ]} Animate[ Graphics[{PointSize[0.02], Table[{Black, Line[posL[π i]], Hue[i], Point[posP[t, π i]]}, {i, 0, 1, 1/(3π-Abs[9.43-t])}] }, PlotRange -> {{-1.5, 1.5}, {-1.5, 1.5}} ], {t, 0, 6π, 0.2} ]

67

I'd like to expand on Quantum_Oli's answer to give an intuitive explanation for what's happening, because there's a neat geometric interpretation. At one point in the animation it looks like there is a circle of colored dots moving about the center, this is a special case of so called hypocycloids known as Cardano circles. A hypocyloid is a curve generated ...

66

Let's do it Andy's way So you are Andy. Nice to meet you. And you never got those hands on a computer. It doesn't matter, I will show you! First you need to go to Marilyn's place. Don't worry, JF isn't there right now. Ask her for a nice photograph and the negatives. i = ImageCrop@Import@"http://i.stack.imgur.com/W8hV5.png" Outstanding picture, good ...

65

Here is a start. I'm sure others will come up with better solutions, but I think from here it's mostly down to finding a better algorithm to pick the random lines. First, we get ourselves a Region representation of the text we want to stylise (thanks to yode for simplifying this part): textRegion = DiscretizeGraphics[ Text[Style["MUSEUM", FontFamily ->...

65

For this one I've defined three types of layer, a flower, a simple circle and a ring of small circles. You could add more for greater variety. flower[n_, a_, r_] := Module[{b = RandomChoice[{-1/(2 n), 0}]}, Cases[ParametricPlot[ r (a + Cos[n t])/(a + 1) {Cos[t + b Sin[2 n t]], Sin[t + b Sin[2 n t]]}, {t, 0, 2 Pi}], l_Line :> FilledCurve[l], -1]] ...

62

Here's a try: g3 = Graphics3D[{Gray, Sphere[]}, Lighting -> "Neutral", Boxed -> False] img = ColorConvert[Rasterize[g3, "Image", ImageResolution -> 72], "GrayLevel"] edge = ColorNegate@EdgeDetect[img] Manipulate[ dots = Image@ Map[RandomChoice[{#, 1 - #} -> {1, 0}] &, ImageData@ImageAdjust[img, {0, c, g}], {2}]; ...

55

TL;DR Yes, this can be done! If you read the article "Hexagonal circle packings and Doyle spirals" by Leys, you will see that for a choice p and q, we need to find the complex values A, B and r. For that purpose, we can steal this part from the demonstration you linked: doyle[pi_, qi_] := Module[{p = pi, q = qi, s, t, r}, r[s_, t_, p_, q_] := (s^2 + ...

54

An extended comment follows. Mondrian, in the late work referenced by the OP and characterized by primary colored rectangles separated by black lines, employed an extraordinarily sophisticated understanding of perception, color, and light. As background to understand what Mondrian does, I recommend The Interaction on Color, by Joseph Albers and Alfred C. ...

53

My simple version using Image: size = 300; r = ListConvolve[DiskMatrix[#], RandomInteger[BernoulliDistribution[0.001], {5 size, size}], {1, 1}] & /@ {1.5, 2, 3}; Dynamic[Image[(r[[#]] = RotateRight[r[[#]], #]) & /@ {1, 2, 3}; Total[r[[All, ;; size]]]]] Update A slightly prettier version, same basic idea but now with flakes. flake := Module[{...

53

Scientific progress! In v10.3 with all the goodies in AnatomyData we can now use the simple code: Entity["AnatomicalStructure", "Skin"]["Graphics3D"] Zoom in on the appropriate part and you're done. pelvisLoc = AnatomyData[Entity["AnatomicalStructure", "Pelvis"], "RegionBounds"]; Show[ Entity["AnatomicalStructure", "Skin"]["Graphics3D"], PlotRange ...

Only top voted, non community-wiki answers of a minimum length are eligible