# Find all "chains" in the poset of divisors

I want to input a set of divisors of an integer $n$ and return all subsets of these divisors ${d_1,d_2,...d_k=n}$ such that $d_1$ divides $d_2$, $d_2$ divides $d_3$, ... and $d_(k-1)$ divides $d_k$. I would like to have a code that could be understood by a beginner Mathematica user.

• As a possible starting point: Select[Subsets[Divisors[n], {3, DivisorSigma[0, n]}], And @@ (Divisible @@@ Partition[Reverse[#], 2, 1]) &]; doing this in a more efficient manner is something I'll leave for people smarter than me to do… ;) Jun 3, 2015 at 13:38
• Re: I would like to have a code that could be understood by a beginning Mathematica user.. Code is just code, and can be understood by anyone furnished with suitable documentation, the appropriate behavioral drivers and some time to spare. Sometimes it can be understood by language interpreters too. Jun 4, 2015 at 0:48
• @Belisarius, Thanks for your comment. Here is what happens when a beginning Mathematica user has lots of time to spare:Table[Timing[ Table[Length[ Select[Subsets[Divisors[n], {k}], Apply[And, Map[Apply[Divisible, #] &, Partition[Reverse[#], 2, 1]]] &]], {k, 1, PrimeOmega[n] + 1}]], {n, Table[Apply[Times, Prime[Range[m]]], {m, 0, 5}]}] ... and we are led to Sloane's OEIS A038719 Jun 4, 2015 at 15:08
• @GeoffreyCritzer Nice!. This is the equivalent expression using my answer Join @@ (Join[{DivisorSigma[0, #]}, Tally[Length /@ allChains[#]][[All, 2]]] & /@ Table[Times @@ Prime[Range[m]], {m, 1, 7}]) .But I think it's slower! Jun 4, 2015 at 16:12
• with Timing[Join @@ (Join[{DivisorSigma[0, #]}, Tally[Length /@ allChains[#]][[All, 2]]] & /@ Table[Times @@ Prime[Range[m]], {m, 1, 5}])] Jun 4, 2015 at 19:39

A graph representation:

opts = {VertexLabels -> "Name", ImagePadding -> 10};

g[n_] := Graph[Flatten[Thread[DirectedEdge[#, Most@Divisors@#]] & /@ Divisors@n], opts]

aa = g[30]


Then (v10 only, thanks to @billc for running it for me):

fp = FindPath[aa, 30, 1, Infinity, All]
(*
{{30, 1}, {30, 15, 1}, {30, 10, 1}, {30, 6, 1}, {30, 5, 1},
{30, 3, 1}, {30, 2, 1}, {30, 15, 5, 1}, {30, 15, 3, 1}, {30, 10, 5, 1},
{30, 10, 2, 1}, {30, 6, 3, 1}, {30, 6, 2, 1}}
*)


(For pre-v10 options see here)

Now, all the adjacent sublists in those lists are valid chains.

Union @@ (Flatten[Table[#[[i ;; j]], {j, 2, Length@#}, {i, 1, j - 1}], 1] & /@ fp)

(*
{{2, 1}, {3, 1}, {5, 1}, {6, 1}, {6, 2}, {6, 3}, {10, 1}, {10, 2},
{10, 5}, {15, 1}, {15, 3}, {15, 5}, {30, 1}, {30, 2}, {30, 3}, {30, 5},
{30, 6}, {30, 10}, {30, 15}, {6, 2, 1}, {6, 3, 1}, {10, 2, 1}, {10, 5, 1},
{15, 3, 1}, {15, 5, 1}, {30, 2, 1}, {30, 3, 1}, {30, 5, 1}, {30, 6, 1},
{30, 6, 2}, {30, 6, 3}, {30, 10, 1}, {30, 10, 2}, {30, 10, 5}, {30, 15, 1},
{30, 15, 3}, {30, 15, 5}, {30, 6, 2, 1}, {30, 6, 3, 1}, {30, 10, 2, 1},
{30, 10, 5, 1}, {30, 15, 3, 1}, {30, 15, 5, 1}}
*)


The last step is also equivalent to:

Union@Flatten[ReplaceList[#, {___, i_, x___, j_, ___} :> {i, x, j}] & /@ fp, 1]


Finally, the whole thing can be packed up in a function like:

allChains[n_] := Module[{a, fp},
a = Graph@ Flatten[Thread[DirectedEdge[#, Most@Divisors@#]] & /@ Divisors@n];
fp = FindPath[a, n, 1, Infinity, All];
Union @@ (Flatten[Table[#[[i ;; j]], {j, 2, Length@#}, {i, 1, j - 1}], 1] & /@ fp)
]

• Looks great! I think your use of an abundant number is a good example… Jun 3, 2015 at 23:07
• @J. M. Glad you like it. I enjoy a lot this kind of solutions, trying to convert a problem into some area where Mma is strong. Jun 3, 2015 at 23:26