15
$\begingroup$

Josef Albers (1888 - 1976) was a German-born American artist. In 1920, Albers joined the Weimar Bauhaus as a student and became a faculty member in 1922, teaching the principles of handicrafts.

enter image description here

Josef Albers, Aufwärts (Upwards), ca. 1926

With the Bauhaus's move to Dessau in 1925, he was promoted to professor and married Anni Albers, a student at the institution who was to become famous as a textile artist:

How to weave Anni Albers Red Meander carpet?

Following the Bauhaus's closure under Nazi pressure in 1933, Josef and Anni Albers emigrated to the United States. He was appointed as the head of the painting program at Black Mountain College in North Carolina, a position he held until 1949.

enter image description here

Josef Albers (left) with Buckminster Fuller (Mid) and students at Black Mountain College, summer 1948: Construction of a geodesic dome.

In 1950, Albers left Black Mountain to head the department of design at Yale University. He is considered to be one of the most influential teachers of visual art in the twentieth century.

Between 1925 and 1929 Albers produced a series of abstract paintings, which I would like to replicate with Mathematica. Here is another one of them:

enter image description here

Josef Albers, Fabrik (Factory), 1925

More pieces of the series can be seen at the Josef & Anni Albers Foundation

My request

Can we produce rectangular patterns like these with a certain amount of randomness?

$\endgroup$
3
  • 2
    $\begingroup$ Albers like Mondrian had a deep interest in perception and the interaction of color. See earlier thread Composition-à-la-Mondrian and his wonderful book on the subject: The Interaction of Color $\endgroup$
    – Jagra
    Commented Feb 7 at 13:48
  • 1
    $\begingroup$ Thank you, Jagra, nice observation. I asked a Mondrian - question some years ago: Composition à la Mondrian, and I just realized that there is a RandomMondrian in the Repository $\endgroup$
    – eldo
    Commented Feb 7 at 14:00
  • $\begingroup$ Ha! I hadn't remembered that you asked the earlier question. Nice to see that you have retained your interest in all of this. Keen to see what you develop. $\endgroup$
    – Jagra
    Commented Feb 7 at 14:10

4 Answers 4

10
$\begingroup$
  • We use KroneckerProduct to create some {0,1}-matrixs.
  • {m1,m2,...,m6,m7} are several types of such {0,1}-matrixs.
  • We set random grid points in the rectangle and choose some type of such matrixs and use Plus to mixing the types.
k = 8;
m1 = KroneckerProduct[PadRight[{0, 1}, k, "Periodic"], 
   PadRight[{0, 1}, k, "Periodic"]];
m2 = KroneckerProduct[PadRight[{0, 1}, k, "Periodic"], 
   PadRight[{1, 0}, k, "Periodic"]];
m3 = KroneckerProduct[PadRight[{1, 0}, k, "Periodic"], 
   PadRight[{0, 1}, k, "Periodic"]];
m4 = KroneckerProduct[PadRight[{1, 0}, k, "Periodic"], 
   PadRight[{1, 0}, k, "Periodic"]];
m5 = KroneckerProduct[PadRight[{1, 1}, k, "Periodic"], 
   PadRight[{1, 0}, k, "Periodic"]];
m6 = KroneckerProduct[PadRight[{1, 0}, k, "Periodic"], 
   PadRight[{1, 1}, k, "Periodic"]];
m7 = KroneckerProduct[PadRight[{1, 1}, k, "Periodic"], 
   PadRight[{1, 1}, k, "Periodic"]];
ArrayPlot/@{m1,m2,m3,m4,m5,m6,m7} 

enter image description here

