# Solving puzzles with Mathematica

I would like to be able to solve logic puzzles such as the one described here using Mathematica.

I have copied & pasted the listed example below to save on jumping about with hyperlinks:

• The number is prime.
• No digits are repeated.
• $$A\cdot B=C\cdot D$$
• The first digit is greater than 3

This does it

li = Prime[Range[PrimePi[4*10^3], PrimePi[10^4]]];
q = IntegerDigits[li[[n]]];
mi = Rest@DeleteCases[Table[If[q[]q[]==q[]q[],li[[n]],0],
{n,1,Length@li}],0];
ni = DeleteCases[Table[If[Length@Complement[IntegerDigits[mi[[n]]]]==4,mi[[n]],0],
{n,1,Length@mi}],0]


but certainly isn't the best approach, especially for more complex problems.

I tried thing like this:

FindInstance[{Element[FromDigits[{a, b, c, d}], Primes],  a != b != c != d,
10^3 <= FromDigits[{a, b, c, d}] <= 10^4, a > 3, b > 0, c > 0, d > 0, a*b == c*d},
{a, b, c, d}, 1]


but it didn't work, and I am not sure why.

I was wondering whether I could use Rojo's method for defining a set as a starting point, but again, not sure what is the best approach.

# Update

So far:

li = Prime[Range[PrimePi[4*10^3], PrimePi[10^4]]];
q = IntegerDigits[li[[n]]];
mi = Rest@ DeleteCases[Table[If[q[] q[] == q[] q[], li[[n]], 0],
{n, 1, Length@li}], 0];
DeleteCases[Table[If[Length@Complement[IntegerDigits[mi[[n]]]] == 4, mi[[n]], 0],
{n, 1, Length@mi}], 0] // Timing

(*{0., {6329}}*)

pred[a_, b_, c_, d_] :=
And @@ {FromDigits@{a, b, c, d} \[Element] Primes, a != b != c != d,
a b == c d, a > 3};
Select[Range[1000, 9999], pred @@ IntegerDigits[#] &] // Timing

(*{0.218401, {6329}}*)

Select[IntegerDigits@Prime[Range[1, PrimePi[10^4]]],
Length@Union@# == 4 &&(*4 different digits*)
Equal @@ Times @@@ Partition[#, 2] &&(*the product condition*)#[]
> 3 & (*#[]>3*)] // Timing

(*{0.031200, {{6, 3, 2, 9}}}*)

Select[Flatten[
Table[(10^3 a + 10^2 b + 10 c + d)*
Boole[a != b && a != c && a != d && b != c && b != d && c != d &&
a b == c d], {a, 4, 9}, {b, 0, 9}, {c, 0, 9}, {d, 0, 9}], 3],
PrimeQ[#] &] // Timing

(*{0.015600, {6329}}*)

Select[Most@NestWhileList[NextPrime, 4000, # < 10000 &],
Function[Block[{a, b, c, d}, {a, b, c, d} = IntegerDigits[#];
And @@ {a b == c d, a != b != c != d}]]] // Timing

(*{0.031200, {6329}}*)

• This seems to work: pred[a_, b_, c_, d_] := And @@ {FromDigits@{a, b, c, d} ∈ Primes, a != b != c != d, a b == c d, a > 3}; Select[Range[1000, 9999], pred @@ IntegerDigits[#] &]
– user484
Oct 25 '14 at 12:12
• @RahulNarain yes that is great. Any idea why FindInstance doesn't work? Oct 25 '14 at 12:14
• FindInstance is a black box full of elves as far as I'm concerned, so no.
– user484
Oct 25 '14 at 14:18
• @RahulNarain Ha! So it's not just me then! :) Oct 25 '14 at 14:29
• @RahulNarain Why not add this as an answer? Oct 25 '14 at 14:37

Sorry, but this afternoon I'm too lazy to think too much.

Therefore here is the simple literal translation of the four conditions letting Boole[] do the main job and giving the unique result

Select[
Flatten[Table[(10^3 a + 10^2 b + 10 c + d)*
Boole[a != b && a != c && a != d && b != c && b != d && c != d &&
a b == c d], {a, 4, 9}, {b, 0, 9}, {c, 0, 9}, {d, 0, 9}], 3],
PrimeQ[#] &]

(* Out= {6329} *)


Regards,
Wolfgang

EDIT 25.10.14 18:10

I just learned from rhermans that the logical expression can be written much shorter. Hence

Select[Flatten[
Table[(10^3 a + 10^2 b + 10 c + d)*
Boole[a != b != c != d && a b == c d], {a, 4, 9}, {b, 0, 9}, {c,
0, 9}, {d, 0, 9}], 3], PrimeQ[#] &]

(* Out[]= {6329} *)


Regards,
Wolfgang

Select[IntegerDigits@Prime[Range[1, PrimePi[10^4]]],
Length@Union@# == 4 &&                              (* 4 different digits *)
Equal @@ Times @@@ Partition[#, 2] &&               (* the product condition *)
#[] > 3 &                                        (* #[] >3 *)
]

(* {6,3,2,9} *)


## Fast

Select[
Most@NestWhileList[NextPrime, 4000, # < 10000 &]
, Function[Block[{a, b, c, d}, {a, b, c, d} = IntegerDigits[#];
And @@ {
a b == c d,
a != b != c != d
}
]]]


(AbsoluteTiming -> 0.015600)

## Slow

Select[
FromDigits[{a, b, c, d}] /.
Solve[a != b != c != d && 3 < a <= 9 && 0 < b <= 9 && 0 < c <= 9 &&
0 < d <= 9 && a*b == c*d, {a, b, c, d}, Integers]
, PrimeQ]


(AbsoluteTiming -> 7.257229 )

(spoiler)

{6329}

Just another way. Noting from the puzzle the integer digits must consist of integer and multiples that do not exceed 10 (and obviously 0 cannot be one of the digits) thus only 1 and 2,3 and their multiples less than 10 can form the digits of the desired number, i.e.{1,2,3,4,6,8,9}.. You could pare down further but:

set = {1, 2, 3, 4, 6, 8, 9};
sub = Subsets[set, {4}];
can = Pick[sub,
Equal @@@ (Times @@@ Partition[RotateLeft[#, 1], 2] & /@ sub)];
prim = Flatten[Map[FromDigits[#, 10] &, (Permutations /@ can), {2}]];
primc = Pick[prim, PrimeQ /@ prim];
ansc = Pick[primc,
Equal @@@ (Times @@@ Partition[IntegerDigits@#, 2] & /@ primc)];
ans = Pick[ansc, (First@IntegerDigits[#]) > 3 & /@ ansc]


yields:

(*{6329}*)


or

q[x_] := Equal @@ Times @@@ Partition[x, 2];
set = {1, 2, 3, 4, 6, 8, 9};
sub = Subsets[set, {4}];
pck1 = Pick[sub, q[RotateLeft@#] & /@ sub];
perm = Cases[Flatten[Permutations /@ pck1, 1], {_?(# > 3 &), __}];
pck2 = FromDigits /@ Pick[perm, q /@ perm];
ans = Pick[pck2, PrimeQ /@ pck2]


The second approach:

• selects from 4 digit subsets those whose products are square
• then selects permutation which have first element >3 then
• selects from those pattern which is $A.B=C.D$ then
• selects prime