3
$\begingroup$

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}}*)
$\endgroup$
  • 2
    $\begingroup$ 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[#] &] $\endgroup$ – Rahul Oct 25 '14 at 12:12
  • $\begingroup$ @RahulNarain yes that is great. Any idea why FindInstance doesn't work? $\endgroup$ – martin Oct 25 '14 at 12:14
  • 3
    $\begingroup$ FindInstance is a black box full of elves as far as I'm concerned, so no. $\endgroup$ – Rahul Oct 25 '14 at 14:18
  • $\begingroup$ @RahulNarain Ha! So it's not just me then! :) $\endgroup$ – martin Oct 25 '14 at 14:29
  • $\begingroup$ @RahulNarain Why not add this as an answer? $\endgroup$ – martin Oct 25 '14 at 14:37
3
$\begingroup$

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

$\endgroup$
3
$\begingroup$
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} *)
$\endgroup$
1
$\begingroup$

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}

$\endgroup$
1
$\begingroup$

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
$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.