How to weave Anni Albers Red Meander carpet?

Question

Anni Albers (1899 - 1994) was a German artist regarded as one of the most influential textile designers of the 20th century. Since 1931 Albers was head of the Bauhaus weaving workshops in Dessau and Berlin. In 1933 Albers, who was Jewish, fled to North Carolina, where she was invited to teach at the Black Mountain College. Later she became the first textile artist to be honoured with a show at the Museum of Modern Art.

Anni Albers in her weaving shop at Black Mountain College, 1937

One of her carpets reminded me of the famous Hilbert curve:

Anni Albers Red Meander, 1954

My reproduction with Mathematica looks quite nice, but doesn't reflect the randomness and small irregularities of Red Meander.

Graphics[{Darker @ Red, Thickness[0.025], HilbertCurve[4]},
 Background -> Lighter @ Lighter @ Lighter @ Brown,
 AspectRatio -> 1.5]

Question

Maybe, a better choice would be a random walk on a square lattice grid using one of the many Graph plots. How can we get a better reproduction of Red Meander with Mathematica?

Hm. Looks like a random maze to me. Have look here: https://www.wolfram.com/mathematica/new-in-10/enhanced-graphs-and-networks/maze-generator.html — Henrik Schumacher, Nov 16 '23 at 15:18
Btw., I really enjoy your art-related questions and in particular this short vita of Anni Albers. I am from Germany, but have never heard her name before. — Henrik Schumacher, Nov 16 '23 at 15:21
Oh, I also found this https://resources.wolframcloud.com/FunctionRepository/resources/RandomMaze/ — Henrik Schumacher, Nov 16 '23 at 15:24
Thank you, Henrik, probably an Irrgarten (maze) would be the best start — eldo, Nov 16 '23 at 15:24
And here some 3D generalizations: https://mathematica.stackexchange.com/questions/146156/how-can-mathematica-be-used-to-create-a-3d-maze-with-text-like-this. Googling "random maze mathematica" reveals plenty of different strategies. — Henrik Schumacher, Nov 16 '23 at 15:26
Anni's husband Josef was a mentor to my childhood neighbor across the street. I suspect Richard was also influenced by Anni herself. — Daniel Lichtblau, Nov 17 '23 at 22:21
Very interesting. The twisted routes of immigration - like the maze of Anni's carpet. — eldo, Nov 17 '23 at 23:13

Syed · Accepted Answer · 2023-11-17T03:18:44.860

22

An attempt:

Using CoordinateBoundsArray and FindShortestTour:

