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.
s
occurring no more thann
times)? Then
inIntegerPartitions[n]
is not the same as the limit for number of occurrences of parts
? Please show how you managed to get thes
andn
part of the task to work. $\endgroup$ – LLlAMnYP Aug 18 '15 at 15:19c
). Apart from that, I've changedC
andD
to lowercase, as both of these in uppercase are reserved symbols in Mathematica. $\endgroup$ – LLlAMnYP Aug 18 '15 at 15:27