8
$\begingroup$

In the numbers game in countdown, contestants are given 6 numbers with which they must reach a seventh number with basic arithmetic. The only operations allowed are addition, subtraction, multiplication and division. Contestants may use all of the numbers a maximum of once.

Example:

Target = $902$

Numbers = $(75,50,8,7,3,2)$

solution1: $\left(75+50+3\right)\times7+8-2=902$

solution2: $75\times\left(7+8-3\right)+2=902$

What is an effective way to code this in Mathematica?

I'm answering this myself, but am interested in other more elegant solutions, as well as solutions that take any number of arguments.

$\endgroup$
5
$\begingroup$

Improved answer

(Since the contents of the original answer is contained in what follows here, the original answer is deleted.)

I address the following problem: given a set of numbers and a target, obtain the target from the given numbers by using the arithmetic operators *, /, + ,- such that each number occurs only once.

In his question, Feyre requires the numbers to occur at most once. That problem can be solved in the same way as this one by adding his function first to the arithmetic operators, or probably simpler by running my function alldifferentsolutions on all subsets of the given numbers.

For the numbers (2,3,5,12) and the target 25, a solution is 12+(2*5+3)=25. That solution can be rewritten as 3+12+2*5=25, which is another solution. However, these two solutions have to be considered as the same. In the final result we want all solutions to be different.

Roughly speaking, we proceed as follows.

