8
$\begingroup$

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}}
$\endgroup$
0

4 Answers 4

7
$\begingroup$

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]
$\endgroup$
3
  • $\begingroup$ I have downvoted because this is Mathematica StackExchange, so the answers are supposed to be written in Wolfram Language. $\endgroup$
    – Domen
    Aug 3, 2023 at 14:11
  • $\begingroup$ @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. $\endgroup$
    – Aky
    Aug 3, 2023 at 14:34
  • 2
    $\begingroup$ @Domen I wrote some Mathematica code - I'd appreciate someone making it more idiomatic, if possible. $\endgroup$
    – Aky
    Aug 3, 2023 at 15:00
4
$\begingroup$

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.

$\endgroup$
2
  • $\begingroup$ 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. $\endgroup$ Aug 3, 2023 at 14:00
  • $\begingroup$ Yes, you are right. $\endgroup$
    – 138 Aspen
    Aug 3, 2023 at 14:01
4
$\begingroup$

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}  *)
$\endgroup$
2
$\begingroup$

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, 
   raise2ToPowerOf2NeededMinus1, newNumberToAdd, elementInTheList, 
   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.*)
  newNumberToAdd = elementInTheList*raise2ToPowerOf2NeededMinus1; 
  listWithoutNumbers = Drop[list, raise2ToPowerOf2NeededMinus1]; 
  newList = 
   Prepend[newNumberToAdd][
    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, 
  powerOf2NeededMinus1, raise2ToPowerOf2NeededMinus1, newNumberToAdd, 
  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.

$\endgroup$
1
  • 3
    $\begingroup$ 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. $\endgroup$
    – Michael E2
    Aug 3, 2023 at 2:44

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.