Re: combinatoric card problem

*To*: mathgroup at smc.vnet.net*Subject*: [mg25844] Re: [mg25835] combinatoric card problem*From*: Andrzej Kozlowski <andrzej at tuins.ac.jp>*Date*: Wed, 1 Nov 2000 01:25:32 -0500 (EST)*Sender*: owner-wri-mathgroup at wolfram.com

on 00.10.28 2:41 PM, pw at pewei at nospam.algonet.se wrote: > In China they often play this card game: > put four card on a table and try, as fast as possible, to arrive to the > result 24 using only addtion subtraction multiplication and division. > > ex. the cards: { hearts_6 ,hearts_7 ,clove_8 ,spades_king } gives the > numbers: > > {6,7,8,12} > > and 12*(6+8)/7=24 > > Is there some way to do determine how to do this with mathematica, or maybe > there is some way to determine if a certain quadruple can make the required > result? > > Peter W > > > Similar question seem to be asked quite often on this list. Of course Mathematica can do this sort of thing: it can do basically anything for which a well defined algorithm is given. This particular problem is not difficult, it is just time consuming to write out the code, to test it and to run it, and does not seem important enough to spend a lot of time on. However, since I have seen a similar question on this list about four times, I have decided to have a go just once. The solution given below is imperfect: it is neither efficient or elegant. It may not even be complete (I might have missed something) but if it isn't it should be easy to complete by anyone who is really interested in this matter. (I am also pretty sure that much more efficient and elegant solutions can be found). Here is a brief explanation. Given a list of four integers, e.g. {6,7,8,12} solution[{6,7,8,12}] should give all ways (if there are any) of obtaining 24 using the operations Plus,Times,Subtract,Divide and each of the numbers in the list just once. The idea is this. Two of the operations, Plus and Times are associative and comutative, two of them, Subtract and Divide are not. We try to write out all possible formulas of the type: A1[B1[x,y],B2[u,v]], A1[B1[x,y],A2[u,v]] etc. Here {x,y,u,v} are the given four numbers, the A's stand for Plus and Times, and the B's for Subtract or Divide. Note that if we take any formula which makes sense and replace Plus by Times it will still make sense (though it will give a different value) and similarly with Divide and Subtract. This is not true for Plus and Divide, e.g. Plus[1,2,3] makes sense but Divide[1,2,3] does not. We need three symbols A1,A2,A3 which stand for one of {Plus,Times} and three Symbols {B1,B2,B3} which stand for one of {Subtract,Divide}. The local variable "rules" give all the ways of substituting Plus or Times for one of the A's and Subtract or Divide for one of the B's. There are, (I think!), 14 types of valid formulas we need to consider, (which however overlap because commutativity and associativiy is not fully taken into account), which are denoted by type[1] to type[14]. We apply them to all possible permutations of the list of numbers we are testing: which is very wasteful as our A's are commutative, but I said I was not concerned with getting an efficient solution, just in demonstrating that Mathematica can do this! That's basically all. The answers are formatted using HoldForm to prevent them from evaluating, but some peculiarities occur (see below) which I have not bothered to investigate. The function solution (defined below) can be applied to any list of four numbers to see what solutions we get. Here is the example from the original posting: In[5]:= solution[{6, 7, 8, 12}] Out[5]= 12 6 + 8 12 (6 + 8) {(6 + 8) --, 12 -----, ----------} 7 7 7 Here is another: In[6]:= solution[{1, 2, 3, 4}] Out[6]= {2 3 4, 3 4 2, 2 4 3, 2 3 4, (1 + 2 + 3) 4, 4 3 2, 3 4 2, 4 2 3, 2 4 3, 4 2 3, 4 2 3, 3 2 4, 2 3 4, 3 2 4, 3 2 4, 2 3 4, 2 3 4, 2 3 4 Plus[1], 3 4 Plus[2], 2 4 Plus[3], 2 3 Plus[4], (1 + 2 + 3) Plus[4], 4 (3 + (1 + 2)), 2 2 2 4 (2 + (1 + 3)), 4 (1 + (2 + 3)), 3 4 -, 4 3 -, 3 4 -, 1 1 1 3 3 3 4 4 4 2 3 2 4 2 4 -, 4 2 -, 2 4 -, 2 3 -, 3 2 -, 2 3 -, 4 ---, 3 ---, 1 1 1 1 1 1 1 1 3 4 2 3 4 2 3 4 4 2 3 3 2 4 2 3 4 2 ---, --------, -------, -----, -----, -----} 1 Times[1] Plus[1] 1 1 1 Note that besides the repetitions there are some formatting problems. Sometimes expressions like Times[a] or Plus[a] appear for a. Sometimes the factor 1 is missing, e.g. 2 3 4 means 1 2 3 4 (1 times 2 times 3 times 4 = 24). The reason why 4 2 3 seems to appear several times is that actually sometimes (4 3) 2 and 4 (3 2) are considered distinct. All of these problems can can be fixed, but it would take more time than I want to spend on this. One can find all solutions (assuming my list of forms is complete). One way: load the package: << DiscreteMath`Combinatorica` define cards = KSubsets[Range[13], 4]; and run: Map[solution, cards] I have done it and it took what seemed like 10 minutes on my 233 MHz PowerBook G3. Here is the code: solution[ls_List] := Module[{numbers = Permutations[ls], A1, A2, A3, B1, B2, B3, type, f, rules1, rules2, rules}, rules1 = Map[Thread, Map[RuleDelayed[{A1, A2, A3}, #] &, Flatten[Outer[List, {Times, Plus}, {Times, Plus}, {Times, Plus}], 2]]]; rules2 = Map[Thread, Map[RuleDelayed[{B1, B2, B3}, #] &, Flatten[Outer[ List, {Subtract, Divide}, {Subtract, Divide}, {Subtract, Divide}], 2]]]; rules = Flatten[Outer[Join, rules1, rules2, 1], 1]; SetAttributes[A1, {Orderless, Flat, OneIdentity}]; SetAttributes[A2, {Orderless, Flat, OneIdentity}]; SetAttributes[A3, {Orderless, Flat, OneIdentity}]; type[1] = Union[Flatten[ Map[ReplaceList[#, {l_, m___} :> A3[A2[l], A1[m]]] &, numbers]]]; type[2] = Union[Flatten[ Map[ReplaceList[#, {l__ /; Length[{l}] == 2, m__} :> A1[A2[l], B1[m]]] &, numbers]]]; type[3] = Union[Flatten[ Map[ReplaceList[#, {l__ /; Length[{l}] == 2, m__} :> A1[B2[l], B1[m]]] &, numbers]]]; type[4] = Union[Flatten[ Map[ReplaceList[#, {l__, m__} :> B1[A2[l], A1[m]]] &, numbers]]]; type[5] = Union[Flatten[ Map[ReplaceList[#, {l__ /; Length[{l}] == 2, m__} :> B3[B2[l], A1[m]]] &, numbers]]]; type[6] = Union[Flatten[ Map[ReplaceList[#, {l__ /; Length[{l}] == 2, m__} :> B3[B2[l], B1[m]]] &, numbers]]]; type[7] = Union[Flatten[ Map[ReplaceList[#, {l__, m_, n_} :> A3[A2[A1[l], m], n]] &, numbers]]]; type[8] = Union[Flatten[ Map[ReplaceList[#, {l__, m_, n_} :> A3[A2[B1[l], m], n]] &, numbers]]]; type[9] = Union[Flatten[ Map[ReplaceList[#, {l__, m_, n_} :> A3[B1[A1[l], m], n]] &, numbers]]]; type[10] = Union[Flatten[ Map[ReplaceList[#, {l__, m_, n_} :> B1[A2[A1[l], m], n]] &, numbers]]]; type[11] = Union[Flatten[ Map[ReplaceList[#, {l__, m_, n_} :> B1[A2[B2[l], m], n]] &, numbers]]]; type[12] = Union[Flatten[ Map[ReplaceList[#, {l__, m_, n_} :> A1[B2[B2[l], m], n]] &, numbers]]]; type[13] = Union[Flatten[ Map[ReplaceList[#, {l__, m_, n_} :> B1[B2[A1[l], m], n]] &, numbers]]]; type[14] = Union[Flatten[ Map[ReplaceList[#, {l__, m_, n_} :> B1[B2[B3[l], m], n]] &, numbers]]]; f[n_] := Module[{u, v, posis = Position[type[n] /. rules, 24]}, If[posis == {}, {}, u = rules[[First[Transpose[posis]]]]; v = Map[HoldForm, type[n][[Last[Transpose[posis]]]]]; Union[Table[v[[i]] /. u[[i]], {i, 1, Length[v]}]]]]; Union[Flatten[Map[f, Range[14]]]]] -- Andrzej Kozlowski Toyama International University JAPAN http://platon.c.u-tokyo.ac.jp/andrzej/ http://sigma.tuins.ac.jp/