Efficient code for the Ten True Sentences puzzle

Question

I am trying to solve Ten True Sentences Puzzle.

Take a look at the following sentences:

• The number of times the digit 0 appears in this puzzle is _____.
• The number of times the digit 1 appears in this puzzle is _____.
• The number of times the digit 2 appears in this puzzle is _____.
• The number of times the digit 3 appears in this puzzle is _____.
• The number of times the digit 4 appears in this puzzle is _____.
• The number of times the digit 5 appears in this puzzle is _____.
• The number of times the digit 6 appears in this puzzle is _____.
• The number of times the digit 7 appears in this puzzle is _____.
• The number of times the digit 8 appears in this puzzle is _____.
• The number of times the digit 9 appears in this puzzle is _____.

Fill these sentences with digits such that all the sentences holds true.

I wrote the following code, but it didn't work.

Do[
  If[Tally[Range[0, 9] ~Join~ x][[All, 2]] == x, Print@x],
  {x, Tuples[Range[0, 9], 10]}] // AbsoluteTiming

How can I imporve my code?

Updated

Compile[{},
   NestWhile[Join[{1, 7, 3, 2}, RandomInteger[10, 6]] &, Range[0,9], 
      Tally[Range[0, 9] ~Join~ #][[All, 2]] != # &], 
   CompilationTarget -> "C", RuntimeOptions -> "Speed"
   ][] // AbsoluteTiming

Answer 1

Since the finished puzzle will contain exactly 20 numbers, we can assert that the solution for x will satisfy Total[x] == 20. We can therefore consider the IntegerPartitions of 20, which are of length 10, and limited to the numbers 1-9:

parts = IntegerPartitions[20, {10}, Range[1, 9]];

The solution for x must be a permutation of one of these, so the complete candidate set for x is:

can = Flatten[Permutations /@ parts, 1];

There are 92278 of these, sufficiently few to use the OP's code straight away. However, we can also note that the solution must satisfy (x-1).Range[0,9] == 20, so we can further reduce the candidate set:

can = can[[Flatten@Position[(can - 1).Range[0, 9], 20]]];

This leaves just 391 possibilities for x, making the OP's code very fast:

Do[If[Tally[Range[0, 9]~Join~x][[All, 2]] == x, Print@x], {x, can}]
(*  {1,7,3,2,1,1,1,2,1,1}  *)

Answer 2

Represent the solution as a list $\{z_0, z_1, \ldots, z_9\}$. The counts of appearances of the various digits can be computed as

appearanceCount[n_Integer, i_Integer, b_: 10] := Count[IntegerDigits[n, b], i];
appearanceCount[z_List, i_Integer, b_: 10] := Sum[appearanceCount[n, i, b], {n, z}]

(This may be inefficient, especially considering the question will later be limited to one-digit answers, but I prefer it for its expressiveness and full generality. Notice, too, the possible generalization to bases $b$ other than $10$.)

We seek a fixed point of the function that counts the appearances of digits in the answer and adds $1$ to each (to account for their appearances in the question itself):

f[z_List] := appearanceCount[z, #] & /@ Range[0, Length[z] - 1] + 1
FixedPoint[f, ConstantArray[1, 10], 20]

This starts with a somewhat arbitrary guess $z_i=1$ for all $i$. (I asked the iteration not to proceed more than $20$ times, to avoid infinite loops.)

{1, 11, 2, 1, 1, 1, 1, 1, 1, 1}

We need to check that this is indeed a fixed point (and not just the last thing that was tried):

f[%]==%

True

The question does use the term "digit" to refer to what goes in the blanks, so perhaps the value of "11" would be considered invalid: it uses two digits. Rather than thinking too hard about this, let's optimistically start with some random guesses and check everything that emerges as a possible fixed point:

Select[Union[FixedPoint[f, #, 10] & /@ RandomChoice[Range[0, 9], {100, 10}]], f[#] == # &]

{{1, 7, 3, 2, 1, 1, 1, 2, 1, 1}}

One could systematically search for solutions by checking all $10$-tuples; there are $10^{10}$ of them, so this would take some time!

Answer 3

too long for a comment -- but your basic approach does work in some reasonable time if we are a little smart about restricting the range of the values:

(either test works about the same)

test[v_] := Tally[Range[0, 9]~Join~v][[All, 2]] == v ;
test[v_] := Count[ v   , #] + 1 & /@ Range[0, 9] ==  v
result = Table[0, {9}];
Timing[While[! test[result] ,
    result = (Join[{1, RandomInteger[{5, 8}]}, 
    RandomInteger[{1, 5}, 8]]) ]; result]

{68.5, {1, 7, 3, 2, 1, 1, 1, 2, 1, 1}}

edit: again with a little less built in knowedge of the solution.. I think if you start working it by hand you'll quickly realise the #1's and 2 must be both greater than 2 and the others cant be too big..

test[v_] := Count[ v   , #] + 1 & /@ Range[0, 9] ==  v
result = Table[0, {9}];
Timing[While[! test[result] ,
  result = Join[ {1 , Count[#, 1] + 2 , Count[#, 2] + 1}, # ] & @ 
   RandomInteger[{1, 6}, 7]]; result]

Answer 4

A = Table[{i,}, {i, 0, 9}];
Table[A〚i, -1〛 = Thread[Join @@ A == i - 1]~Count~True,
 {10}, {i, 10}] // Grid

Output:

1   2   2   1   1   1   1   1   1   1
1   9   2   1   1   1   1   1   1   2
1   8   3   2   1   1   1   1   2   1
1   7   3   2   1   1   1   2   1   1
1   7   3   2   1   1   1   2   1   1
1   7   3   2   1   1   1   2   1   1
1   7   3   2   1   1   1   2   1   1
1   7   3   2   1   1   1   2   1   1
1   7   3   2   1   1   1   2   1   1
1   7   3   2   1   1   1   2   1   1