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

Question

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]] - 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@
       MapThread[
         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"[1]] & /@ 
    Permutations[
     Flatten[Table[Array[i, 2], {i, Alphabet[][[1 ;; 4]]}]] // 
      Rest], {___, x_[_], x_[_], ___}], {x_[_], __, x_[_]}] // Length

Answer 1

couples = Partition[Range @ 8, 2]

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

pairs = Complement[Subsets[Range[8], {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[[1]] &, couples])];

Multicolumn[Graph[#, VertexLabels -> vlabels, VertexLabelStyle -> Small, 
    VertexSize -> Large, ImageSize -> 200, 
    VertexStyle -> 
     MapIndexed[Alternatives @@ # -> ColorData[97][#2[[1]]] &, 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[6]

{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[97][#2[[1]]] &, 
      Partition[Range[2 nc], 2]]] & /@ RandomSample[hc[nc], 16], 4]

Answer 2

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

Answer 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[20], perrow = UpTo[4]},
    (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}],

Answer 4

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]

Answer 5

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 *)