Edna Andrade's Black Dragon: Winding Around Control Points

Question

Edna Andrade

Edna Andrade (1917-2008) is now recognized as an early leader in the Op Art movement. She lived and worked in Philadelphia for the majority of her career after first moving to the city from Virginia to attend the Pennsylvania Academy of Fine Arts (PAFA).

Photograph of Edna Andrade from the 1960s

At the Academy Andrade was awarded two Traveling Scholarships that allowed her to visit Europe in 1936 and 1937, exposing her to the Bauhaus movement and other examples of European pre-war modernism. Artists who particularly influenced her style included Paul Klee and Piet Mondrian.

Edna Andrade, Moongate A, 1966

"I take delight in measure and ratio, structure and system. The pure and powerful archetypes; the circle, the triangle, the square, the pentagon .... offer me infinite formal possibilities and choices." - Edna Andrade, 1974

During World War II, Andrade worked for the Office of Strategic Services designing visual aids, maps and exhibitions. Beginning in the 1950s, Andrade painted highly abstract, geometric paintings that used a limited color palette and variety of shapes. Her work is in numerous international collections.

Black Dragon

I particularly like Andrade's Black Dragon, a winding pattern which reminded me at Paul Klee's looping constructs. The pattern looked simple to me, but my reproduction attempts failed miserably.

Edna Andrade, Black Dragon, 1971

Reproduction attempt

Starting in the upper left corner I produced a sequence of annuli and immediately encountered problems: There is no smooth transition between the 2nd and 3rd arc, and the 3rd and 4th arc overlap. Similar attempts with the new CircularArcThrough didn't produce a result either.

g1 = Annulus[{1, 0}, {0.9, 1}, {Pi/2, 2 Pi}];

g2 = Annulus[{2.9, 0}, {0.9, 1}, {0, Pi}];

g3 = Annulus[{3.8, -1}, {0.9, 1}, {Pi, 5/2 Pi}];

g4 = Annulus[{1.9, -1}, {0.9, 1}, {0, Pi}];

Graphics[{
  g1, g2, g3, g4,
  PointSize[0.05], 
  Point[{{1, 0}, {2.9, 0}, {3.8, -1}, {1.9, -1}}]},
 Axes -> True]

This is almost certainly not the way to go, but

Question

what would be an appropriate method to create Black-Dragon-like patterns?

cvgmt · Accepted Answer · 2024-07-24 03:03:59Z

Edit

We try to deal with the boundary pattern. To do this,we can fixed the boundary pattern of the four corners. The main idea is that we add one more layer to the Rectangle[{1,1},{n,n}] and using the original idea so that we can distinguish the interior pattern and the outer pattern.

n = 10;
coords = Tuples[Range[0, n + 1], 2];
SW = {{0, 1} <-> {1, 0}, {1, 0} <-> {2, 1}, {1, 2} <-> {2, 1}, {0, 
     2} <-> {1, 1}};
