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

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:

enter image description here

Visualize random samples:

DrawTable /@ RandomSample[result, 3]

enter image description here

DrawTable[# /. x_Integer :> Subscript[{"W", "H"}[[Sign@x]], Abs@x]] & /@ RandomSample[result, 3]

enter image description here


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

enter image description here

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

enter image description here


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]

enter image description here