# Find all possible configurations of a finite dipole system

I have a system which is composed of the following blocks

$$[-,+],[+,+],[+,-],[-,-]$$

I can compose a system of $$n$$ blocks with the only rule that the edges act as a dipole.

for example $$[-,+][-,+][-,-][+,-]$$

is a possible configuration of $$n=4$$.

Is it possible to create a code with mathematica that will produce all the possible configurations for any given $$n$$?

• With[{n = 2}, Tuples[{-1, +1}, n]] ? Jan 22, 2021 at 9:55
• this gives all the possible elements, but how can I compose all the possible combinations for any given $n$, which will perserve a dipole between the elements? Jan 22, 2021 at 9:59
• "the only rule that the edges act as a dipole." - to clarify, an admissible configuration is one with + or - on both ends, and +/- always being adjacent between the two poles? Jan 22, 2021 at 10:09

AttachDipole[x : {___, {_, "+"}}] := Append[x, #] & /@ {{"-", "-"}, {"-", "+"}};
AttachDipole[x : {___, {_, "-"}}] := Append[x, #] & /@ {{"+", "-"}, {"+", "+"}};

AttachDipoles[dipls_List] := Join @@ AttachDipole /@ dipls
AllDipoles[n_] :=
Nest[AttachDipoles, {{{"-", "-"}}, {{"-", "+"}}, {{"+", "-"}}, {{"+", "+"}}}, n - 1]

AllDipoles[1]

{{{"-", "-"}}, {{"-", "+"}}, {{"+", "-"}}, {{"+", "+"}}}

AllDipoles[2]

{{{"-", "-"}, {"+", "-"}}, {{"-", "-"}, {"+", "+"}},
{{"-", "+"}, {"-", "-"}}, {{"-", "+"}, {"-", "+"}},
{{"+", "-"}, {"+", "-"}}, {{"+", "-"}, {"+", "+"}},
{{"+", "+"}, {"-", "-"}}, {{"+", "+"}, {"-", "+"}}}

AllDipoles[3]

{{{"-", "-"}, {"+", "-"}, {"+", "-"}}, {{"-", "-"}, {"+", "-"}, {"+", "+"}},
{{"-", "-"}, {"+", "+"}, {"-", "-"}}, {{"-", "-"}, {"+", "+"}, {"-", "+"}},
{{"-", "+"}, {"-", "-"}, {"+", "-"}}, {{"-", "+"}, {"-", "-"}, {"+", "+"}},
{{"-", "+"}, {"-", "+"}, {"-", "-"}}, {{"-", "+"}, {"-", "+"}, {"-", "+"}},
{{"+", "-"}, {"+", "-"}, {"+", "-"}}, {{"+", "-"}, {"+", "-"}, {"+", "+"}},
{{"+", "-"}, {"+", "+"}, {"-", "-"}}, {{"+", "-"}, {"+", "+"}, {"-", "+"}},
{{"+", "+"}, {"-", "-"}, {"+", "-"}}, {{"+", "+"}, {"-", "-"}, {"+", "+"}},
{{"+", "+"}, {"-", "+"}, {"-", "-"}}, {{"+", "+"}, {"-", "+"}, {"-", "+"}}}


Here is a one liner:

n = 3;
DeleteCases[Tuples[Tuples[{-1, 1}, 2],  n], {___, {_, x_}, {y_, _}, ___} /; ( x == y)]

{{{-1, -1}, {1, -1}, {1, -1}}, {{-1, -1}, {1, -1}, {1,
1}}, {{-1, -1}, {1, 1}, {-1, -1}}, {{-1, -1}, {1, 1}, {-1,
1}}, {{-1, 1}, {-1, -1}, {1, -1}}, {{-1, 1}, {-1, -1}, {1,
1}}, {{-1, 1}, {-1, 1}, {-1, -1}}, {{-1, 1}, {-1, 1}, {-1,
1}}, {{1, -1}, {1, -1}, {1, -1}}, {{1, -1}, {1, -1}, {1,
1}}, {{1, -1}, {1, 1}, {-1, -1}}, {{1, -1}, {1, 1}, {-1, 1}}, {{1,
1}, {-1, -1}, {1, -1}}, {{1, 1}, {-1, -1}, {1, 1}}, {{1, 1}, {-1,
1}, {-1, -1}}, {{1, 1}, {-1, 1}, {-1, 1}}}

• You can make the pattern a bit more compact with {___, {_, x_}, {x_, _}, ___} Jan 22, 2021 at 15:19