g0 = Graph[coords, 
   NestList[
     Map[RotationTransform[π/
         2, {(n + 1)/2, (n + 1)/2}], #, {2}] &, SW, 3] // Flatten, 
   VertexCoordinates -> coords];
edges := 
  Flatten[Table[
    If[0 <= i < 2 && 0 <= j < 2 || 0 <= i < 2 && n - 1 <= j < n + 1 ||
       n - 1 <= i < n + 1 && 0 <= j < 2 || 
      n - 1 <= i <= n + 1 && n - 1 <= j <= n + 1, Nothing, 
     RandomChoice[
      If[Mod[j, 2] == 
         0, {.7, .3}, {.3, .7}] -> {{i, j} <-> {i + 1, j + 1}, {i + 1,
           j} <-> {i, j + 1}}]], {i, 0, n}, {j, 0, n}]];
graph := 
  GraphUnion[Graph[coords, edges], g0, VertexCoordinates -> coords];
g = Block[{g = graph}, 
   While[(! 
      And @@ Flatten@
        Table[1 <= VertexDegree[g, {i, j}] <= 3, {i, 1, n}, {j, 1, 
          n}]), g = graph]; g];
HighlightGraph[g, EdgeList@g0]

edges = EdgeList[g];
{boundary, interior} = 
  GatherBy[edges, 
   RegionWithin[Rectangle[{1, 1}, {n, n}], 
     Rectangle @@ CoordinateBoundingBox[List @@ #]] &];
arc[type_][edge_] := 
 Module[{p, q, a, b, c, d, in, u, v, o, s, type1, type2}, {p, q} = 
   List @@ edge;
  {a, c} = CoordinateBoundingBox[{p, q}];
  {b, d} = {a + {1, 0}, c + {-1, 0}};
  in = Select[Complement[{a, b, c, d}, {p, q}], 
    RegionWithin[Rectangle[{1, 1}, {n, n}], Point@#] &];
  o = Mean[{p, q}];
  u = Function[in, Mean[{in, p}]];
  v = Function[in, Mean[{in, q}]];
  s = (4/3)*Tan[π/8];
  type1 = 
   BezierCurve[{u@#, {1 - s, s} . {u@#, o}, {1 - s, s} . {v@#, o}, 
       v@#}] & /@ in;
  type2 = Line[{u@#, o, v@#}] & /@ in;
  Which[type == "type1", Return[type1], type == "type2", 
   Return[RandomChoice[{10, 1} -> {type1, type2}]]]]
Graphics[{AbsolutePointSize[5], Point@coords, 
  arc["type1"] /@ boundary, arc["type2"] /@ interior}]

More other styles of such graphics.

edges = EdgeList[g];
{boundary, interior} = 
  GatherBy[edges, 
   RegionWithin[Rectangle[{1, 1}, {n, n}], 
     Rectangle @@ CoordinateBoundingBox[List @@ #]] &];
arc[type_][edge_] := 
 Module[{p, q, a, b, c, d, in, u, v, o, s, type1, type3},
  {p, q} = List @@ edge;
  {a, c} = CoordinateBoundingBox[{p, q}];
  {b, d} = {a + {1, 0}, c + {-1, 0}};
  in = Select[Complement[{a, b, c, d}, {p, q}], 
    RegionWithin[Rectangle[{1, 1}, {n, n}], Point@#] &];
  o = Mean[{p, q}];
  u = Function[in, Mean[{in, p}]];
  v = Function[in, Mean[{in, q}]];
  s = (4/3)*Tan[π/8];
  type3 = {{BezierCurve[{u@#, {1 - s, s} . {u@#, o}, {1 - s, 
           s} . {v@#, o}, v@#}]}, Opacity[.35], RandomColor[], 
      FilledCurve[{Line[{p, u@#}], 
        BezierCurve[{{1 - s, s} . {u@#, o}, {1 - s, s} . {v@#, o}, 
          v@#}], Line[{v@#, q}]}]} & /@ in;
  type1 = 
   BezierCurve[{u@#, {1 - s, s} . {u@#, o}, {1 - s, s} . {v@#, o}, 
       v@#}] & /@ in;
  Which[type == "type1", Return[type1], type == "type3", 
   Return[type3]]]
Graphics[{AbsolutePointSize[5], Point@coords, 
  arc["type3"] /@ interior, arc["type1"] /@ boundary}, 
 GridLines -> {Range[0, n + 1], Range[0, n + 1]}]

Animate

The main idea is that we using Graph again for the pair of the Line.
Needs to be updated later to simplify the code and the idea.

edges = EdgeList[g];
relation[edge_] := 
 Module[{p, q, a, b, c, d, in}, {p, q} = List @@ edge;
  {a, c} = CoordinateBoundingBox[{p, q}];
  {b, d} = {a + {1, 0}, c + {-1, 0}};
  in = Select[Complement[{a, b, c, d}, {p, q}], 
    RegionWithin[Rectangle[{1, 1}, {n, n}], Point@#] &];
  Line[Sort@{#, p}] <-> Line[Sort@{#, q}] & /@ in]
edges2 = Flatten[relation /@ edges];
g2 = Graph[edges2];
paths = FindHamiltonianPath /@ ConnectedGraphComponents[g2];
curve[line1_, line2_] := 
 Module[{o, u, v, c, w, ends1, ends2, s, c1, c2}, ends1 = line1[[1]];
  ends2 = line2[[1]];
  o = Intersection[ends1, ends2] // First;
  u = Mean@ends1;
  v = Mean@ends2;
  w = u + v - o;
  s = (4/3)*Tan[π/8];
  c1 = {1 - s, s} . {u, w};
  c2 = {1 - s, s} . {v, w};
  BezierCurve[{u, c1, c2, v}]]
arcs = Flatten[
   Table[curve @@@ Partition[paths[[i]], 2, 1], {i, 1, Length@paths}]];
ani = Animate[
  Graphics[Take[arcs, j], PlotRange -> {{0, n + 1}, {0, n + 1}}], {j, 
   1, Length@arcs, 1}]

The OP animation.

Clear["Global`*"];
n = 10;
coords = Tuples[Range[0, n + 1], 2];
SW = {{0, 1} <-> {1, 0}, {1, 0} <-> {2, 1}, {1, 2} <-> {2, 1}, {0, 
     2} <-> {1, 1}};
corner = 
  Join[Tuples[{Range[0, 1], Range[0, 1]}], 
   Tuples[{Range[0, 1], Range[n - 1, n]}], 
   Tuples[{Range[n - 1, n], Range[0, 1]}], 
   Tuples[{Range[n - 1, n], Range[n - 1, n]}]];
g0 = Graph[coords, 
   NestList[
     Map[RotationTransform[π/
         2, {(n + 1)/2, (n + 1)/2}], #, {2}] &, SW, 3] // Flatten, 
   VertexCoordinates -> coords];
crosses = 
  RandomChoice[Complement[Tuples[Range[2, n - 1], 2], corner], 4];
edges := 
  Flatten[Table[
    If[MemberQ[corner, {i, j}] || MemberQ[crosses, {i, j}], Nothing, 
     RandomChoice[
      If[Mod[j, 2] == 
         0, {.7, .3}, {.3, .7}] -> {{i, j} <-> {i + 1, j + 1}, {i + 1,
           j} <-> {i, j + 1}}]], {i, 0, n}, {j, 0, n}]];
graph := 
  GraphUnion[Graph[coords, edges], g0, VertexCoordinates -> coords];
g = Block[{g = graph}, 
   While[(! 
      And @@ Flatten@
        Table[1 <= VertexDegree[g, {i, j}] <= 3, {i, 1, n}, {j, 1, 
          n}]), g = graph]; g];
HighlightGraph[g, EdgeList@g0];
edges1 = EdgeList[g];
relation[edge_] := 
 Module[{p, q, a, b, c, d, in}, {p, q} = List @@ edge;
  {a, c} = CoordinateBoundingBox[{p, q}];
  {b, d} = {a + {1, 0}, c + {-1, 0}};
  in = Select[Complement[{a, b, c, d}, {p, q}], 
    RegionWithin[Rectangle[{1, 1}, {n, n}], Point@#] &];
  Line[Sort@{#, p}] <-> Line[Sort@{#, q}] & /@ in]
edges2 = Flatten[relation /@ edges1];
g2 = Graph[edges2];
f = {i, j} |-> {Line[{{i, j}, {i + 1, j}}] <-> 
     Line[{{i, j + 1}, {i + 1, j + 1}}], 
    Line[{{i, j}, {i, j + 1}}] <-> Line[{{i + 1, j}, {i + 1, j + 1}}]};
g3 = Graph[f @@@ crosses // Flatten];
g4 = GraphUnion[g2, g3];
curve[edge_] := 
  Module[{line1, line2, o, u, v, c, w, ends1, ends2, int, s, c1, c2},
   line1 = edge[[1]];
   line2 = edge[[2]];
   ends1 = line1[[1]];
   ends2 = line2[[1]];
   int = Intersection[ends1, ends2];
   If[int == {}, Return[Line[Mean /@ {ends1, ends2}]],
    o = First@int;
    u = Mean@ends1;
    v = Mean@ends2;
    w = u + v - o;
    s = (4/3)*Tan[π/8];
    c1 = {1 - s, s} . {u, w};
    c2 = {1 - s, s} . {v, w};
    Return[BezierCurve[{u, c1, c2, v}]]]];
paths = FindHamiltonianPath /@ (ConnectedGraphComponents[g4]);
arcs = Flatten[curve /@ EdgeList@Subgraph[g4, #] & /@ paths, 1];
ani = Manipulate[
  Graphics[{AbsolutePointSize[5], Point@coords, AbsoluteThickness[5], 
    Take[arcs, j]}], {j, 1, Length@arcs, 1}]

Reply to comment @VitaliyKaurov

Clear["Global`*"];
n = 10;
coords = Tuples[Range[0, n + 1], 2];
SW = {{0, 1} <-> {1, 0}, {1, 0} <-> {2, 1}, {1, 2} <-> {2, 1}, {0, 
     2} <-> {1, 1}};
corner = Join[Tuples[{Range[0, 1], Range[0, 1]}], 
   Tuples[{Range[0, 1], Range[n - 1, n]}], 
   Tuples[{Range[n - 1, n], Range[0, 1]}], 
   Tuples[{Range[n - 1, n], Range[n - 1, n]}]];
g0 = Graph[coords, 
   NestList[
     Map[RotationTransform[π/
         2, {(n + 1)/2, (n + 1)/2}], #, {2}] &, SW, 3] // Flatten, 
   VertexCoordinates -> coords];
 crosses = 
  RandomChoice[Complement[Tuples[Range[2, n - 1], 2], corner], 4]; 
crosses = {};
edges := Flatten[
   Table[If[MemberQ[corner, {i, j}] || MemberQ[crosses, {i, j}], 
     Nothing, 
     RandomChoice[
      If[Mod[j, 2] == 
         0, {.7, .3}, {.3, .7}] -> {{i, j} <-> {i + 1, j + 1}, {i + 1,
           j} <-> {i, j + 1}}]], {i, 0, n}, {j, 0, n}]];
graph := GraphUnion[Graph[coords, edges], g0, 
   VertexCoordinates -> coords];
g = Block[{g = graph}, 
   While[(! 
      And @@ 
       Flatten@Table[
         1 <= VertexDegree[g, {i, j}] <= 3, {i, 1, n}, {j, 1, n}]), 
    g = graph]; g];
HighlightGraph[g, EdgeList@g0];
edges1 = EdgeList[g];
relation[edge_] := 
 Module[{p, q, a, b, c, d, in}, {p, q} = List @@ edge;
  {a, c} = CoordinateBoundingBox[{p, q}];
  {b, d} = {a + {1, 0}, c + {-1, 0}};
  in = Select[Complement[{a, b, c, d}, {p, q}], 
    RegionWithin[Rectangle[{1, 1}, {n, n}], Point@#] &];
  Line[Sort@{#, p}] <-> Line[Sort@{#, q}] & /@ in]
edges2 = Flatten[relation /@ edges1];
g2 = Graph[edges2];
f = {i, j} |-> {Line[{{i, j}, {i + 1, j}}] <-> 
     Line[{{i, j + 1}, {i + 1, j + 1}}], 
    Line[{{i, j}, {i, j + 1}}] <-> Line[{{i + 1, j}, {i + 1, j + 1}}]};
g3 = Graph[f @@@ crosses // Flatten];
g4 = GraphUnion[g2, g3];
curve[type_][edge_] := 
  Module[{line1, line2, o, u, v, c, w, ends1, ends2, int, s, c1, c2, 
    p, q, type1, type2, regs},
   line1 = edge[[1]];
   line2 = edge[[2]];
   ends1 = line1[[1]];
   ends2 = line2[[1]];
   int = Intersection[ends1, ends2];
   If[int == {}, Return[Line[Mean /@ {ends1, ends2}]],
    o = First@int;
    p = Complement[ends1, {o}][[1]];
    q = Complement[ends2, {o}][[1]];
    u = Mean@ends1;
    v = Mean@ends2;
    w = u + v - o;
    s = (4/3)*Tan[π/8];
    c1 = {1 - s, s} . {u, w};
    c2 = {1 - s, s} . {v, w};
    type1 = {RandomColor[], Opacity[.3], 
      FilledCurve[{Line[{p, u}], 
        BezierCurve[{{1 - s, s} . {u, w}, {1 - s, s} . {v, w}, v}], 
        Line[{v, q}]}]};
    type2 = {BezierCurve[{u, c1, c2, v}]};
    Which[type == "type1", Return[type1], type == "type2", 
     Return[type2]]]];
paths = FindHamiltonianPath /@ (ConnectedGraphComponents[g4]);
arcs = Flatten[curve["type2"] /@ EdgeList@Subgraph[g4, #] & /@ paths, 
   1];
regs = Flatten[curve["type1"] /@ EdgeList@Subgraph[g4, #] & /@ paths, 
   1];
ani = Manipulate[
  Graphics[{AbsolutePointSize[5], arcs, Take[regs, j]}, 
   PlotRange -> {{-1, n + 2}, {-1, n + 2}}, 
   PlotRangePadding -> .1], {j, 1, Length@regs, 1}]

Original

The idea is that we find the pattern as the picture show below.

n = 10;
coords = Tuples[Range[n + 1], 2];
edges := 
  Flatten[Table[
    RandomChoice[
     If[Mod[j, 2] == 
        0, {.7, .3}, {.3, .7}] -> {UndirectedEdge[{i, j}, {i + 1, 
         j + 1}], UndirectedEdge[{i + 1, j}, {i, j + 1}]}], {i, 1, 
     n}, {j, 1, n}, 1]];
graph := Graph[coords, edges, VertexCoordinates -> coords];
g = Block[{g = graph}, 
  While[(! 
      And @@ Thread[VertexDegree[g] < 4]) || (FindCycle[g] != {}), 
   g = graph]; g]

There are three patterns. The first and second pattern is two separate quarter, the third pattern is cross.

pattern[edge_] := 
 Which[Last@edge - First@edge == {1, 1}, {Circle[First@edge, 
    1/2, {0, π/2}], Circle[Last@edge, 1/2, {π, 3/2 π}]}, 
  Last@edge - First@edge == {-1, 1}, {Circle[First@edge, 
    1/2, {π/2, π}], 
   Circle[Last@edge, 1/2, {3/2 π, 2 π}]}, 
  Last@edge - First@edge == {0, 
    0}, {Line[{First@edge - {1/2, 0}, First@edge + {1/2, 0}}], 
   Line[{First@edge - {0, 1/2}, First@edge + {0, 1/2}}]}]

With[{i = 3, 
  j = 8}, {Graphics[{FaceForm[], EdgeForm[Dashed], Rectangle[{i, j}], 
    AbsoluteThickness[5], 
    pattern[{i, j} \[UndirectedEdge] {i + 1, j + 1}]}], 
  Graphics[{FaceForm[], EdgeForm[Dashed], Rectangle[{i, j}], 
    AbsoluteThickness[5], 
    pattern[{i + 1, j} \[UndirectedEdge] {i, j + 1}]}], 
  Graphics[{FaceForm[], EdgeForm[Dashed], Rectangle[{i, j}], 
    AbsoluteThickness[5], 
    pattern[{i + 1/2, j + 1/2} \[UndirectedEdge] {i + 1/2, 
       j + 1/2}]}]}]

list = List /@ RandomInteger[{1, n*n}, 4];
edges = MapAt[
   Mean[{#[[2]], #[[1]]}] \[UndirectedEdge] Mean[{#[[2]], #[[1]]}] &, 
   EdgeList[g], list];
Graphics[{AbsoluteThickness[5], AbsolutePointSize[10], 
  pattern /@ edges, Point@coords}]

Remark

After I found the way to draw the original picture,I found that the simple cases have been drawn by Trotte in his book,The Mathematica Guidebook for Graphics,Page 318~319,but need to point out that, my method avoid a single circle, and does not contain cycles.

Almost exact replica! But I noticed one difference: diagonal alleys are less pronounced in the OP. — yarchik, Commented Jul 15 at 18:58
Thank you, cvgmt, marvelous. I hope you had some fun with this :) — eldo, Commented Jul 17 at 13:23

azerbajdzan · Accepted Answer · 2024-07-16 00:52:50Z

n = 6;(*number of points in one quater*)
cross = 1;(*number of crosses in one quarter*)

g1 = {Circle[{0, 1}, 1/2, {3/2 Pi, 2 Pi}], 
  Circle[{1, 0}, 1/2, {Pi/2, Pi}]};
g2 = {Circle[{0, 0}, 1/2, {0, 1/2 Pi}], 
   Circle[{1, 1}, 1/2, {Pi, 3/2 Pi}]};
g3 = {Line[{{1/2, 0}, {1/2, 1}}], Line[{{0, 1/2}, {1, 1/2}}]};

tu1 = (Tuples[{#, #}] &@Range[n]);
tu2 = RandomSample[(Tuples[{#, #}] &@Range[n - 1])];

gra = {Translate[g3, #] & /@ tu2[[1 ;; cross]], 
   Translate[RandomChoice[{g1, g2}], #] & /@ tu2[[cross + 1 ;; -1]], 
   Point[tu1]};
Graphics[{Thickness[0.015], CapForm["Square"], PointSize[0.03], 
  Translate[
     Rotate[gra, #[[1]]], #[[2]]] & /@ {{0, {0, 0}}, {-1/2 Pi, {n - 1,
       0}}, {-3/2 Pi, {0, -(n - 1)}}, {-Pi, {n - 1, -(n - 1)}}}}, 
 Background -> GrayLevel[0.95], ImageSize -> Large]

To have nicer borders:

n = 6;(*number of points in one quater*)
cross = 1;(*number of crosses in one quarter*)

g1 = {Circle[{0, 1}, 1/2, {3/2 Pi, 2 Pi}], 
  Circle[{1, 0}, 1/2, {Pi/2, Pi}]};
g2 = {Circle[{0, 0}, 1/2, {0, 1/2 Pi}], 
   Circle[{1, 1}, 1/2, {Pi, 3/2 Pi}]};
g3 = {Line[{{1/2, 0}, {1/2, 1}}], Line[{{0, 1/2}, {1, 1/2}}]};

tu1 = (Tuples[{#, #}] &@Range[n]);
tu2 = RandomSample[(Tuples[{#, #}] &@Range[n - 1])];

gra = {Translate[g3, #] & /@ tu2[[1 ;; cross]], 
   Translate[RandomChoice[{g1, g2}], #] & /@ tu2[[cross + 1 ;; -1]], 
   Point[tu1]};

border = (f |-> (Translate[Circle[f[[1]], 1/2, f[[2]]], f[[3]]] & /@ 
       Range[1, 2 n - 1, 2])) /@ {{{0, 0}, {0, Pi}, {#, n}}, {{0, 
      1 - n}, {Pi/2, 3/2 Pi}, {1, #}}, {{0, -2 n + 2}, {Pi, 2 Pi}, {#,
       n}}, {{2 n - 2, -n + 1}, {3/2 Pi, 5/2 Pi}, {1, #}}};

Graphics[{Thickness[0.015], CapForm["Square"], PointSize[0.03], 
  Translate[
     Rotate[gra, #[[1]]], #[[2]]] & /@ {{0, {0, 0}}, {-1/2 Pi, {n - 1,
       0}}, {-3/2 Pi, {0, -(n - 1)}}, {-Pi, {n - 1, -(n - 1)}}}, 
  border}, Background -> GrayLevel[0.95], ImageSize -> Large]

I notice that unlike the original figure, your paths are never broken as 3/4 circles at the border. Apart from this tiny difference, amazing post ! — yarchik, Commented Jul 16 at 9:21
@yarchik Easy to add open ends by manipulating variable border but I like it more with no open ends. — azerbajdzan, Commented Jul 16 at 9:57

evanb · Accepted Answer · 2024-07-16 11:55:01Z

First a little setup about important places on the lattice.

L = 10
points = Outer[List, Range[L], Range[L]];
verticalEdges = (points + RotateRight[points])/2;
horizontalEdges = (points + RotateRight /@ points)/2;
faces = (
   points
 + RotateRight[points]
 + RotateRight /@ points
 + RotateRight[RotateRight /@ points]
)/4;

grid = Show[
    Graphics[{Black, Disk[#, 0.2]} & /@ points],
    ListPlot[verticalEdges, PlotMarkers -> {"|"}],
    ListPlot[horizontalEdges, PlotMarkers -> {"-"}],
    ListPlot[faces, PlotMarkers -> {"\[Cross]"}],
    PlotRange -> {{0, 11}, {0, 11}}
]

which sets up the grid

Now we can imagine drawing a worm that winds its way through the grid. A worm is a self-avoiding random walk on the faces.

worm = {RandomChoice[Flatten[faces, 1]]};
segments = 25;

For[steps = 0, steps < segments, steps += 1,
    legal = False;
    While[Not@legal,
        dir = RandomChoice[{{+1, 0}, {-1, 0}, {0, +1}, {0, -1}}];
        next = dir + Last@worm;
        If[Not@MemberQ[worm, next], legal = True]
    ];
    AppendTo[worm, next]
]

We can connect them with circular arcs between each worm segment's midpoint.

midpoints = (worm[[2 ;;]] + worm[[;; -2]])/2;
steps = worm[[2 ;;]] - worm[[;; -2]];
curvature = steps[[2 ;;]] - steps[[;; -2]];
centers = worm[[2 ;; -2]] + curvature/2;

The curvature is the second derivative of the worm's directions, and using the curvature compute the centers.

minimalArc[{a_, b_}] := Which[
    Abs[a - b] <= \[Pi]/2, {a, b},
    a - b > \[Pi]/2, {b, \[Pi] - a},
    b - a > \[Pi]/2, {a, \[Pi] - b},
    True, (Print[{a, b}]; {b, 2 \[Pi] - a})
]

Show[
    grid,
    ListLinePlot[worm],
    ListLinePlot[midpoints, PlotStyle -> {Orange}],
    ListLinePlot[centers, PlotStyle -> Green],
    Graphics[
        {Thick, Table[
            If[curvature[[i]] != {0, 0},
            Circle[centers[[i]], 1/2, 
              minimalArc@Mod[{
                ArcTan @@ (midpoints[[i + 1]] - centers[[i]]), 
                ArcTan @@ (midpoints[[i]] - centers[[i]])}, 2 \[Pi]]],
            Line[{midpoints[[i + 1]], midpoints[[i]]}]
           ], 
           {i, segments - 1}]}],
PlotRange -> {{0, 11}, {0, 11}}
]

This is obviously an incomplete solution, in that

I've only drawn one worm
The random generation of the self-avoiding worm can get trapped forever
This algorithm cannot generate self-crossings that the original shows
I have not incorporated any knowledge of the boundary into the worm's generation.

However, I think this makes an interesting alternative approach, and the method of illustrating the worm is independent the algorithm used to generate it.

$\begingroup$ Thank you, evanb, useful and instructive for me $\endgroup$
– eldo
Commented Jul 17 at 13:26 — eldo, Commented Jul 17 at 13:26

Stack Exchange Network

Edna Andrade's Black Dragon: Winding Around Control Points

3 Answers 3

Edit

Animate

The OP animation.

Original

Remark

Your Answer

Not the answer you're looking for? Browse other questions tagged
graphics
computational-geometry
generative-art
splines
or ask your own question.

Linked

Hot Network Questions

Edna Andrade's Black Dragon: Winding Around Control Points

3 Answers 3

Edit

Animate

The OP animation.

Original

Remark

Your Answer

Sign up or log in

Post as a guest

Not the answer you're looking for? Browse other questions tagged graphicscomputational-geometrygenerative-artsplines or ask your own question.

Linked

Related

Hot Network Questions

Not the answer you're looking for? Browse other questions tagged
graphics
computational-geometry
generative-art
splines
or ask your own question.