2
$\begingroup$

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'
Improve this question
$\endgroup$
12
  • 1
    $\begingroup$ Any given partition must satisfy these criteria or the entire set of possible partitions (I mean part s occurring no more than n times)? The n in IntegerPartitions[n] is not the same as the limit for number of occurrences of part s? Please show how you managed to get the s and n part of the task to work. $\endgroup$ Commented Aug 18, 2015 at 15:19
  • 1
    $\begingroup$ Welcome to Mathematica.SE! I hope you will become a regular contributor. To get started, 1) take the introductory Tour now, 2) when you see good questions and answers, vote them up by clicking the gray triangles, because the credibility of the system is based on the reputation gained by users sharing their knowledge, 3) remember to accept the answer, if any, that solves your problem, by clicking the checkmark sign, and 4) give help too, by answering questions in your areas of expertise. $\endgroup$ Commented Aug 18, 2015 at 15:23
  • $\begingroup$ I have also formatted your post, please check if I have not distorted any intent (e.g. changed the sign of inequality for the last criterion, as you say, it should be within c). Apart from that, I've changed C and D to lowercase, as both of these in uppercase are reserved symbols in Mathematica. $\endgroup$ Commented Aug 18, 2015 at 15:27
  • $\begingroup$ @LLlAMnYP, no the the n in IntegerPartitions[n] is not the same as the limit for number of occurrences of part s. sorry about that. I do not have the file where i had those two working on me put i will post it in a few hours when am at that computer. The way i went about it was counting the number of occurences of the element in the list and then removing elements less then the value desired. I assumed that i could use this as an index once the code was working better $\endgroup$ Commented Aug 18, 2015 at 15:56
  • $\begingroup$ @LLlAMnYP also thanks for the formatting help that makes my post a lot more readable and you got all the info right by the looks of it $\endgroup$ Commented Aug 18, 2015 at 16:03

1 Answer 1

Reset to default
2
$\begingroup$

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.

Improve this answer
$\endgroup$
4
  • $\begingroup$ That works pretty well, except i had a typo in my original question that was minor and i fixed it. I changed it from bigger to smaller in the first condition and all that meant was changing > to < in the fourth line of cappartitions. that is my fault though. thanks for all your help and i will keep working on conditions 3 and 4 $\endgroup$ Commented Aug 18, 2015 at 16:53
  • $\begingroup$ Looking forward to you expanding this, +1 $\endgroup$ Commented Aug 19, 2015 at 0:41
  • $\begingroup$ @StephenHill, ciao, updated. Horrible code, lot's of optimizing to do. Perhaps other contributors would be interested in making this better? Also, I didn't realize until now, that all addends must be bigger than s. In that case, not only should the inequality be reversed, but also the order of arguments in Join to maintain the decreasing order of addends in a partition. $\endgroup$ Commented Aug 19, 2015 at 9:31
  • $\begingroup$ @StephenHill I've updated again with a more human-readable form and rolled all three functions for satisfying the various conditions into one Module. Hope it works. $\endgroup$ Commented Aug 22, 2015 at 16:30

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.