# Test if the decimal digits of $n$ appear $n$ times in the decimal representation of $n!$

I want to find numbers $$n$$ for which the decimal digits of $$n$$ appear $$n$$ times in the decimal representation of $$n!$$.

For instance, $$n\in\left\{0, 1, 1170, 1528, 9877, 9886, 9897, 11535\right\}$$ are known to have this property.

I came up with the following code:

Clear["Global*"];
k = Factorial[n];
p = IntegerDigits[k];
n = 0;
Monitor[Parallelize[
While[True,
If[n == Length[p] -
Length[p /. Thread[IntegerDigits[n] -> Nothing]], Print[n]];
n++]; n], n]


This becomes pretty slow after some time (for $$n\ge200000$$). Is there a faster way?

• Just so I understand, can you explain how 1170 is a solution? I would have guessed that this means that the sequence 1,1,7,0 appears 1170 times in 1170!. But I don't think that's possible. Aug 16, 2022 at 22:31
• Oh, I see. So if I add up the number of 1s, 7s, and 0s in 1170! I get 1170. Aug 16, 2022 at 22:34
• @lericr indeed that is the case. Aug 16, 2022 at 22:40
• So, what kind of timings are you getting so far? Aug 16, 2022 at 22:42

20000 in 21 seconds.

Clear["Global*"];
n = 0;
k := Factorial[n];
p := IntegerDigits[k];
Do[
co = Counts[p];
If[Total[
Table[co[[Key[i]]], {i, DeleteDuplicates[IntegerDigits[n]]}]] ==
n, Print[n]];
n++, 20000]


In red, points (some overlapping) where the difference between the sum of digits and n is 0. Interesting pattern.

Here is an attempt:

IsSpecial[n_Integer] :=
With[
{uniqueDigits = DeleteDuplicates[IntegerDigits[n]]},
n == Count[IntegerDigits[n!], Alternatives @@ uniqueDigits]];
AbsoluteTiming[Select[Range@20000, IsSpecial]]
(* {95.4927, {1, 1170, 1528, 9877, 9886, 9897, 11535}} *)


When I ran your code, it took 256 seconds to test the first 20,000 integers. (I didn't have the patience to go to 200000 given that result for 20000.)

• I'm thinking one optimization would be to not check all of the training 0s. Aug 16, 2022 at 22:51