# Better code for Ramsey partitions

Ramsey partitions for parameters $$a$$ and $$b$$ are certain integer partition of $$a+b$$ developed by McAvaney, Robertson, and Webb (Combinatorica 1992) for applications in fair division problems where two players are to receive unequal shares.

They describe a test for whether a partition of $$a+b$$ (written in weakly decreasing order) is a Ramsey partition for $$a$$ and $$b$$: If when summing terms in the order in which they appear, leaving out whichever terms you wish, your sums do not skip over either $$a$$ or $$b$$.

So, for example, $$(5,3,3,3,2,2,1,1,1)$$ is not a Ramsey partition for $$8$$ and $$13$$, because $$5+3+3=11$$ and $$5+3+3+3=14$$, so 13 was skipped; or $$3+3=6$$ and $$3+3+3 = 9$$, so 8 was skipped.

For another example, $$(8,5,3,3,1,1)$$ is also not a Ramsey partition for $$8$$ and $$13$$ since $$8+3 = 11$$ and $$8+3+3=14$$, so 13 was skipped. (No subsets of these parts skip 8.)

A positive example is $$(8,5,3,2,1,1,1)$$, which is the Ramsey partition for $$8$$ and $$13$$ with the least number of parts. A boring Ramsey partition for $$8$$ and $$13$$ is the partition of 21 consisting of 21 parts 1.

I implemented this with the following code to find the Ramsey partitions for $$a$$ and $$b$$. It works but is very inefficient.

Skips[p_] :=
Complement[Range[Total[p]], Flatten[Map[Accumulate, Subsets[p]]]]

RP[a_, b_] :=
Cases[IntegerPartitions[a + b],
p_ /; FreeQ[Map[Skips, Subsets[p]], a] &&
FreeQ[Map[Skips, Subsets[p]], b]]


Tips on improving this code would be greatly appreciated.

Update 3:

We get further speed-up by (1) working with the left parts of partitions with elements $$\geq 2$$ and appending the results with appropriate number of 1s in the last step; and (2) making the list of candidates shorter by filtering out the ones that skip over a or b before performing the test on all remaining subsets:

