Enigma 1462

Here is how Mathematica can be used to solve New Scientist Enigma number 1462 in the 29 September 2007 issue.

List of all 3-tuples of side lengths of red, blue, and yellow cubes. The upper limit of each of these is constrained by the known number of digits in the cubes of these side lengths in the red and yellow cases, and by the known number of digits in the square of the side length in the blue case.
(sizelist = Flatten[Table[{r,b,y}, {r,0,9}, {b,0,9}, {y,0,21}], 2]) // Length
2200

Select the cases where red volume is a 3-digit number, and the blue area is a 2-digit number, and the yellow volume is a 4-digit number, and the first digit of the red volume is the same as the first digit of the blue area, and the last digit of the blue area is the same as the last digit of the yellow volume.
sizelist2 = Select[sizelist, 100<=#[[1]]^3<=999 && 10<=#[[2]]^2<=99 && 1000<=#[[3]]^3<=9999 && IntegerDigits[#[[1]]^3][[1]] == IntegerDigits[#[[2]]^2][[1]] && IntegerDigits[#[[2]]^2][[-1]] == IntegerDigits[#[[3]]^3][[-1]]&]
{{5,4,16}, {6,5,15}, {7,6,16}}

Check the digits corresponding to the letters in "nil", "no", and "zero". Only the first case is admissable because it has all digits distinct for all these letters.
Map[
(
{volumered, areablue, volumeyellow} = {#[[1]]^3, #[[2]]^2, #[[3]]^3};
nilnozero = Flatten[Map[IntegerDigits[#]&, {volumered, areablue, volumeyellow}]];
nilozer = Drop[Drop[nilnozero, {-1}], {4}]
)&,
sizelist2
]
{{1,2,5,6,4,0,9}, {2,1,6,5,3,3,7}, {3,4,3,6,4,0,9}}

1. Choose the first case above which thus fixes the values of {n, i, l, o, z, e, r}.
2. Compute the volumes of the 3 coloured cubes.
3. Generate a list of permutations of these volumes, because which pile is which is unknown.
4. List all the possible alternative cases of {t, h, g}, i.e. permutations of one base case.
5. For each of these cases of {t, h, g} compute the total volume "nothing".
6. Generate a list of the numbers of cubes in each of the 3 piles, where the 3rd pile is the one with the unknown number.
{n, i, l, o, z, e, r} = %[[1]]
{volumered, volumeblue, volumeyellow} = {#[[1]]^3, #[[2]]^3, #[[3]]^3}&[sizelist2[[1]]]
volumelist = Permutations[{volumered, volumeblue, volumeyellow}]
thglist = Permutations[Complement[Range[0,9], {n, i, l, o, z, e, r}]]
volumetotallist = Map[FromDigits[{n, o, #[[1]], #[[2]], i, n, #[[3]]}]&, thglist]
numberlist=Append[Map[FromDigits, {{n, o}, {n, o, n, e}}], x]
{1,2,5,6,4,0,9}
{125,64,4096}
{{125,64,4096}, {125,4096,64}, {64,125,4096}, {64,4096,125}, {4096,125,64}, {4096,64,125}}
{{3,7,8}, {3,8,7}, {7,3,8}, {7,8,3}, {8,3,7}, {8,7,3}}
{1637218, 1638217, 1673218, 1678213, 1683217, 1687213}
{16,1610,x}

For each member of the list of volumes (see step 3 above) and each possible total volume (see step 5 above) generate an equation for the number of cubes in the unknown pile, and label each equation with the colour of the unknown pile.
eqns = Flatten[Outer[{Switch[#1[[3]], 125, "r", 64, "b", 4096, "y"], #1.numberlist==#2}&, volumelist, volumetotallist, 1], 1]
{{y,105040+4096 x==1637218}, {y,105040+4096 x==1638217}, {y,105040+4096 x==1673218}, {y,105040+4096 x==1678213}, {y,105040+4096 x==1683217}, {y,105040+4096 x==1687213}, {b,6596560+64 x==1637218}, {b,6596560+64 x==1638217}, {b,6596560+64 x==1673218}, {b,6596560+64 x==1678213}, {b,6596560+64 x==1683217}, {b,6596560+64 x==1687213}, {y,202274+4096 x==1637218}, {y,202274+4096 x==1638217}, {y,202274+4096 x==1673218}, {y,202274+4096 x==1678213}, {y,202274+4096 x==1683217}, {y,202274+4096 x==1687213}, {r,6595584+125 x==1637218}, {r,6595584+125 x==1638217}, {r,6595584+125 x==1673218}, {r,6595584+125 x==1678213}, {r,6595584+125 x==1683217}, {r,6595584+125 x==1687213}, {b,266786+64 x==1637218}, {b,266786+64 x==1638217}, {b,266786+64 x==1673218}, {b,266786+64 x==1678213}, {b,266786+64 x==1683217}, {b,266786+64 x==1687213}, {r,168576+125 x==1637218}, {r,168576+125 x==1638217}, {r,168576+125 x==1673218}, {r,168576+125 x==1678213}, {r,168576+125 x==1683217}, {r,168576+125 x==1687213}}

How many cubes are in the remaining pile and what is their colour? This is the only integer solution that can found to any of the above equations.
Select[Map[{#[[1]], Reduce[#[[2]], x, Integers]}&, eqns], (#[[2]]=!=False&)]
{{b,x==21413}}