Solving a discrete equation

Because there are only

8!

40320

combinations, we can test them all:

perm = Permutations@Range@8;

out = #2/#1 + FromDigits[{#6, #7, #8}]/FromDigits[{#3, #4, #5}] ==  1 & @@@ perm;

pos = Flatten@Position[out, True]

{10534, 10679, 15991, 16333, 16963, 37736, 38041, 39464}

perm[[pos]]

{{3, 1, 6, 7, 8, 4, 5, 2}, {3, 1, 7, 8, 6, 5, 2, 4}, {4, 2, 3, 5, 6, 1, 7, 8}, {4, 2, 7, 1, 6, 3, 5, 8}, {4, 3, 6, 2, 8, 1, 5, 7}, {8, 4, 3, 5, 2, 1, 7, 6}, {8, 4, 7, 1, 2, 3, 5, 6}, {8, 6, 5, 7, 2, 1, 4, 3}}


I like @corey979 answer, but bunch of #[[..]] doesn't look nice to me. Also you can use Select to avoid many intermediate steps. A one-liner (kinda long one) could be:

Select[Permutations@Range@8, #2/#1 + 
  FromDigits@{#6, #7, #8}/FromDigits@{#3, #4, #5} & @@ # == 1 &]


eqn = b/a + FromDigits[{f, g, h}]/FromDigits[{c, d, e}] == 1;

Since the sum of the terms is 1 and each term is positive, then each term must be less than 1, i.e., a > b && c > f. You can gain some efficiency by prefiltering the list of Permutations with this simpler criteria.

$HistoryLength = 0;

ClearSystemCache[]

Without prefiltering

(soln = Thread[{a, b, c, d, e, f, g, h} -> #] & /@ 
    Select[Permutations@
      Range@8, #2/#1 + 
          FromDigits@{#6, #7, #8}/FromDigits@{#3, #4, #5} & @@ # == 
       1 &]) // AbsoluteTiming

(*  {0.201104, {{a -> 3, b -> 1, c -> 6, d -> 7, e -> 8, f -> 4, g -> 5, 
   h -> 2}, {a -> 3, b -> 1, c -> 7, d -> 8, e -> 6, f -> 5, g -> 2, 
   h -> 4}, {a -> 4, b -> 2, c -> 3, d -> 5, e -> 6, f -> 1, g -> 7, 
   h -> 8}, {a -> 4, b -> 2, c -> 7, d -> 1, e -> 6, f -> 3, g -> 5, 
   h -> 8}, {a -> 4, b -> 3, c -> 6, d -> 2, e -> 8, f -> 1, g -> 5, 
   h -> 7}, {a -> 8, b -> 4, c -> 3, d -> 5, e -> 2, f -> 1, g -> 7, 
   h -> 6}, {a -> 8, b -> 4, c -> 7, d -> 1, e -> 2, f -> 3, g -> 5, 
   h -> 6}, {a -> 8, b -> 6, c -> 5, d -> 7, e -> 2, f -> 1, g -> 4, h -> 3}}}  *)

Verifying the solutions

And @@ (eqn /. soln)

(*  True  *)

ClearSystemCache[]

Using prefiltering

(soln2 = Thread[{a, b, c, d, e, f, g, h} -> #] & /@ 
    Select[Select[
      Permutations@
       Range@8, #1 > #2 && #3 > #6 & @@ # &], #2/#1 + 
          FromDigits@{#6, #7, #8}/FromDigits@{#3, #4, #5} & @@ # == 
       1 &]) // AbsoluteTiming

(*  {0.138858, {{a -> 3, b -> 1, c -> 6, d -> 7, e -> 8, f -> 4, g -> 5, 
   h -> 2}, {a -> 3, b -> 1, c -> 7, d -> 8, e -> 6, f -> 5, g -> 2, 
   h -> 4}, {a -> 4, b -> 2, c -> 3, d -> 5, e -> 6, f -> 1, g -> 7, 
   h -> 8}, {a -> 4, b -> 2, c -> 7, d -> 1, e -> 6, f -> 3, g -> 5, 
   h -> 8}, {a -> 4, b -> 3, c -> 6, d -> 2, e -> 8, f -> 1, g -> 5, 
   h -> 7}, {a -> 8, b -> 4, c -> 3, d -> 5, e -> 2, f -> 1, g -> 7, 
   h -> 6}, {a -> 8, b -> 4, c -> 7, d -> 1, e -> 2, f -> 3, g -> 5, 
   h -> 6}, {a -> 8, b -> 6, c -> 5, d -> 7, e -> 2, f -> 1, g -> 4, h -> 3}}}  *)

The results are identical

soln === soln2

(*  True  *)

Tags:

Equation Solving

Recent Posts