rQ[targets : {__Integer}] :=
And @@ Table[Or[Last @ # < t, MemberQ[t] @ #], {t, targets}] &;

ramseyQ2[targets : {__Integer}] :=
AllTrue[rQ[targets] @* Accumulate] @
Reverse @
Subsets[#, {2, Length[#] - 1}] &;

SRP[{a_, a_}] := {a, a}

SRP[{a_, b_}] := Flatten[{Min[a, b], SRP[{Min[a, b], Abs[b - a]}]}, 1]

ramseyPartitions2 =
Module[{tl = #, t = Total @ #, m = Min @ #, l = Length @ SRP[#]},
Prepend[SRP[#]] @
Append[ConstantArray[1, t]]@
Map[PadRight[#, Length@# + t - Total@#, 1] &] @
Select[ramseyQ2[tl]] @
Select[rQ[tl] @* Accumulate] @
Select[Length @ # >= 1 &] @
Map[Select[# >= 2 &]] @
IntegerPartitions[t-1, {l, t-1}, Range @ m]] &;

rp2 = ramseyPartitions2[{8, 13}]; // AbsoluteTiming // First

 0.006318

rp2 == rp

 True


Update 2: Complete list of Ramsey partitions:

We can cut the size of candidate partitions by half from 792 (which is Length @ IntegerPartitions[Total[{8, 13}]]) to 386 using

Length @ IntegerPartitions[Total[{8, 13}],
{Length @ SRP[{8, 13}], Total @ {8, 13}},
Range @ Min @ {8, 13}]

386


However, both numbers being small, possible speed-ups can only come from faster functions for testing Ramsey property.

Three observations help to get much faster test function:

For each element t of the target {a, b}, we

1. Check only subsets of the candidate list with elements greater than 1, because skips cannot occur in the right tail (containg 1s) of a candidate partition.
2. Check only subsets with length 2 to Ceiling[t/2]
3. Define the test function for {a,b} (rather than defining for a single integer argument, and mapping it to a and b, and combining the result with And) to avoid computing Accumulate[Subsets[...]] twice.

Using ramseyQ which uses these three observations, we get a 500X+ speed improvement:

ClearAll[ramseyQ, ramseyPartitions]

ramseyQ[targets : {__Integer}, list : {__Integer}] :=
AllTrue[Apply[And] @ Table[MemberQ[#, t] || t > Last[#], {t, targets}] &]@
Map[Accumulate] @
Reverse @
Subsets[Select[# >= 2 &] @ list, {2, Ceiling[Max[targets]/2]}];

ramseyPartitions[targets : {__Integer}] :=
Module[{t = Total @ targets, m = Min @ targets, l = Length @ SRP[targets]},
Select[ramseyQ[targets, #] &] @
IntegerPartitions[t, {l, t}, Range @ m]]

rp = ramseyPartitions[{8, 13}]; // AbsoluteTiming // First

0.03162

 Column @ rp


Update: A shorter and faster alternative recursion to find the shortest Ramsey partition:

SRP[{a_, a_}] := {a, a}

SRP[{a_, b_}] := Flatten[{Min[a, b], SRP[{Min[a, b], Abs[b - a]}]}, 1]

SRP[{8, 13}] // AbsoluteTiming

{0.00004, {8, 5, 3, 2, 1, 1, 1}}

And @@ (shortestRamseyPartition @ # == SRP [#] & /@
RandomInteger[{2, 50}, {20, 2}])

True


A simple implementation of the method in McAvaney, Robertson, and Webb using NestWhileList:

ClearAll[step, shortestRamseyPartition]

step[{a_, b_}] := {Min[a, b], Abs[b - a]};
shortestRamseyPartition[{a_, a_}] := {a, a}

shortestRamseyPartition[{a_, b_}] :=
Join[#, If[a + b == Total[#], {},
ConstantArray[Last @ #, (a + b - Total[#]) / Last[#]]]] & @
NestWhileList[step, {a, b}, Apply[Unequal]][[2 ;;, 1]]


Examples:

shortestRamseyPartition[{8, 13}] // AbsoluteTiming

{0.000315, {8, 5, 3, 2, 1, 1, 1}}

shortestRamseyPartition[{17, 9}] // AbsoluteTiming

{0.000108, {9, 8, 1, 1, 1, 1, 1, 1, 1, 1, 1}}

shortestRamseyPartition[{6, 15}] // AbsoluteTiming

{0.000087, {6, 6, 3, 3, 3}}


Using RamseyQ from lericr's answer to verify:

RamseyQ[#, shortestRamseyPartition[#]] & /@ {{8, 13}, {6, 15}, {17, 9}}

{True, True, True}

SeedRandom[77];

Grid[{#, shortestRamseyPartition @ #} & /@ RandomInteger[{2, 50}, {20, 2}],
Alignment -> Left, Dividers -> All]


• Yes, there's a nice way to find the minimal Ramsey partition which has interesting connections to the Euclidean algorithm. I'm more interested in the enumeration of all Ramsey partitions, e.g., efficiently testing all the partitions of 21 to find the 46 that are Ramsey partitions for 8 and 13. Commented Oct 10, 2023 at 2:23
• @BrianHopkins, please see Update 2 for a faster enumeration.
– kglr
Commented Oct 10, 2023 at 5:59
• That's a nice observation that we can skip all the partitions shorter than the shortest Ramsey partition. In your ramseyQ, do you mean to reference lericr's RamseyQ, or is that a typo and you meant ramseyQ? Either way, I'm having a hard time recreating your result. Commented Oct 10, 2023 at 12:25
• Wonderful -- this allows me to extend Table 2 of the paper, which seems to have stopped at partitions of 27. Commented Oct 10, 2023 at 14:10
• Interesting idea; it reminds me of Brylawski's operations related to the dominance partial order on partitions. Maybe instead of restricting to partitions with at least SRP's number of parts, it would be better to look at all partitions lower than the SRP and screen those for Ramseyness, as you called it. Commented Oct 10, 2023 at 22:48

This implementation is faster than yours, but probably not optimal. Given how fast IntegerPartitions grows, I'm not optimistic that anything will be acceptably performant for anything but small integers.

RamseyQ[target_Integer, list : {___Integer}] :=
AllTrue[Accumulate /@ Rest[Subsets[list]], MemberQ[#, target] || target > Last[#] &];
RamseyQ[targets : {__Integer}, list_] :=
And @@ (RamseyQ[#, list] & /@ targets);
RamseyPartitions[targets : {__Integer}] :=
Select[IntegerPartitions[Total[targets]], RamseyQ[targets, #] &]


The following took about 30 seconds and found 46 RamseyPartitions. I don't know the correct result without checking them all by hand, so I haven't proven that this implementation is correct.

RamseyPartitions[{8, 13}]


I did check my implementation against yours for smaller integers, and the results agreed.

• There are, in fact, 46 Ramsey partitions for 8 & 13 (the authors list them). Commented Oct 10, 2023 at 2:15