7
$\begingroup$

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
$\endgroup$
4
  • 2
    $\begingroup$ 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. $\endgroup$
    – thorimur
    Feb 21 at 0:37
  • 2
    $\begingroup$ 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_]} $\endgroup$
    – thorimur
    Feb 21 at 0:39
  • $\begingroup$ @thorimur Thank you for your advice. $\endgroup$ Feb 21 at 0:42
  • 4
    $\begingroup$ 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. $\endgroup$
    – JimB
    Feb 21 at 3:44
3
$\begingroup$
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]

enter image description here

To get the associated permutations, map VertexList on cycles:

VertexList /@ % // Column

enter image description here

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]

enter image description here

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

enter image description here

Replace hamiltonianCycles with directedHamiltonianCycles in Multicolumn[...] above to get

enter image description here

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]

enter image description here

$\endgroup$
8
$\begingroup$

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

$\endgroup$
5
$\begingroup$

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

$\endgroup$
3
$\begingroup$
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

$\endgroup$
1
  • $\begingroup$ Using Flatten@Array[{h[#] -> w[#], w[#] -> h[#]} &, 4] instead of Array[h[#] <-> w[#] &, 4] would also produce reverse orderings like other answers. $\endgroup$
    – kirma
    Feb 21 at 16:03
1
$\begingroup$

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 *)
    
$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.