Clear["Global`*"];
cba = Flatten[#, 1] &@CoordinateBoundsArray[{{0, 20}, {0, 25}}, 1];
st = FindShortestTour[cba, DistanceFunction -> ManhattanDistance];
g1 = Graphics[{RGBColor[
   0.6682953195362595, 0.15648222612064008`, 0.2435982997997463, 1.], 
   AbsoluteThickness[8], Line@cba[[Last@st]]}
  , Background -> RGBColor[
   0.8820930848135977, 0.8391520320244056, 0.7687012353458889, 1.]
  , PlotRangePadding -> Scaled[.03]
  ]

EDIT-1

Thanks to @ydd, the addition of the following adds the much needed realism to it.

cba += RandomReal[0.05, Dimensions@cba];

EDIT-2

The 3D case:

Clear["Global`*"];
cba = Flatten[#, 2] &@
   CoordinateBoundsArray[{{0, 10}, {0, 10}, {0, 10}}, 1];
st = FindShortestTour[cba, DistanceFunction -> ManhattanDistance];
g3 = Graphics3D[{
   RGBColor[0.6682953195362595, 0.15648222612064008`, 
    0.2435982997997463, 1.]
   , Tube[cba[[Last@st]], 0.2]
   , {Opacity[0.5], EdgeForm[None]
    , Glow@
     RGBColor[0.8820930848135977, 0.8391520320244056, 
      0.7687012353458889, 1.]
    , GeometricTransformation[
     Cuboid @@ Transpose@CoordinateBounds[cba], 
     ScalingTransform[{0.75, 0.75, 0.75}, Mean@cba]]
    }
   }
  , PlotRangePadding -> Scaled[.03]
  , Boxed -> False
  ]

edited Nov 17 '23 at 03:18

answered Nov 16 '23 at 15:49

Syed

52,495
4
30
85

6

This looks really nice. Also fwiw, you can add a small random real to cba to get slightly different patterns every time if that is desired: $$ $$ cba += RandomReal[0.05, Dimensions@cba];
$$ $$ And then do st = ... This also adds some human-like "imperfections/character" to the the perfectly straight lines :D
– ydd Nov 16 '23 at 16:21
3

@ydd, Thanks. Your techniques is impressive. I was thinking of ways to add such realism. I will add this to the answer. – Syed Nov 16 '23 at 16:24
Very impressive! (+1) But what about the "T-junction" patterns in original photo? – Silvia Nov 18 '23 at 12:02
1

Thanks @Silvia, I am still thinking about it. kglr has since added two solutions that address this detail. – Syed Nov 18 '23 at 12:42
1

@eldo @Syed also replacing Line with BezierCurve or BSplineCurve looks cool. – flinty Nov 22 '23 at 12:26

kglr · Answer 2 · 2023-11-17T08:48:19.150

We can use FindSpanningTree on a GridGraph with random edge weights and desired styling to produce a random maze that looks like Red Meander.

Unlike Red Meander, albersKilim, being a tree, does not contain cycles; and, being a spanning tree, contains a single connected component. However, like Red Meander (and unlike FindShortestTour-based approach), it does allow a vertex to be visited multiple times.

ClearAll[albersKilim]
albersKilim[dims : {__Integer}, ew_ : Automatic, opts : OptionsPattern[]] := 
 Module[{gg = GridGraph[dims, 
     EdgeWeight -> ew /. Automatic -> {e_ :> RandomReal[]}]},
  FindSpanningTree[gg, opts, 
   VertexSize -> 0, 
   VertexShapeFunction -> ({} &), 
   EdgeStyle -> 
     Directive[Opacity[1], AbsoluteThickness[8], Darker@Red], 
   Background -> Lighter@Lighter@Lighter@Brown, 
   ImagePadding -> 10]]

Examples:

r = 30; c = 20;
SeedRandom[1];
albersKilim[{r, c}]

SeedRandom[7];
ew = RandomVariate[BetaDistribution[4, 3], r (c - 1) + (r - 1) c];
albersKilim[{r, c}, ew]

SeedRandom[1];
Multicolumn[
 Table[albersKilim[{20, 20}, Automatic, ImageSize -> 300], 9],
 3]

FWIW, although the output is not anywhere like Red Meander, albersKilim also works in 3D:

SeedRandom[1]
albersKilim[{10, 10, 10}, 
 RandomReal[1, EdgeCount@GridGraph@{10, 10, 10}], 
 VertexCoordinates -> Tuples[Range@10, 3], 
 EdgeStyle -> Directive[Opacity[1], MaterialShading["Gold"]], 
 Background -> Black, 
 EdgeShapeFunction -> ({CapForm["Square"], Tube[#, .2]} &), 
 Lighting -> "ThreePoint", ImageSize -> Large]

score 8 · Answer 3 · answered Nov 17 '23 at 14:39

Using `GridGraph` with random `EdgeWeight`s and `FindHamiltonianPath`

We modify the PathGraph induced by the HamiltonianPath by adding/deleting a random number of edges (controlled by options "NewEdges" and "DeletedEdges") so that, as in Red Meander, the resulting graph may have cycles / multiple connected components / vertices with vertex degree exceeding 2. Using @ydd's suggestion in comments we perturb vertex coordinates by a small random amount (controlled by the option "Wiggle") to get a more natural look.

ClearAll[albersMeander]
Options[albersMeander] = 
  {"Wiggle" -> .03, 
   "NewEdges" -> 10, 
   "DeletedEdges" -> 5, 
    EdgeWeight -> Automatic, 
    VertexSize -> 0, 
    VertexShapeFunction -> ({} &), 
    EdgeStyle -> Directive[Opacity[1], AbsoluteThickness[8], Darker@Red], 
    Background -> Lighter[Brown, 2/3],
    ImagePadding -> 10, 
    ImageSize -> 300};
albersMeander[dims:{__Integer}, opts:OptionsPattern[{albersMeander, Graph}]] := 
 Module[{pg$, newedges,
    g$ = GridGraph[dims, 
     EdgeWeight -> 
      (OptionValue[EdgeWeight] /. Automatic -> {e_ :> RandomReal[]})]},
  pg$ = PathGraph[FindHamiltonianPath[g$], 
    VertexCoordinates -> {v_ :> 
       GraphEmbedding[g$][[v]] + RandomReal[OptionValue["Wiggle"]]}];
  newedges = RandomSample[
    DeleteCases[EdgeList @ g$, 
     Alternatives @@ Join[EdgeList @ pg$, Map[Reverse] @ EdgeList @ pg$]], 
    OptionValue["NewEdges"]];
  Graph[EdgeAdd[EdgeDelete[pg$, 
     RandomSample[EdgeList @ pg$, OptionValue["DeletedEdges"]]], 
    newedges], 
   FilterRules[{opts}, Options[Graph]], 
   FilterRules[Options[albersMeander], Options[Graph]]]]

Examples:

SeedRandom[1];
Row[Table[albersMeander[{25, 20}], 3], Spacer[10]]

Do not add/delete any edges, set EdgeWeights to 1 for all edges and play with the option values for "Wiggle":

SeedRandom[1];
Row[Map[albersMeander[{25, 20}, 
     EdgeWeight -> {e_ -> 1},
    "Wiggle" -> #, 
    "DeletedEdges" -> 0, "NewEdges" -> 0, 
     EdgeStyle -> Directive[Opacity[1], 
      CapForm[# /. {0 -> "Square", _ -> "Round"}], 
      AbsoluteThickness[8], Darker@Red]] &] @ {0, 1/10, 2/10}, 
 Spacer[10]]

Play with different values for "DeletedEdges":

SeedRandom[1];
Row[albersMeander[{25, 20}, 
    "DeletedEdges" -> #, 
    "NewEdges" -> 0] & /@ {0, 5, 10, 20},
   Spacer[10]]

Play with different values for "NewEdges":

SeedRandom[1];
Row[albersMeander[{25, 20}, 
    "DeletedEdges" -> 10, 
    "NewEdges" -> #] & /@ {0, 5, 10, 20},
   Spacer[10]]

How to weave Anni Albers Red Meander carpet?

3 Answers3

Using `GridGraph` with random `EdgeWeight`s and `FindHamiltonianPath`

Linked

How to weave Anni Albers Red Meander carpet?

3 Answers3

Using GridGraph with random EdgeWeights and FindHamiltonianPath

Linked

Using `GridGraph` with random `EdgeWeight`s and `FindHamiltonianPath`