SeedRandom[1];
n = 25;
ArrayPlot[
 SparseArray[
  MapThread[
   Rule[Band[#1], #2] &, {RandomInteger[{1, n}, {n, 2}], 
    Table[RandomChoice[{m1, m2, m3, m4, m5, m6, m7}] + 
      RandomChoice[{m1, m2, m3, m4, m5, m6}], n]}]], 
 ColorRules -> {0 -> Red, 1 -> Black, 2 -> White}]

enter image description here

  • For the first picture, we can maily use type m6 and m7 by setting {0, 0, 0, 0, 0, 1, 1}->{m1, m2, m3, m4, m5, m6, m7}.
Clear[m, n];
SeedRandom[1];
m = 5  k;
n = 3  k; 
c = .9; 
pts = 
 RandomSample[Tuples[{Range[m], Range[n]}], Floor[m*n*c]]; ArrayPlot[
 SparseArray[
  MapThread[
   Rule[Band[#1], #2] &, {pts, 
    Table[RandomChoice[{0, 0, 0, 0, 0, 1, 1} -> {m1, m2, m3, m4, m5, 
         m6, m7}] + 
      RandomChoice[{0, 0, 0, 0, 0, 1, 1} -> {m1, m2, m3, m4, m5, m6, 
         m7}], Length@pts]}]], 
 ColorRules -> {0 -> White, 1 -> Black, 2 -> Lighter@Blue}, 
 PlotRangePadding -> 0]

enter image description here

$\endgroup$
8
$\begingroup$

Clearly, there is room for automation here.

Clear["Global`*"];

rules = {1 -> Black, 2 -> Lighter@Blue, 3 -> White, 4 -> White, 
   5 -> Lighter@Blue, 6 -> Black};
parts = IntegerPartitions[30, {1, 6}] // Select[4 < Length@# < 8 &];
runs = RandomSample[parts, 40] // 
   Map[RotateLeft[#, RandomInteger[{1, 3}]] &];
cols = RandomInteger[{1, 6}, Length@#] & /@ runs;
cbars = (MapThread[Thread[{#1, #2}] &, {runs, cols}] /. {a_, b_} :> 
     Sequence @@ ConstantArray[Lookup[rules, b], a]);

To check where the errors (if any) can come from:

Dimensions /@ {rules, parts, runs, cols, cbars}

ArrayPlot[{
     cbars[[1]], cbars[[2]]
     , cbars[[1]], cbars[[2]]
     , cbars[[1]], cbars[[2]]
     
     , cbars[[9]], cbars[[6]]
     , cbars[[9]], cbars[[6]]
     , cbars[[9]], cbars[[6]]
     , cbars[[9]], cbars[[6]]
     
     , cbars[[21]], cbars[[15]]
     , cbars[[21]], cbars[[15]]
     , cbars[[21]], cbars[[15]]
     , cbars[[21]], cbars[[15]]
     
     , cbars[[10]], cbars[[13]]
     , cbars[[10]], cbars[[13]]
     , cbars[[10]], cbars[[13]]
     , cbars[[10]], cbars[[13]]
     
     , cbars[[22]], cbars[[25]]
     , cbars[[22]], cbars[[25]]
     , cbars[[22]], cbars[[25]]
     , cbars[[2]], cbars[[25]]
     , cbars[[2]], cbars[[25]]
     } // 
    SubsetMap[
      RotateLeft[#, RandomInteger[{3, 6}]] &, #, {All, 
       RandomInteger[{8, 12}]}] & //
   SubsetMap[
     RotateLeft[#, RandomInteger[{3, 6}]] &, #, {All, 
      RandomInteger[{18, 22}]}] & //
  SubsetMap[
    RotateLeft[#, RandomInteger[{3, 6}]] &, #, {All, 
     RandomInteger[{28, 30}]}] &
 ]

A typical output:

enter image description here

$\endgroup$
7
$\begingroup$
ClearAll[albersFabrik]

albersFabrik[clrs_ : Automatic, lines_ : Automatic, d_ : Automatic, 
   t_ : 15][opts : OptionsPattern[]] := 
 Module[{c = clrs /. Automatic -> {Black, Red, White}, 
   n = d /. Automatic -> 10}, 
  Graphics[
   Map[{Last[c = RotateRight[c]], 
       CapForm["Square"], AbsoluteThickness[t], Line @ #} &]@
    RandomSample @
     Map[Table[
         RandomChoice[{Map[Reverse], Identity}]@RandomSample[#, 2], 
         lines /. Automatic -> 20] &]@
      Outer[List, Range[0, 3  n, 3], Range[0, 3 n, 3]], opts, 
   ImageSize -> Medium, 
   Background -> First[clrs /. Automatic -> {Black, Red, White}], 
   PlotRangePadding -> 2]]

Examples:

SeedRandom[777];

Row[{albersFabrik[][], albersFabrik[][], albersFabrik[][]}, Spacer[10]]

enter image description here

Row[{albersFabrik[RandomColor[3]][], 
     albersFabrik[RandomColor[3]][], 
     albersFabrik[RandomColor[3]][]}, Spacer[10]]

enter image description here

Row[{albersFabrik[Automatic, 4][], 
     albersFabrik[Automatic, 15][], 
     albersFabrik[Automatic, 25][]}, Spacer[10]]

enter image description here

$\endgroup$
5
$\begingroup$
upwards := Module[
  {colors = {Lighter@Blue, Black, White}, partitions = 8, rows = 40, cols = 30, matrix, part},
  {part["rows"], part["cols"]} = 
     Partition[Join[{1}, Sort@RandomSample[Range[2, # - 1], partitions], {#}], 2, 1] & 
       /@ {rows, cols};
  matrix = Array[If[ Mod[#, 2] == 0, Lighter@Blue, Black] &, {rows, cols}] ;
  Outer[{rows, cols} |->
    matrix[[Span @@ rows, Span @@ cols]] //= 
      ReplaceAll[#,  Rule @@ RandomSample[colors, 2]] &, part["rows"], part["cols"], 1];
  matrix // ArrayPlot]

SeedRandom[1];
Multicolumn[Table[upwards, 6], 3]

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.