Need Help Writing code to find Capparelli Partitions

Question

I am trying to add multiple criterion to

IntegerPartitions[n] 

so that it sorts only partitions that fit the criterion. It creates a list of list of numbers in descending orders and I want to eliminate all the ones that don't fit

• Has no part smaller than s (Already Solved)
• part s occurs at most k times (Already Solved)

• If elements are Dist apart then they are at least Diff apart
  i.e list[[i]] - list[[i+Dist]] >= Diff (Already Solved)

• If parts are a distance d from each other and they are within c of other
  i.e if list[[i]] - list[[i + d]] <= c
  then the sum of the parts between them (and the parts themselves) is 'm' mod 'M'

I can do some individual conditions like getting part s to occur no more than k times, but I have trouble getting it to check all these conditions. Any help would be appreciated.

EDIT: Thanks to LLlAMnYP for helping me get as far as I have. Now i have a list of list of integers in descending order and would just like to to filter out all the ones that don't fit the following criterion

• If parts are a distance d from each other and they are within c of other
  i.e if list[[i]] - list[[i + d]] <= c
  then the sum of the parts between them (and the parts themselves) is 'm' mod 'M'

Answer 1

Here's my implementation of satisfying the first two conditions.

capPartitions[n_Integer, s_Integer, k_Integer] := 
 Flatten[Table[
   Join[ConstantArray[s, i], #] & /@ 
    Select[IntegerPartitions[n - i s], AllTrue[#, # < s &] &],
    {i, k, 0, -1}], 1]

Not extremely efficient, rather generates more possible partitions than necessary, then filters the bad ones out.

Here's a function, that tests a list of numbers for satisfying the third condition:

testDiff = 
 AllTrue[Subtract @@ (Partition[#, Length@# - #2, #2]), 
   Function[{diff}, diff >= #3]] &

Usage: testDiff[partition, dist, diff], returns True or False.

Generate all partitions of 15 where 4 occurs no more than 3 times:

capPartitions[15, 4, 3];

Filter such, that elements 3 apart differ at least by 2:

Select[%, testDiff[#, 3, 2] &]

{{4, 4, 4, 2, 1}, {4, 4, 4, 1, 1, 1}, {4, 4, 3, 2, 2}, {4, 4, 3, 2, 1, 1}}

Hopefully this should get you started. I'll give the problem some more thought and try to come up with an update. Be warned, I haven't considered error-handling here yet. Mathematica may complain about inappropriate stuff with certain combinations of arguments.

1st update
Naturally, as commented under OP, checking the 3rd condition on a partition shorter than dist (using my algorithm) means partitioning it into sublists of negative length. So here's a better testDiff function, that gives the thumbs-up to any partition that's shorter than dist without wasting cpu time for the proper test:

testDiff =
 Which[Length@# < #2, True,
   True, AllTrue[Subtract @@ (Partition[#, Length@# - #2, #2]), 
    Function[{diff}, diff >= #3]]] &

For the moment a "to-do" remains for the first two conditions. As I said, capPartitions is a bit inefficient. Instead of running

Select[IntegerPartitions[n - i s], AllTrue[#, # < s &] &]

it would be much better to generate here only those partitions of n - i s whose biggest addend is smaller than s. That means only taking the last x partitions, which should be an analytically expressible quantity, but this will need a bit more thought on my part.

2nd update
To check the fourth criterion we need to examine each partition that remains after applying the previous criteria. Say, we have a partition of the form

{c1, c2, c3, c4, c5, c6, c7, c8, c9}

and we're interested in such sequences, that if two numbers are 4 apart and within, say, 2 of each other...

Partition[{c1...c9}, 4 + 1, 1] (* which gives... *)
{{c1, c2, c3, c4, c5},
 {c2, c3, c4, c5, c6},
 {c3, c4, c5, c6, c7},
 {c4, c5, c6, c7, c8},
 {c5, c6, c7, c8, c9}}

of which we select only those, where the difference of First@# - Last@# <= 2 & to the result of which we apply Total/@ then Mod[#, M]/@ then AllTrue[..., # == m]... this leads me to roll a function testMod which looks like this:

testMod = 
 AllTrue[Function[{tot}, Mod[tot, #4]] /@ 
    Total /@ (Select[Partition[#, #2 + 1, 1], 
       Function[{part}, (First@part - Last@part <= #3) && Length@part == #2 + 1]]),
         Function[{mod}, mod == #5]] &

testMod[partition, d, c, M, m] takes a list of integers (partition), and checks, if there are any subsequences, which are of length d + 1 (if not, the partition is too short and the criterion need not apply) whose first and last element differ by c or less, in which case it takes the total of the sequence (each subsequence of length d + 1, actually) and divides each total modulo M, then runs an AllTrue to check if each result is equal to m.

Here're the function definitions all in one block for easy copy-paste:

capPartitions[n_Integer,s_Integer,k_Integer]:=Flatten[Table[Join[ConstantArray[s,i],#]&/@Select[IntegerPartitions[n-i s],AllTrue[#,#<s&]&],{i,k,0,-1}],1]
testDiff=Which[Length@#<#2,True,True,AllTrue[Subtract@@(Partition[#,Length@#-#2,#2]),Function[{diff},diff>=#3]]]&
testMod=AllTrue[Function[{tot},Mod[tot,#4]]/@Total/@(Select[Partition[#,#2+1,1],Function[{part},(First@part-Last@part<=#3)&&Length@part>#2]]),Function[{mod},mod==#5]]&

Let's generate all Capparelli partitions of 15 with 4 occurring no more than 3 times...

capPartitions[15, 4, 3];

elements 6 apart must differ by 1...

Select[%, testDiff[#, 6, 1] &]

if elements are 4 apart and within 2 of each other then their sum plus the sum of those between them modulo 2 must equal 1...

Select[%, testMod[#, 4, 2, 2, 1] &]

{{4, 4, 4, 3}, {4, 4, 4, 2, 1}, {4, 4, 4, 1, 1, 1},
 {4, 4, 3, 3, 1}, {4, 4, 3, 2, 2}, {4, 4, 3, 2, 1, 1},
 {4, 4, 3, 1, 1, 1, 1}, {4, 4, 2, 2, 1, 1, 1},
 {4, 3, 3, 3, 2}, {4, 3, 3, 3, 1, 1},
 {4, 3, 3, 1, 1, 1, 1, 1}, {4, 3, 2, 2, 2, 2},
 {3, 3, 3, 3, 3}, {3, 3, 3, 3, 1, 1, 1},
 {3, 3, 3, 2, 2, 1, 1}, {3, 3, 3, 1, 1, 1, 1, 1, 1}
}

3rd update
Apparently, I cannot read (the documentation), because much of the functionality is already coded into the built-in IntegerPartitions[] function. Using the 2nd and 3rd argument we can make the capPartitions[] function much more efficient.

Let's revisit the OP (and this time I'll do it as he requests, with all addends not less than s). I also present the testDiff and testMod functions in a more human-readable form.

kMinAddendsS[n_Integer, s_Integer, k_Integer] := 
 Flatten[Table[
   Join[#, ConstantArray[s, i]] & /@ 
    IntegerPartitions[n - i s, All, Range[s + 1, n]], {i, k, 0, -1}], 
  1]

testDiff2[list_List, dist_Integer, diff_Integer] :=
 Which[Length@list < dist + 1, True,
  True, AllTrue[
   Subtract @@ (Partition[list, Length@list - dist, dist]), (# >= 
      diff &)]]

testMod2[list_List, d_, c_, M_, m_] :=
 Which[Length@list < d + 1, True,
  True, And @@ ((# == m &)@*(Mod[#, M] &)@*Total) /@ 
    DeleteCases[_?(First@# - Last@# > c &)]@Partition[list, d + 1, 1]]

capparelliPartitions[n_Integer, s_Integer: 0, k_Integer: 0, 
   dist_Integer: 1, diff_Integer: 0, d_Integer: 1, c_Integer: - 1, 
   M_Integer: 1, m_Integer: 1] /; s <= n/2 && n > 0 && s >= 0 :=
 Module[{partitions = kMinAddendsS[n, s, k]},
  partitions = Select[partitions, testDiff2[#, dist, diff] &];
  partitions = Select[partitions, testMod2[#, d, c, M, m] &]
  ]

The capparelliPartitions function includes some error handling and takes up to nine arguments. So one can limit himself to just the first condition, or just the first two, etc.