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