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

**Re: ParametricPlot3D: shading?**

**Loading packages w/o write access**

**Pairings**

**[Q] Plotting non-continuous function**