# Efficient code for the Ten True Sentences puzzle

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

-
This is because your puzzle is impossible. Every number appears at least once in your sentence, but you force us to use 0. –  VF1 Jan 7 '13 at 16:32
There is one solution in this puzzle, {1,7,3,2,1,1,1,2,1,1} –  chyaong Jan 7 '13 at 17:01
@VF1 The link OP provided also has the solution... –  rm -rf Jan 7 '13 at 18:10
@Hypnotoad There is a solution because OP edited the question. Before, it stated that every number 0-9 should be used. –  VF1 Jan 7 '13 at 18:30
Isnt that cheating to use part of the known solution? Anyway this would seem to lend itself to a genetic algorithm, or at least track solutions that have been tried so you dont repeat. –  george2079 Jan 7 '13 at 18:44
show 1 more comment

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}  *)

-

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!

-
+1 for the fixed point method. btw there is a function DigitCount could do what appearanceCount does. –  Silvia Jan 7 '13 at 19:42
@Silvia Thank you--it seems like almost any one-line function I can write has already been incorporated in the software somewhere :-). –  whuber Jan 7 '13 at 19:45

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]

-
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

-