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