First we construct all possible schemes (patterns) for the lefthand side of the solutions. E.g. the lefthand side of the solution 12+(2*5+3)=25 has the scheme plus[_, plus[times[_,_], _].

Each scheme is transformed into a test function. E.g. for the above scheme, the test function is HoldForm[Plus[#1, Plus[Times[#2, #3],#4]==25&. Each test function will be used on every permutation of the given numbers. When releasing the function value gives True, we have found a solution of the problem.

In the final result, we still have to skip duplicate solutions.

The schemes for a problem with n numbers will be collected in the list schemes[n]. Therefore, schemes[1]={_}. (For technical reasons, in the implementation we will use the name var instead of the underscore.)

Every scheme for a problem with n numbers has a head plus, times, subtract or divide, and two arguments, each being a scheme of a lower index that add to n. For example, the scheme for 12+(2*5+3)=25 mentioned above is in schemes[4]. It has head plus, the first argument is in schemes[1] and the second argument in schemes[3].

This allows us to define the schemes recursively. Of course we will use memoization to speed up the computation.

The recursive construction gives us all possible schemes, so also schemes for solutions that have to be considered as duplicates. We want to delete these superfluous schemes.

Consider the simple rewriting a+(b-c) = (a+b)-c. That means that every solution from the scheme plus[_, subtract[_,_]] also turns up in an equivalent form as a solution from the scheme subtract[plus[_,_],_]. Therefore, the scheme plus[_, subtract[_,_]] can be deleted from schemes[3]. Similar rewritings give other schemes that can be deleted.

The deletable schemes are indicated in the list duplicates:

duplicates={
  plus[___, _subtract,___],
  times[___, _divide,___],
  subtract[___, _subtract,___],
  divide[___, _divide,___],
  subtract[ _, (times|divide)[___,_subtract, ___]],
  subtract[_, plus[___, times[___,_subtract, ___],___]],
  divide[subtract[times[___,_subtract, ___],_], _subtract]
};

This list does not contain the schemes that can be deleted, but the Mathematica patterns for those schemes. The third element for example covers both a-(b-c)=(a+b)-c and (a-b)-c=a-(b+c).

When we have deleted the superflous schemes from the schemes list and have constructed the solutions, nevertheless duplicates turn up. That is caused by the values that we used as arguments in the test function. For example, if the solution has a divide subexpression which has the value 1 or -1, then the same solution turns up with the arguments reversed. Similarly, when a subtract subexpression has the value 0, there is also a solution with reversed arguments. Another situation is when there is a subexpression of the form (a-b)(c-d). Then there is another solution with the subexpression (b-a)(d-c).

So for getting rid of the duplicates, we need a list of transformations based on the numerical values. For big problems, this list has to be longer, but for the size up to 6, the following list suffices:

numericrules={
  z:divide[a_,b_] :> divide[b,a] /; Abs[compute[z]]==1 && Min[Cases[b, _Integer, All]]<Min[Cases[a, _Integer, All]],
  z:subtract[a_,b_] :> subtract[b,a] /; compute[z]== 0 && Min[Cases[b, _Integer, All]]<Min[Cases[a, _Integer, All]],
  z:(times|divide)[___,num:subtract[a_, b_] | times[ ___, subtract[a_, b_], ___],
    den:subtract[c_, d_] | times[ ___, subtract[c_, d_], ___],___]:>  (z/. {a->b, b->a, c->d, d->c} )/; compute[num]<0 
};

Here at last is the implementation of the function alldifferentsolutions:

alldifferentsolutions[numbers_, target_] := 
  Module[{plus, times, subtract, divide,compute, schemes, var, duplicates, numericrules, tests, result},
    Attributes[plus]={Flat, Orderless};
    Attributes[times]={Flat, Orderless};
    compute[expr_] := expr /. {plus->Plus, times->Times, subtract->Subtract, divide->Divide};
    schemes[1]={var};
    schemes[n_] := schemes[n]=Module[{zzz},
      zzz=Join[
        Table[Outer[ff,schemes[i], schemes[n-i]], {ff, {plus,times}}, {i,1,n/2}],
        Table[Outer[ff,schemes[i], schemes[n-i]], {ff, {subtract,divide}}, {i,1,n-1}]
      ]// Flatten // DeleteDuplicates;
      DeleteCases[zzz,Alternatives @@ duplicates]];
    duplicates={
      plus[___, _subtract,___],
      times[___, _divide,___],
      subtract[___, _subtract,___],
      divide[___, _divide,___],
      subtract[ _, (times|divide)[___,_subtract, ___]],
      subtract[_, plus[___, 
      times[___,_subtract, ___],___]],
      divide[subtract[times[___,_subtract, ___],_], _subtract]
    };
    numericrules={
      z:divide[a_,b_] :> divide[b,a] /; Abs[compute[z]]==1 && Min[Cases[b, _Integer, All]]<Min[Cases[a, _Integer, All]],
      z:subtract[a_,b_] :> subtract[b,a] /; compute[z]== 0 && Min[Cases[b, _Integer, All]]<Min[Cases[a, _Integer, All]],
      z:(times|divide)[___,num:subtract[a_, b_] | times[ ___, subtract[a_, b_], ___],
        den:subtract[c_, d_] | times[ ___, subtract[c_, d_], ___],___]:>  (z/. {a->b, b->a, c->d, d->c} )/; compute[num]<0 
    };
    tests=compute[ Function /@ HoldForm /@ Table[i=0; ( ff/. var:>(i++; Slot[i]))==target, {ff, schemes[Length[numbers]]}]];
    result=Reap[
      Do[If[Quiet[ReleaseHold[test@@nn]],Sow[test@@nn]],{test,tests},{nn,Permutations[numbers]}]][[2]];
    If[result!={}, result=result[[1]]];
    result = ReleaseHold[result /.{Plus->plus, Times->times, Subtract->subtract, Divide->divide}];
    result=DeleteDuplicates[result /. numericrules];
    compute[HoldForm /@ result]
  ] 

The function is relatively fast. The six number problem raised by Feyre now runs in about 8 seconds and returns 9 different solutions.

(sols=alldifferentsolutions[{2,3,7,8,50,75},902])//Length// Timing
Column[sols]

(* {7.96875, 9} *)
(*
    7 50+8 (75-2 3)==902
    2 (7 75-(50+3 8))==902
    (8+7 (3+50+75))-2==902
    (7 (75-3)+8 50)-2==902
    7 (2+3+50+75)-8==902
    7 (2 (75-3)-8)-50==902
    (8+2 3) (75-7)-50==902
    (8+75 (50-2))/(7-3)==902
    ((7+75) (8+50/2))/3==902
*)

Solving a seven number problem can be done in slightly over 6 minutes.

$\endgroup$
  • $\begingroup$ Nice answer, it seems to run more slower than the amount of extra permutations though. $\endgroup$ – Feyre Dec 27 '16 at 22:45
4
$\begingroup$

Here I define the functional form for the calculations:

fun[{x1_, x2_, x3_, x4_, x5_, x6_}] := 
 a[b[c[d[e[x1, x2], x3], x4], x5], x6]

This functions means that the second number is not used:

first[x_, y_] := x

Here I define the user function:

cn[x1_, x2_, x3_, x4_, x5_, x6_, x7_] := 
 Module[{n = Permutations[{x1, x2, x3, x4, x5, x6}], 
   rep = Thread[{a, b, c, d, e} -> #] & /@ 
     Tuples[{Plus, Subtract, Times, Divide, first}, 5]}, 
  Table[
     Table[If[(fun[n[[j]]] /. rep[[i]]) == x7, 
       Print[{fun[n[[j]]], rep[[i]]}]], {i, Length[rep]}], {j, 
      Length[n]}];]

And here is a sample of the numerous solutions of the example in the question, in unformatted form:

cn[75, 50, 8, 7, 3, 2, 902]

enter image description here

$\endgroup$
  • $\begingroup$ Does this cover all the possibilities that are valid? Aren't solutions of the form $a(b+c)+d(e+f)$ missed out, for example. $\endgroup$ – Lucas Dec 25 '16 at 22:46
  • $\begingroup$ @Lucas Those are missing out as I realised after I posted, happened because I changed tack halfway through my solution. Will correct when not too busy. $\endgroup$ – Feyre Dec 26 '16 at 10:12
  • $\begingroup$ I started doing it using a tree structure, but I too found that I didn't have the time to do it. $\endgroup$ – Lucas Dec 26 '16 at 20:55
3
$\begingroup$

This is another brute force approach, which checks every possible computation. It takes over a minute to run. I use the version 11 function Groupings to get the binary expression trees.

n = {75, 50, 8, 7, 3, 2};
target = 902;

g = Groupings[Array[Slot, 6], 2];

f = Tuples[{Plus, Times, Subtract, Divide, #1 &}, 5];

calcs = Function /@ DeleteDuplicates@Flatten[
     Outer[ReplacePart[#, Thread[Position[#, List] -> #2]] &, g, f, 1], 1];

p = Permutations[n];

all = Quiet@Outer[Apply, calcs, p, 1];

Column@DeleteDuplicates[
  Position[all, target] /. {c_, v_} :> calcs[[c]] @@ (HoldForm /@ p[[v]])]

(*
2+(3+7+8)*50
2+(-3+7+8)*75
2+50*(-7+75/3)
-2+8+7*(3+50+75)
2*(8*(-3+50)+75)
-8+7*(2+3+50+75)
-50+7*(-8+2*(-3+75))
2-(3-7-8)*75
2*(-8*(3-50)+75)
2-50*(7-75/3)
2*(-3*8-50+7*75)
(3+8)*(7+75)
-2+8*50+7*(-3+75)
-50+(2*3+8)*(-7+75)
((8+50/2)*(7+75))/3
-2+8*50-7*(3-75)
(8+(-2+50)*75)/(-3+7)
(-8+(2-50)*75)/(3-7)
7*50-8*(2*3-75)
(8-(2-50)*75)/(-3+7)
7*50+8*(-2*3+75)
*)
$\endgroup$
1
$\begingroup$

Here's another solution. It follows closely Graham Hutton's paper and Haskell implementation.

    BeginPackage["CountDown`"]

    RandomCountDownNumbers::usage="RandomCountDownNumbers[] returns a random countdown problem, a list of two elements: a list of six numbers and a target number.";

    SolveCountDown::usage="SolveCountDown[\!\(\*
    StyleBox[\"p\"]\)] solves countdown problem p. Argument \!\(\*
    StyleBox[\"p\"]\) is a list of two elements: a list of numbers and a target number. If no exact solution exists it finds the nearest solution to the target number.";

    Begin["`Private`"]

    RandomCountDownNumbers[] := {RandomSample[Join[{25, 50, 75, 100}, Range[10], Range[10]], 6], RandomInteger[{100, 999}]}

    split[xs_List] := Table[{Take[xs, i], Take[xs, -Length[xs] + i]}, {i, 1, Length[xs] - 1}]

    subbags[xs_List] := Flatten[Permutations /@ Subsets[xs], 1]

    ops = {add, sub, mul, div}

    valid[add[x_List, y_List]] := If[Length[x] == 0 || Length[y] == 0, False, x[[1]] <= y[[1]]]
    valid[mul[x_List, y_List]] := If[Length[x] == 0 || Length[y] == 0, False, x[[1]] <= y[[1]]]
    valid[sub[x_List, y_List]] := If[Length[x] == 0 || Length[y] == 0, False, x[[1]] > y[[1]]]
    valid[div[x_List, y_List]] := If[Length[x] == 0 || Length[y] == 0, False,y[[1]] != 0 && Divisible[x[[1]], y[[1]]]]

    apply[add[x_List, y_List]] := {x[[1]] + y[[1]]}
    apply[sub[x_List, y_List]] := {x[[1]] - y[[1]]}
    apply[mul[x_List, y_List]] := {x[[1]] * y[[1]]}
    apply[div[x_List, y_List]] := {x[[1]] / y[[1]]}

    values[val[x_List]] := {x[[1]]}
    values[app[_, r_, l_]] := Join[values[l], values[r]]

    eval[{}] := {}
    eval[val[x_List]] := If[x[[1]] > 0, x, {}]
    eval[app[op_, l_, r_]] := Module[{x, y}, 
      x = eval[l];
      y = eval[r];
      If[valid[op[x, y]], apply[op[x, y]], {}]
    ]

    exprs[{}] := {}
    exprs[{n_Integer}] := {val[{n}]}
    exprs[xs_List] := Flatten[Table[e, {s,split[xs]}, {l, exprs[s[[1]]]}, {r, exprs[s[[2]]]}, {e, combine[l, r]}]]

    combine[res[l_, x_], res[r_, y_]] := Module[{cs},
      cs = res[app[#, l, r], If[valid[#[x, y]],apply[#[x, y]], {}]] & /@ ops;
      cs = DeleteDuplicates[cs];
      DeleteCases[cs, res[_, {}]]
    ]

    reslts[{}] := {}
    reslts[{n_Integer}] := {res[val[{n}], {n}]}
    reslts[xs_List] := DeleteDuplicates[Flatten[Table[e, {s,split[xs]}, {l, reslts[s[[1]]]}, {r, reslts[s[[2]]]}, {e, combine[l, r]}]]]

    readableExpr[val[x_List]] := x[[1]]
    readableExpr[app[op_, l_, r_]] := op[readableExpr[l], readableExpr[r]]

    resExpr[res[e_, _]] := readableExpr[e]
    resVal[res[_, x_List]] := x[[1]]

    SolveCountDown[xs_List] := Module[{cs, ss, sr, tns, tn},
      cs = Flatten[Table[e, {is, subbags[xs[[1]]]}, {e, reslts[is]}]];
      cs = DeleteDuplicates[cs];
      cs = DeleteCases[cs, res[_, {}]];
      ss = Cases[cs, res[_, {n_}] /; n == xs[[2]]];
      ss = If[Length[ss] == 0, 
        tns = resVal /@ cs;
        tn = Nearest[tns, xs[[2]]][[1]];
        Cases[cs, res[_, {n_}] /; n == tn],
        ss
      ];  
      sr = resExpr /@ ss;
      sr  /. {add -> Hold[Plus], mul -> Hold[Times], sub -> Hold[Subtract], div -> Hold[Divide]}
    ]

    End[]
    EndPackage[]

Takes about 20 seconds for 6 numbers.

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