18
$\begingroup$

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.

enter image description here

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

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

enter image description here

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]

enter image description here

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?

$\endgroup$
7

3 Answers 3

22
$\begingroup$

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

enter image description here


EDIT-1

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

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

enter image description here


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
  ]

enter image description here

$\endgroup$
5
  • 6
    $\begingroup$ 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 $\endgroup$
    – ydd
    Nov 16, 2023 at 16:21
  • 3
    $\begingroup$ @ydd, Thanks. Your techniques is impressive. I was thinking of ways to add such realism. I will add this to the answer. $\endgroup$
    – Syed
    Nov 16, 2023 at 16:24
  • $\begingroup$ Very impressive! (+1) But what about the "T-junction" patterns in original photo? $\endgroup$
    – Silvia
    Nov 18, 2023 at 12:02
  • 1
    $\begingroup$ Thanks @Silvia, I am still thinking about it. kglr has since added two solutions that address this detail. $\endgroup$
    – Syed
    Nov 18, 2023 at 12:42
  • 1
    $\begingroup$ @eldo @Syed also replacing Line with BezierCurve or BSplineCurve looks cool. $\endgroup$
    – flinty
    Nov 22, 2023 at 12:26
11
$\begingroup$

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

enter image description here

SeedRandom[7];

ew = RandomVariate[BetaDistribution[4, 3], r (c - 1) + (r - 1) c];

albersKilim[{r, c}, ew]

enter image description here

SeedRandom[1];

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

enter image description here

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]

enter image description here

$\endgroup$
8
$\begingroup$

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

enter image description here

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

enter image description here

Play with different values for "DeletedEdges":

SeedRandom[1];

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

enter image description here

Play with different values for "NewEdges":

SeedRandom[1];

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

enter image description here

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

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