Solving puzzles with Mathematica

Question

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[[1]]q[[2]]==q[[3]]q[[4]],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[[1]] q[[2]] == q[[3]] q[[4]], 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)#[[1]] 
> 3 & (#[[1]]>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}})

Answer 1

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[38]= {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

Answer 2

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

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

Answer 3

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 )

Answer

(spoiler)

{6329}

Answer 4

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