# Design a function that gives all strict partitions of an integer

A strict partition of an integer has all distinct parts. There are no duplicates like 1 in {5,3,1,1} for 10. All the parts are unique. Sylvester created a bijection between the partitions of an integer into odd numbers and the strict partitions of an integer. I tried to understand how to go from odd number partitions to strict partitions but I couldn't figure it out. For more details, please see https://arxiv.org/pdf/0812.2826.pdf. I can count the number of distinct partitions with PartitionsQ. I want to list all them, not count them. I can generate all strict partitions of an integer, say 13 with

(n |-> Select[IntegerPartitions[n], Sort[#] == Union[#] &])[13]


This also works.

(n |-> Select[IntegerPartitions[n], DuplicateFreeQ[#] &])[13]


I want to use an alternative method that only computes necessary partitions instead of computing all partitions and selecting the ones that have no duplicates. I can compute all the partitions into odd numbers with for example

IntegerPartitions[13,Infinity,Range[1,13,2]]


If I could figure out a way to use Sylvesters bijection to from the output of

{{13}, {11, 1, 1}, {9, 3, 1}, {9, 1, 1, 1, 1}, {7, 5, 1}, {7, 3,
3}, {7, 3, 1, 1, 1}, {7, 1, 1, 1, 1, 1, 1}, {5, 5, 3}, {5, 5, 1, 1,
1}, {5, 3, 3, 1, 1}, {5, 3, 1, 1, 1, 1, 1}, {5, 1, 1, 1, 1, 1, 1, 1,
1}, {3, 3, 3, 3, 1}, {3, 3, 3, 1, 1, 1, 1}, {3, 3, 1, 1, 1, 1, 1,
1, 1}, {3, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1}, {1, 1, 1, 1, 1, 1, 1, 1,
1, 1, 1, 1, 1}}


to the output of

{{13}, {12, 1}, {11, 2}, {10, 3}, {10, 2, 1}, {9, 4}, {9, 3, 1}, {8,
5}, {8, 4, 1}, {8, 3, 2}, {7, 6}, {7, 5, 1}, {7, 4, 2}, {7, 3, 2,
1}, {6, 5, 2}, {6, 4, 3}, {6, 4, 2, 1}, {5, 4, 3, 1}}


Then I could make a more efficient program to compute the strict partitions. I could name it StrictPartitions. How can I get the strict partitions from the odd partitions? Even if you are also confused by the article I linked, if you have a good example of someone explaining using Sylvester's bijection to go from odd partitions to strict partitions I would appreciate knowing about it.

I would like to design a function StrictIntegerPartitions that lists the strict integer partitions of a strictly positive integer 1 by 1 by one.

The function would be defined as something like this.

StrictIntegerPartitions[n_Integer?IntegerQ/;Not[n<=0]]:=OddPartitionsToStrictPartitions[IntegerPartitions[n,Infinity,{1,n,2}]


I do not want to use Select to find the solution. I do not need to use Select. I can generate all partitions of an integer into odd parts, then keep merging odd parts until there are no duplicate odd parts left like {3,3,3,1,1,1,1} to {6,3,2,2,} to {6,3,4} to {6,4,3}. Select generates partitions I do not need. That is why I do not want to use it. The partition of an integer into odd parts can be generated with IntegerPartitions[n, Infinity,Range[1, n, 2]] for an integer n. For example,

IntegerPartitions[10, Infinity, Range[1, 10, 2]]


returns

{{9,1},{7,3},{7,1,1,1},{5,5},{5,3,1,1},{5,1,1,1,1,1},{3,3,3,1},{3,3,1,1,1,1},{3,1,1,1,1,1,1,1},{1,1,1,1,1,1,1,1,1,1}}


I randomly came across this question today, and remembered I'd written a function to do this in Haskell not too long ago.

  distinctPartitions 0 = [[]]
distinctPartitions n = [x:xs | x <- [1..n], xs <- distinctPartitions (n - x), null xs || x < head xs]


Here's my (probably clumsy) attempt to translate this to Mathematica (with memoization):

distinctPartitions[0] := distinctPartitions[0] = {{}};
distinctPartitions[n_] :=
distinctPartitions[n] =
Flatten[Table[
Prepend[xs, x], {x, 1, n}, {xs,
Select[distinctPartitions[n - x],
Length@# == 0 || x < First@# &]}], 1]

• I have downvoted because this is Mathematica StackExchange, so the answers are supposed to be written in Wolfram Language. Aug 3, 2023 at 14:11
• @Domen Fair enough ¯\_(ツ)_/¯. I tried to post it as a comment, but couldn't do a code block. I found the code in the other answers rather verbose, and figured someone else might translate my attempt to Mathematica and "upgrade" this answer. I'm sure it's easy to do with a mixture of Table, Select and what-have-you.
– Aky
Aug 3, 2023 at 14:34
• @Domen I wrote some Mathematica code - I'd appreciate someone making it more idiomatic, if possible.
– Aky
Aug 3, 2023 at 15:00

Three cases:

1. distinct parts
2. all elements are odd
3. number of parts is odd.

We now focus on the bijection between case 1 and case 2.

# Mathematica code ✅

distinctPartitionsOf13 = (n |-> Select[IntegerPartitions[n], DuplicateFreeQ[#] &])[13];
oddElementPartitionsOf13 = IntegerPartitions[13, Infinity, Range[1, 13, 2]];
oddPartsPartitionsOf13 = IntegerPartitions[13, {1, Infinity, 2}, All];

Length /@ {distinctPartitionsOf13, oddElementPartitionsOf13,
oddPartsPartitionsOf13}   (* {18,18,52} *)


### distinctToOddElement

(* Helper function to split even numbers until no evens remain *)
splitEven[n_] :=
If[EvenQ[n], Flatten[{splitEven[n/2], splitEven[n/2]}], n]

(* Function to convert a partition with distinct parts to odd parts *)
distinctToOddElement[partition_List] := Flatten[splitEven /@ partition]

generatedOddElementPartitionsOf13 = distinctToOddElement/@ distinctPartitionsOf13;

Sort@Map[Sort, generatedOddElementPartitionsOf13 ] ==
Sort@Map[Sort, oddElementPartitionsOf13 ]



### oddElementToDistinct

binaryDecomposition[n_Integer] :=
Reverse[2^Flatten[Position[Reverse[IntegerDigits[n, 2]], 1] - 1]]

helper[lst_] :=
Flatten@Table[ele[[1]]*binaryDecomposition[ele[[2]]], {ele, lst}];

oddElementToDistinct[partition_List] := helper@Tally@partition

generatedDistinctPartitionsOf13 =
oddElementToDistinct /@ oddElementPartitionsOf13

Sort@Map[Sort, generatedDistinctPartitionsOf13] ==
Sort@Map[Sort, distinctPartitionsOf13]


# Reference

Use the method found on OEIS A000009.

Bijection: given n = L1*1 + L2*3 + L3*5 + L7*7 + ..., a partition into odd parts, write each Li in binary, Li = 2^a1 + 2^a2 + 2^a3 + ... where the aj's are all different, then expand n = (2^a1 * 1 + ...)*1 + ... by removing the brackets and we get a partition into distinct parts. For the reverse operation, just keep splitting any even number into halves until no evens remain.

• You can improve oddPartsPartitionsOf13 = (n |-> Select[IntegerPartitions[n], OddQ@Length@# &])[13]; by doing IntegerPartitions[13, {1, Infinity, 2}, All] instead to generate partitions of 13 with an odd lengths instead of generating unnecessary partitions and selecting the ones with Select. Aug 3, 2023 at 14:00
• Yes, you are right. Aug 3, 2023 at 14:01

The OP professed an interest to "make a more efficient program to compute the strict partitions," but as yet no one has addressed timing.

Block[{n = 61},
Join @@@
KeyValueMap[#1*(#*2^Range[Length[#] - 1, 0, -1] &@
IntegerDigits[#2, 2]) &] /@
Counts /@ IntegerPartitions[n, Infinity, Range[1, n, 2]] /.
0 -> Nothing (* zero counts for nothing *)
] // Length // AbsoluteTiming

(*  {0.15744, 12076}  *)


I figured out a solution.

StrictIntegerPartitions[n_] := Reverse[LexicographicSort[ (Map[BlockNewOddPartsToDistinctParts])[IntegerPartitions[n, Infinity, Range[1, n, 2]]]]] BlockNewOddPartsToDistinctParts[partition_] := ReverseSort[FixedPoint[Catenate[Split[#1] /. list:{Repeated[x_, {2, Infinity}]} :> BlockFunction[list]] & , partition]] BlockFunction[list_ /; SameQ @@ list] := Block[{length, powerOf2Needed, powerOf2NeededMinus1, raise2ToPowerOf2NeededMinus1, newNumberToAdd, elementInTheList, listWithoutNumbers, newList}, length = Length[list]; powerOf2Needed = BitLength[length]; powerOf2NeededMinus1 = powerOf2Needed - 1; raise2ToPowerOf2NeededMinus1 = 2^powerOf2NeededMinus1; elementInTheList = First[list]; newNumberToAdd = elementInTheList*raise2ToPowerOf2NeededMinus1; listWithoutNumbers = Drop[list, raise2ToPowerOf2NeededMinus1]; newList = Prepend[newNumberToAdd][listWithoutNumbers]]


Here is my solution formatted better.

BlockFunction // ClearAll
BlockFunction[list_ /; SameQ @@ list] :=
Block[{length, powerOf2Needed, powerOf2NeededMinus1,
listWithoutNumbers, newList}, length = Length[list];
powerOf2Needed = BitLength[length];
powerOf2NeededMinus1 = powerOf2Needed - 1;
raise2ToPowerOf2NeededMinus1 = Power[2, powerOf2NeededMinus1];
elementInTheList =
First[list];(*If we assume all the elements are the same,
this should give the correct result. For example in {1,1,1,1,1,1,
1}, First will give 1.*)
listWithoutNumbers = Drop[list, raise2ToPowerOf2NeededMinus1];
newList =
listWithoutNumbers]](*I used Block because its faster than Module. The only problem with this is that Block can make things hard to debug.*)

BlockNewOddPartsToDistinctParts[partition_] :=
ReverseSort[
FixedPoint[
Catenate[
Split[#] /.
list : {Repeated[x_, {2, Infinity}]} :> BlockFunction[list]] &,
partition]]

StrictIntegerPartitions[n_] :=
Return[Reverse[
LexicographicSort[
Map[BlockNewOddPartsToDistinctParts][
IntegerPartitions[n, Infinity,
Range[1, n, 2]]]]]]; Remove[{length, powerOf2Needed,
elementInTheList, listWithoutNumbers,
newList}](*I remove the Block variables so I don't have trouble \
debugging.*)


I have a faster and very slightly more memory efficient solution.

functionWithoutVariables[partition_] :=
Join[{First[partition]*2^(BitLength[Length[partition]] - 1)},
Drop[partition, 2^(BitLength[Length[partition]] - 1)]]
NoVariablesOddPartsToDistinctParts[partition_] :=
ReverseSort[
FixedPoint[
Catenate[
Split[#] /.
list : {Repeated[x_, {2, Infinity}]} :>
functionWithoutVariables[list]] &, partition]]
NoVariablesStrictIntegerPartitions[n_] :=
Reverse[LexicographicSort[
Map[NoVariablesOddPartsToDistinctParts][
IntegerPartitions[n, Infinity, Range[1, n, 2]]]]];


The benefit of this I did not use Block to make things hard to debug.

• Copying & pasting & trying your code gives an error. You should improve the format of this post, not just so it's correct but also readable. Aug 3, 2023 at 2:44