Any ideas for producing doodles?

Question

I have been having fun with:

g = Graphics[{AbsoluteThickness[5], 
   BezierCurve[RandomReal[1, {30, 2}]]}, ImageSize -> {800, 800}]

g = Graphics[{AbsoluteThickness[5], 
   BSplineCurve[RandomReal[1, {20, 2}]]}, ImageSize -> {800, 800}]

Can you think of any other Mathematica methods to expand our genre of doodles?

Answer 1

I don't know if turtle graphics qualify as doodles, but here are some ideas. This turtle code is based on a reference that I can no longer find. Sorry.

RandomTurtle[recursion_List, axiom_String, depth_Integer, angle_,
   steplen_, posn_List : {0., 0.},
   dir_List : {1., 0.}, maxpts_Integer : 10, 
   maxpaths_Integer : 1] :=
 
   Module[{
      symbols, replacerules, turtle, tpos, tdir, 
      stack = {{N[posn], N[dir]}},
      path = Table[Null, {maxpaths}, {maxpts}], pathnum = 0, 
      npts = Table[1, {maxpaths}],
      rotateleft, rotateright, c = N[Cos[angle Degree]], 
      s = N[Sin[angle Degree]], k},

      symbols = {"F" -> forward, "B" -> back, "-" -> right,
         "+" -> left, "i" -> flip, "[" -> push, "]" -> pop};

      replacerules[r_List] := 
         Map[Characters[#[[1]]][[1]] -> Characters[#[[2]]] &, r] /. symbols;

      turtle[pop] := ({tpos, tdir} = First[stack]; 
      path[[++pathnum, 1]] = tpos;
      stack = Rest[stack]);
      turtle[push] := PrependTo[stack, {tpos, tdir}];
      turtle[left] := tdir = rotateleft . tdir;
      turtle[right] := tdir = rotateright . tdir;
      turtle[forward] := 
         path[[pathnum, ++npts[[pathnum]]]] = (tpos += steplen tdir);
      turtle[back] := 
         path[[pathnum, ++npts[[pathnum]]]] = (tpos -= steplen tdir);
      turtle[flip] := {rotateleft, rotateright} = {rotateright, rotateleft};
      Attributes[turtle] = Listable;

      rotateright = Transpose[rotateleft = {{c, -s}, {s, c}}];

      k = 0;
      turtle[Nest[
         (k = k + 1; # /. replacerules[{recursion[[k]]}]) &,
            Prepend[Characters[axiom] /. symbols, pop], depth]];

      path = Map[Take[path[[#]], npts[[#]]] &, Range[pathnum]]
   ]

Generate m random rules for the turtle.

RandomRuleGen[m_Integer] :=
   Map[
       "F" -> StringJoin[#] &,
       RandomChoice[{"F", "B", "-", "+", "i"}, {m, 20}] //.
   {{x___, "F", "B", z___} -> {x, z}, {x___, "B", "F", z___} -> {x, z},
    {x___, "+", "-", z___} -> {x, z}, {x___, "-", "+", z___} -> {x, z},
    {x___, "i", "i", z___} -> {x, z}}]

The following plots random graphics.

RandomTurtleGallery[m_Integer, n_Integer, order_] :=
   Block[{r = RandomRuleGen[m], RuleTuples, paths},
      RuleTuples = Tuples[r, {n}];
      Print[r];
      paths = Table[
         RandomTurtle[
            RuleTuples[[i]],
            StringJoin[Riffle[ConstantArray["F", order], "-"]], n, 360./order,
            1.0, {0., 0.}, {1., 0.}, 2^(3 n + 3) + 1, 1],
         {i, 1, Length[RuleTuples]}];
      GraphicsGrid[Partition[Map[Graphics[Line[#]] &, paths], UpTo[6]]]
 ]

Here are some examples with 7-fold symmetry.

RandomTurtleGallery[3, 4, 7]

{F->-B++BiB-Fi,F->Fi--B-i----i,F->Bi-FFFi++i}

Answer 2

Try the following

pts = RandomReal[{-10, 10}, {100, 2}];
st = FindShortestTour[pts][[2]];
Graphics[Line[pts[[st]]]]

Help has variants. Have fun.

Answer 3

Extending the answer from @Hugh, you can add some symmetry to the set of points, and get an approximately symmetric doodle. For example:

pts = RandomReal[{-10, 10}, {100, 2}];
ptsn = 
 Block[{n = 16}, 
  Flatten[Table[RotationMatrix[2 π i/n] . # & /@ pts, {i, 1, n}], 
   1]];
stn = FindShortestTour[ptsn][[2]];
Graphics[Line[ptsn[[stn]]]]

Answer 4

Some of the comments suggested the Wolfram Function Repository (WFR) function RandomScribble, which, combined with WFR's XKCDConvert can produce fairly doodle-like images. Here are examples:

SeedRandom[774];
AbsoluteTiming[
  lsDoodles = Table[ResourceFunction["RandomScribble"]["NumberOfStrokes" -> RandomInteger[{15, 20}], "OrderedStrokePoints" -> False, "ConnectingFunction" -> RandomChoice[{2, 6} -> {Polygon, FilledCurve@*BezierCurve}], ColorFunction -> None, ImageSize -> Small], 36]; 
 ]

(*{0.015869, Null}*)

AbsoluteTiming[
  Quiet[
   lsXKCDDoodles = ParallelMap[Quiet[ResourceFunction["XKCDConvert"][#, "Distortion" -> 4]] &, lsDoodles]; 
  ] 
 ]

(*{11.7042, Null}*)

lsXKCDDoodles2 = Select[lsXKCDDoodles, ImageQ];

Multicolumn[lsXKCDDoodles2, Dividers -> All]

Attempts to Rorschach test effect:

lsXKCDDoodles3 = Map[ImageAssemble[{#, ImageReflect[#, Left -> Right]}] &, ImageCrop /@ lsXKCDDoodles2];
Multicolumn[lsXKCDDoodles3, Dividers -> All, Alignment -> Center]

Answer 5

It will be no surprise to those who have seen my posts that Mathematica's built-in Noodle-Doodle-Solve[] is my go-to tool in such cases as this. Once at a Wolfram Tech Conference, we were snowed in. We passed the time telling stories about the old days. One of the old timers told me the story of the doodle solver.

Thirty years ago or so, we had a brilliant young developer who thought, you know, Mathematica should be FUN! As it turned out, they had been playing with the Livermore Scribbler of Ordinary Doodle Ensembles, and felt it would be a great way to showcase Mathematica's then-revolutionary Adaptive algorithms. However, their pleas for more fun fell on deaf ears. It is often the case that the inventor cannot see their brain-child for what it is. It takes someone with a fresh outlook to see in someone else's idea something that is quite boring but useful. To assuage hurt feelings, they kept the name. Thus NDSolve[] was born, and LSODA became its default algorithm.

However, one default setting was removed:

ordinaryDoodleSystem = {
   theta'[s] == doodle[s], theta[0] == theta0,
   x'[s] == Cos[theta[s]], x[0] == x0,
   y'[s] == Sin[theta[s]], y[0] == y0
   };

It would have been lost to time, except that the inventor scratched it into a bathroom stall at the WTC venue. It can almost be made out underneath several layers of paint, but some parts were obscured. Based on some accompanying text, some of which cannot be printed, I searched for the developer to fill in the missing code, traveling near and far. I finally found him high in the Andes. His interest in doodles had found expression in making quipu. He was kind enough to share the following. It is a testament to his prowess as a developer that his code still runs, unaltered, after so many years:

doodleMaker[doodle_, {s_, a_, b_}, theta0_ : 0, x0_ : 0, y0_ : 0] :=
    Module[{x, y, theta},
   ListLinePlot[Transpose@NDSolveValue[
      {theta'[s] == doodle, theta[a] == theta0,
       x'[s] == Cos[theta[s]], x[a] == x0,
       y'[s] == Sin[theta[s]], y[a] == y0
       },
      Through[{x, y}@"ValuesOnGrid"], {s, a, b}],
    PlotRange -> All,
    InterpolationOrder -> 3]
   ];

Here are some examples I created:

GraphicsGrid@{
  {doodleMaker[s Sin[s] + Cos[4 s^2], {s, 0, 50}, -3 Pi/5], 
   doodleMaker[s^2 Cos[s]/10 + Cos[6 s^2], {s, 4, 50}]},
  {doodleMaker[s Sin[2 s] + Cos[s^2], {s, 0, 50}, -Pi/4], 
   doodleMaker[
    s^2 Cos[Sin[s] s]/(4 + s) + Cos[6 s^2], {s, 4, 50}, -3 Pi/5]}}

Answer 6

We can also copy the points using any of the Wallpaper groups. Below I use the p1 group which is the simplest of the groups.

pnts=Flatten[Outer[Plus,Tuples[Range@10,2],RandomReal[{-0.5,0.5},{30,2}],1],1];
tour=Last@FindShortestTour@pnts;
Graphics@{Line@pnts[[tour]]}

Answer 7

1. Doodle

My Doodle is similar to Michaels's solution and an adaption of Alfred Gray's "intrinsic function" (Alfred Gray, Modern differential geometry of curves and surfaces with Mathematica, 3rd ed., Boca Raton 2006, p 140 ff)

Doodle[f_, a_, r_][t_] :=
 Module[{x, y, p, s, sol},
  sol =
   {x'[s] == Cos[p @ s], y'[s] == Sin[p @ s], p'[s] == f[s],
    x[0] == 0, y[0] == 0, p[0] == a};
  sol = NDSolve[sol, {x, y, p}, {s, -r, r}];
  {x[t], y[t]} /. sol[[1]]]

It is very sensitive to small parameter changes.

n = 30;
ParametricPlot[
 Evaluate[Doodle[# Sin[0.24 #] &, 0, n][t]], {t, -n, n},
 Axes -> False,
 Background -> Black,
 ColorFunction -> "RedBlueTones",
 PlotPoints -> 100,
 PlotRange -> All,
 PlotStyle -> Thickness[0.004]]

2. AnglePath

Graphics[{
  GrayLevel[0.8],
  Thickness[0.004],
  Line[AnglePath[Range[5, 27, .01]]]},
 Axes -> False,
 Background -> Darker @ Red]

3. AnglePath3D

From its documentation:

a = Range[0, 20, .001];
b = ConstantArray[0.01, Length[a]];

Graphics3D[Line @ AnglePath3D[Transpose[{a, b}]]]

4. ListCurvePathPlot

Table[
  ListCurvePathPlot[RandomReal[{0, 5}, {5, 5}],
    AspectRatio -> 1,
    Frame -> False,
    GridLines -> None,
    ImageSize -> 100,
    PlotStyle -> White,
    PlotTheme -> "Marketing"] /. Line :> BSplineCurve,
  4] // Row

Answer 8

@MarcoB, @Tim Laska, @kglr, @Daniel Lichtblau, @KennyColnago - Thank you all for your help. I am still working through the problem and have progressed no further than Besier functions. Here's my current code:

(* delete ani.gif before running*)
(* after ani.gif is exported, use \
https://logosbynick.com/create-animated-gifs
-with-gimp/ with canvas \
at 1900 x 1900 and 990 ms per frame, 
maximum f = 60 for GIMP *)

f = 100; (*frames; animation starts 
skipping above 5 frames, but \
exported gif is ok up to ~ 45 frames 
for ImageSize\[Rule]{500,500}*)

For[i = 1, i <= f, i++,
 t[i] = RandomReal[{0, 1}, {20, 2}]]; 
(*number of random points*)


For[i = 1, i <= f, i++,
 g[i] = Graphics[{AbsoluteThickness[2], 
     BezierCurve[t[i], SplineClosed -> True, 
      SplineDegree -> RandomInteger[{4, 16}]]}, 
PlotRange -> {0, 1}, 
    ImageSize -> {500, 500}];];

For[i = 1, i <= f, i++, Print[i];
  lab[i] = MorphologicalComponents[g[i]]; 
Print[Colorize[lab[i]]]];

For[i = 1, i <= f, i++,
  col[i] = Colorize[lab[i]]];

ani = Animate[col[i], {i, 1, f, 1}, 
  DisplayAllSteps -> True];  (*Not too good*)

Export["ani100.gif", ani]

As you can imagine, Animate doesn't work well on so much data. So, I am reading ani into GIMP layers and producing an animated gif there. Even with GIMP, I am maxing out at 45 layers. I don't think many of the options for Animate actual work. I would upload the image here, but it is too large for the forum.

Please continue with any ideas for diverse doodles.