# How to correctly calculate the number of seating plans for the 4-couples problem?

Four couples a are sitting around a round table, in which husband and wife can not be adjacent. How many different seating plans are there?

I want to get as many simple calculations as possible.

  (sol = DeleteCases[
DeleteCases[
DeleteDuplicatesBy[
Permutations[Flatten[Table[{h[i], w[i]}, {i, 1, 4}]]],
RotateLeft[#, Ordering[#, -1][] - 1] &], ({h[a_], __,
w[a_]} | {w[a_], __, h[a_]})], ({___, h[a_], w[a_], ___} | {___,
w[a_], h[a_], ___})])// Length


If you can, visualize the top 10 results as succinctly as possible:

   Show[Graphics[
Table[Circle[{0, 0},
8, {(i π)/4 + 2 ArcSin[1/8], ((i + 1) π)/4 -
2 ArcSin[1/8]}], {i, 8}]], Graphics[
Table[{Opacity[0.5], EdgeForm[Opacity[.6]], Hue[-(11/72)],
Thick,
Disk[(8) {Cos[2 Pi q/8], Sin[2 Pi q/8]}, 2]}, {q, 8}]]
, Graphics@
Text[Style[#1, 13, Bold, Red], #2, Automatic] &, {#,
Table[8 {Cos[2 Pi q/8], Sin[2 Pi q/8]}, {q, 1, 8}]}]] &  /@
sol[[1 ;; 10]]


Other examples:

