# How to weave Anni Albers Red Meander carpet?

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?

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.]
]


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]]
}
}
, Boxed -> False
]


• 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, 2023 at 16:21
• @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, 2023 at 16:24
• Very impressive! (+1) But what about the "T-junction" patterns in original photo? Nov 18, 2023 at 12:02
• Thanks @Silvia, I am still thinking about it. kglr has since added two solutions that address this detail.
– Syed
Nov 18, 2023 at 12:42
• @eldo @Syed also replacing Line with BezierCurve or BSplineCurve looks cool. Nov 22, 2023 at 12:26

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,


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],
Background -> Black,
EdgeShapeFunction -> ({CapForm["Square"], Tube[#, .2]} &),
Lighting -> "ThreePoint", ImageSize -> Large]


### Using GridGraph with random EdgeWeights 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],
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]]