Mathematica 9 is now available
Services & Resources / Wolfram Forums
-----
 /
MathGroup Archive
1996
*January
*February
*March
*April
*May
*June
*July
*August
*September
*October
*November
*December
*Archive Index
*Ask about this page
*Print this page
*Give us feedback
*Sign up for the Wolfram Insider

MathGroup Archive 1996

[Date Index] [Thread Index] [Author Index]

Search the Archive

Re: Pairings

  • To: mathgroup at smc.vnet.net
  • Subject: [mg4475] Re: Pairings
  • From: rubin at msu.edu (Paul A. Rubin)
  • Date: Mon, 29 Jul 1996 02:37:27 -0400
  • Organization: Michigan State University
  • Sender: owner-wri-mathgroup at wolfram.com

In article <4shue0$g7n at ralph.vnet.net>,
   Robert Pratt <rpratt at math.unc.edu> wrote:
->I want a function that finds, given n, all pairings of Range[n] excluding
->{1,2}, {2,3}, {n-2,n-1}, and {n-1,n}.  One approach would be to find the
->appropriate permutations of Range[n] and then use Map[Partition[#,2],%]&. 
->For example, I would want specialpairings[4] to return {{{1,3},{2,4}}} 
and
->specialpairings[6] to return {{{1,3},{2,5},{4,6}}, {{1,4},{2,5},{3,6}},
->{{1,4},{2,6},{3,5}}, {{1,5},{2,4},{3,6}}, {{1,5},{2,6},{3,4}},
                                                         ^^^^^
->{{1,6},{2,4},{3,5}}, {{1,6},{2,5},{3,4}}}.
                                    ^^^^^

Am I misinterpreting your definition of "special" pairings?  Shouldn't two 
of these have been weeded?

->  I have worked out a formula 
->for the number of special pairings as a function of n, and 
->Length[specialpairings[8]] should be 57.

I only get 36 special pairings of 8.  Again, maybe I have the wrong 
definition.

->The well-known and easily derived formula for the number of pairings of 
->Range[n] is
->
->numberofpairings[n_]:=n!/((2^(n/2))(n/2)!)
->
->I can show that the number of special pairings is given by
->
->numberofspecialpairings[n_]:=((n^2-8n+19)/((n-1)(n-3))) 
numberofpairings[n]

Since numberofpairings[4] = 3 and (4^2-8*4+19)/((4-1)(4-3)) = 1, this 
predicts 3 special pairings of the first four integers, whereas I can find 
(and you list above) only one.

->Since these formulas are asymptotic to each other as n gets large, it's 
->completely reasonable to generate all pairings and throw out those which 
->contain any of the four "bad" pairs {1,2}, {2,3}, {n-2,n-1}, and {n-1,n}.
->
->The following naive method returns the desired results:  
->
->specialpairings[n_Integer]:=
->  Select[Union[
->    Map[Sort[#] &, Map[Partition[#,2] &, Permutations[Range[n]]],2]],
->    Intersection[#,{{1,2},{2,3},{n-2,n-1},{n-1,n}}] == {} &] 
->
->Of course, this function is VERY slow since there is a LOT of 
->duplication.  I would like to use some sort of backtracking technique to 
->make the function more efficient.  Does anyone have any suggestions?

->Rob Pratt
->Department of Mathematics
->The University of North Carolina at Chapel Hill
->CB# 3250, 331 Phillips Hall
->Chapel Hill, NC  27599-3250
->
->rpratt at math.unc.edu

I pasted this into Mathematica.  For n=6, it produced the following 
results:

In[]:=  Timing[ specialpairings[6] ]
Out[]=  {6.041 Second, {{{1, 3}, {2, 5}, {4, 6}},
          {{1, 4}, {2, 5}, {3, 6}}, {{1, 4}, {2, 6}, {3, 5}}, 
          {{1, 5}, {2, 4}, {3, 6}}, {{1, 5}, {2, 6}, {3, 4}}, 
          {{1, 6}, {2, 4}, {3, 5}}, {{1, 6}, {2, 5}, {3, 4}}}}

This includes the two instances of {3, 4} of which I am suspicious.  For 
n=8, it sent my hard disk into a black hole, spinning all the way.

Anyhow, here's a solution that uses recursion:

In[]:=
  sp[ {n_Integer, m_Integer} ] :=
    Module[
     {x, y},
     {x, y} = Sort[ {n, m} ];
     If[ y != x + 1, {{{x, y}}}, {{Null}} ]
    ]

  sp[ x_List ] :=
    Module[
      {y = Sort[ x ], z, n, m},
      z = 
        DeleteCases[ {First[ y ], #}& /@ Rest[ y ], {n_, m_} /; m == n + 1
        ];
      z = 
        Flatten[
          z /. {n_Integer, m_Integer} :> 
               (Append[ #, {n, m} ]& /@ sp[ Complement[ y, {n, m} ] ]),
          1
        ];
      Sort /@ DeleteCases[ z, {Null, ___} ]
    ] /; (And @@ (IntegerQ /@ x)) && EvenQ[ Length[ x ] ] &&
          Length[ x ] > 2

Results for n=6, 8 and 10 (edited for brevity):

In[]:=  Timing[ sp[ Range[ 6 ] ] ]
Out[]=  {0.604 Second, {{{1, 3}, {2, 5}, {4, 6}}, 
          {{1, 4}, {2, 5}, {3, 6}}, {{1, 4}, {2, 6}, {3, 5}}, 
          {{1, 5}, {2, 4}, {3, 6}}, {{1, 6}, {2, 4}, {3, 5}}} }
In[]:=  Timing[ sp[ Range[ 6 ] ] ][[1]]
Out[]=  0.385 Second

In[]:=  Timing[ sp[ Range[ 8 ] ] ]
Out[]=  {2.472 Second, {{{1, 3}, {2, 4}, {5, 7}, {6, 8}}, ...,
           {{1, 8}, {2, 7}, {3, 5}, {4, 6}}}}
In[]:=  Length[ %[[2]] ]
Out[]=  36
In[]:=  Timing[ sp[ Range[ 8 ] ] ][[1]]
Out[]=  2.746 Second

In[]:=  Timing[ sp[ Range[ 10 ] ] ][[1]]
Out[]=  20.048 Second

I ran the first two twice each, because Mma timings are notorious for 
being, shall we say, not entirely deterministic.  I believe this is partly 
due to its storage and reuse of itermediate results from expression 
evaluations.

As always with computer stuff, you can trade memory for time.  The 
following uses virtually the same function as sp[] above, but records 
results in memory for subsequent reuse:

In[]:=
  sp2[ {n_Integer, m_Integer} ] :=
    Module[
     {x, y},
     {x, y} = Sort[ {n, m} ];
     If[ y != x + 1, {{{x, y}}}, {{Null}} ]
    ]

  sp2[ x_List ] :=
    (sp2[x] =
      Module[
        {y = Sort[ x ], z, n, m},
        z = 
          DeleteCases[ {First[ y ], #}& /@ Rest[ y ], {n_, m_} /; 
                       m == n + 1
          ];
        z = 
          Flatten[
            z /. {n_Integer, m_Integer} :> 
                 (Append[ #, {n, m} ]& /@ sp2[ Complement[ y, {n, m} ] ]),
            1
          ];
        Sort /@ DeleteCases[ z, {Null, ___} ]
      ]
    ) /; (And @@ (IntegerQ /@ x)) && EvenQ[ Length[ x ] ] &&
          Length[ x ] > 2

In[]:=  Timing[ sp2[ Range[ 6 ] ] ]
Out[]=  {0.824 Second, {{{1, 3}, {2, 5}, {4, 6}},
          {{1, 4}, {2, 5}, {3, 6}}, {{1, 4}, {2, 6}, {3, 5}}, 
          {{1, 5}, {2, 4}, {3, 6}}, {{1, 6}, {2, 4}, {3, 5}}}}

In[]:=  Timing[ sp2[ Range[ 6 ] ] ][[1]]
Out[]=             -14
        -3.26406 10    Second

Note that the time for the second repetition is trivial, since the answer 
is stored in memory.

In[]:=  Clear[ sp2 ]; 
In[]:=  Timing[ sp[ Range[ 8 ] ] ]
Out[]=  {1.648 Second, {{{1, 3}, {2, 4}, {5, 7}, {6, 8}}, ...,
          {{1, 8}, {2, 7}, {3, 5}, {4, 6}}}}
In[]:=  Length[ %[[2]] ]
Out[]=  36
Timing[ sp2[ Range[ 8 ] ] ]

I cleared the definition of sp2 (and reloaded it, not shown above) to keep 
the timing comparison with sp on even footing.  For n=8, sp2[] is somewhat 
faster.

In[]:=  Timing[ sp2[ Range[ 10 ] ] ][[1]]
Out[]=  6.096 Second

For n=10 it is much faster, in part because I specifically did *not* clear 
out the old definition.  Having already run sp2[] over Range[8], when I ran 
it over Range[10], any call to sp2[] using argument sets not including 9 or 
10 pulled the answer from memory rather than recomputing it.

Paul

**************************************************************************
* Paul A. Rubin                                  Phone: (517) 432-3509   *
* Department of Management                       Fax:   (517) 432-1111   *
* Eli Broad Graduate School of Management        Net:   RUBIN at MSU.EDU    *
* Michigan State University                                              *
* East Lansing, MI  48824-1122  (USA)                                    *
**************************************************************************
Mathematicians are like Frenchmen:  whenever you say something to them,
they translate it into their own language, and at once it is something
entirely different.                                    J. W. v. GOETHE

==== [MESSAGE SEPARATOR] ====


  • Prev by Date: Re: ParametricPlot3D: shading?
  • Next by Date: Loading packages w/o write access
  • Previous by thread: Pairings
  • Next by thread: [Q] Plotting non-continuous function