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/