DeleteCases[
DeleteCases[
Prepend[#, "a"] & /@
Permutations[
Flatten[Table[Array[i, 2], {i, Alphabet[][[1 ;; 4]]}]] //
Rest], {___, x_[_], x_[_], ___}], {x_[_], __, x_[_]}] // Length

• Note that instead of nesting DeleteCases, you can instead insert a | between patterns, like an "or" (the underlying name for this is Alternative), e.g. ({h[a_], __, w[b_]} | {w[a_], __, h[b_]}) /; a == b. Feb 21 at 0:37
• You can also do away with the equality check /; a == b in this case simply by using the same named pattern: {h[a_], __, w[a_]} | {w[a_], __, h[a_]} Feb 21 at 0:39
• You are assuming that the individuals of each couple are distinguishable. Shorter code is p = Join[{-1}, #] & /@ Permutations[{1, -2, 2, -3, 3, -4, 4}]; s = Select[p, Min[Abs[Abs[#] - Abs[RotateLeft[#]]]] != 0 &] // Length.
– JimB
Feb 21 at 3:44

couples = Partition[Range @ 8, 2]

{{1, 2}, {3, 4}, {5, 6}, {7, 8}}

pairs = Complement[Subsets[Range, {2}], couples];

hamiltonianCycles = FindHamiltonianCycle[pairs, All];

Length @ hamiltonianCycles

744

RandomSample[hamiltonianCycles, 5] To get the associated permutations, map VertexList on cycles:

VertexList /@ % // Column vlabels = Thread[Flatten @ couples -> (Placed[#, Center] & /@
Flatten @ MapIndexed[{Subscript[w, #], Subscript[h, #]} &@#2[] &, couples])];

Multicolumn[Graph[#, VertexLabels -> vlabels, VertexLabelStyle -> Small,
VertexSize -> Large, ImageSize -> 200,
VertexStyle ->
MapIndexed[Alternatives @@ # -> ColorData[#2[]] &, couples]] & /@
RandomSample[hamiltonianCycles, 16], 4] If orientation of seating does matter, we can process to hamiltonianCycles to reverse the cycles and edges and Join the resulting list with hamiltonianCycles:

directedHamiltonianCycles = Join[#, Map[Reverse@*Map[Reverse]]@#] &@
Apply[DirectedEdge, hamiltonianCycles, {2}];

Length @ directedHamiltonianCycles

1488

RandomSample[directedHamiltonianCycles, 5] // Column Replace hamiltonianCycles with directedHamiltonianCycles in Multicolumn[...] above to get Update: Making a function that takes the number of couples as argument:

ClearAll[hc]
hc[nc_] := Module[{pl = Complement[Subsets[#, {2}], Partition[#, 2]] &@Range[2 nc]},
FindHamiltonianCycle[pl, All]]

Length /@ hc /@ Range

{0, 1, 16, 744, 56256, 6385920}

vlabeling[nc_] := MapThread[Apply[Sequence] @* Thread @* Rule,
{Partition[Range[2 nc], 2],
Array[Placed[#, Center] & /@ {Subscript[w, #], Subscript[h, #]} &,
nc]}]

nc = 5;

Multicolumn[Graph[#, VertexLabels -> vlabeling[nc],
VertexLabelStyle -> Small, VertexSize -> Large, ImageSize -> 200,
VertexStyle ->
MapIndexed[Alternatives @@ # -> ColorData[#2[]] &,
Partition[Range[2 nc], 2]]] & /@ RandomSample[hc[nc], 16], 4] With a little borrowing from JimB comment to populate all the possible solutions, another way to solve it is by using Partition[ ..., 2, 1, 1] to pick every two seat next to each other with start and ending seat case:

ps = Join[{-1}, #] & /@ Permutations[{1, -2, 2, -3, 3, -4, 4}];

result = DeleteCases[ps, l_ /; AnyTrue[Partition[l, 2, 1, 1], Plus @@ # == 0 &]]
(*Output Length: 1488 *)


If a couple sitting next to each other, then sum of them will be zero (one is $$n$$ other is $$-n$$), so we delete these cases.

For visualizing, you can use CirclePoints:

DrawTable[l_] :=
Graphics[{Circle[],
MapIndexed[{White, EdgeForm[Black], Disk[#, .2], Black,Text[l[[#2[]]], #1]} &,
CirclePoints[Length@l]]}]

DrawTable[{1, 2, 3}]


Out: Visualize random samples:

DrawTable /@ RandomSample[result, 3] DrawTable[# /. x_Integer :> Subscript[{"W", "H"}[[Sign@x]], Abs@x]] & /@ RandomSample[result, 3] Sorry that this is a mess, but it takes a lot of time to make code pretty. Anyway, SatisfiabilityCount/SatisfiabilityInstances are the core of it all. This approach could be generalised to more complicated questions than round tables etc., but of course would need a different visualisation with those questions.

With[{couples = 4, (* Just for clarity: *) genders = 2},
With[{seats = couples genders},
And @@ Flatten@Join[
(* Fix position of one person. *)
{s[1, 1, 1]},
(* Exactly one person per seat. *)
Table[
BooleanCountingFunction[{1}, couples genders] @@
Flatten@Table[s[i, j, k], {j, couples}, {k, genders}], {i,
seats}],
(* Exactly one instance of each person. *)
Table[
BooleanCountingFunction[{1}, seats] @@
Table[s[i, j, k], {i, seats}], {j, couples}, {k, genders}],
(* At most one person from a couple per adjacent seats. *)
Table[
BooleanCountingFunction[1, 2 genders] @@
Flatten@Table[s[i, j, k], {i, {##}}, {k, genders}], {j, couples}] & @@@
EdgeList@CycleGraph[seats]]
// SatisfiabilityCount]]


1488

With[{couples = 4, (* Just for clarity: *) genders = 2},
With[{seats = couples genders},
With[{sols = And @@ Flatten@Join[
(* Fix position of one person. *)
{s[1, 1, 1]},
(* Exactly one person per seat. *)
Table[
BooleanCountingFunction[{1}, couples genders] @@
Flatten@Table[s[i, j, k],
{j, couples}, {k, genders}], {i, seats}],
(* Exactly one instance of each person. *)
Table[
BooleanCountingFunction[{1}, seats] @@ Table[s[i, j, k],
{i, seats}], {j, couples}, {k, genders}],
(* At most one person from a couple per adjacent seats. *)
Table[
BooleanCountingFunction[1, 2 genders] @@
Flatten@Table[s[i, j, k],
{i, {##}}, {k, genders}], {j, couples}] & @@@
EdgeList@CycleGraph[seats]] //
(* Pick variables (s[seat, couple, gender]) which are true. *)
With[{vars =
Flatten@Table[
s[i, j, k], {i, seats}, {j, couples}, {k, genders}]},
Pick[vars, #] & /@ SatisfiabilityInstances[#, vars, All] &]},
(* Draw a sample of graphs of seatings with couples. *)
With[{samples = UpTo, perrow = UpTo},
(Graphics[
{Circle[],
Table[
With[{pp = {Sin[#], Cos[#]} & /@ (# 2 \[Pi]/seats)},
{Black, Line@pp,
LightRed, Disk[First@pp, 1/5],
LightBlue, Disk[Last@pp, 1/5],
Black, Text[i, #] & /@ pp}] &@
SortBy[Last][Cases[#, s[s_, i, g_] :> {s, g}]][[All, 1]], {i, couples}]}] & /@
RandomSample[sols, samples]) //
GraphicsGrid@Partition[#, perrow] &]]]] By adding the following constraint to the problem we can find out that there are only 12 solutions where genders alternate around the table (odd seats must have a female, even seats a male):

(* Genders must alternate. *)
Table[Or @@ Table[s[i, j, Mod[i, 2, 1]], {j, couples}], {i, seats}], couples = Graph[Array[h[#] <-> w[#] &, 4]]

seatingplans = FindCycle[GraphComplement[couples], {8}, All]

Length[seatingplans]
(* 744 *)

Graph[RandomChoice@seatingplans,
VertexLabels -> Placed[Automatic, Center], VertexSize -> 0.75] • Using Flatten@Array[{h[#] -> w[#], w[#] -> h[#]} &, 4] instead of Array[h[#] <-> w[#] &, 4] would also produce reverse orderings like other answers. Feb 21 at 16:03

Label the attendees as (1, -1, 2, -2, 3, -3, 4, -4) where (1,2,3 and 4) are type 1 and (-1,-2,-3,-4) are their respective partners and are of type 2. There are two necessary conditions (done here for n=4 couples):

1. Assuming the types are distinguishable then the only valid seating arrangements are all of the "type 1s" in seats (1,3,5,7) or in seats (2,4,6,8).

2. No two side-by-side seats sum to 0. The third argument in ListConvolve wraps the first and last seats next to each other.

seatinglist =
Select[Permutations[Flatten[Table[{i, -i}, {i, 4}]]],
And [ Sort[#[[{1, 3, 5, 7}]]] == {1, 2, 3, 4} ||
Sort[#[[{2, 4, 6, 8}]]] == {1, 2, 3, 4},
Count[ ListConvolve[{1, 1}, #, -1], 0] == 0] &];
Length[seatinglist]
(* 96 *)