Re: combinatoric card problem
- To: mathgroup at smc.vnet.net
- Subject: [mg25846] Re: [mg25835] combinatoric card problem
- From: Andrzej Kozlowski <andrzej at tuins.ac.jp>
- Date: Wed, 1 Nov 2000 01:25:33 -0500 (EST)
- Sender: owner-wri-mathgroup at wolfram.com
I really did not intend to write more than once about this problem, but
after sending my message I noticed some small errors and a possibility of
improvement. The improvement is that actually all the ReplaceList's are not
needed and be replaced by ReplaceAll. In this particular case doing this
only seems to speed up the computation and make the output slightly nicer.
Thus, the slightly changed code is:
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[15] = Union[Flatten[Map[ReplaceAll[#, {l__} :> A1[l]] &,
numbers]]];
type[1] =
Union[Flatten[
Map[ReplaceAll[#, {l__, m___} :> A3[A2[l], A1[m]]] &, numbers]]];
type[2] =
Union[Flatten[
Map[ReplaceAll[#, {l__ /; Length[{l}] == 2, m__} :>
A1[A2[l], B1[m]]] &, numbers]]];
type[3] =
Union[Flatten[
Map[ReplaceAll[#, {l__ /; Length[{l}] == 2, m__} :>
A1[B2[l], B1[m]]] &, numbers]]];
type[4] =
Union[Flatten[
Map[ReplaceAll[#, {l__, m__} :> B1[A2[l], A1[m]]] &, numbers]]];
type[5] =
Union[Flatten[
Map[ReplaceAll[#, {l__ /; Length[{l}] == 2, m__} :>
B3[B2[l], A1[m]]] &, numbers]]];
type[6] =
Union[Flatten[
Map[ReplaceAll[#, {l__ /; Length[{l}] == 2, m__} :>
B3[B2[l], B1[m]]] &, numbers]]];
type[7] =
Union[Flatten[
Map[ReplaceAll[#, {l__, m_, n_} :> A3[A2[A1[l], m], n]] &,
numbers]]];
type[8] =
Union[Flatten[
Map[ReplaceAll[#, {l__, m_, n_} :> A3[A2[B1[l], m], n]] &,
numbers]]];
type[9] =
Union[Flatten[
Map[ReplaceAll[#, {l__, m_, n_} :> A3[B1[A1[l], m], n]] &,
numbers]]];
type[10] =
Union[Flatten[
Map[ReplaceAll[#, {l__, m_, n_} :> B1[A2[A1[l], m], n]] &,
numbers]]];
type[11] =
Union[Flatten[
Map[ReplaceAll[#, {l__, m_, n_} :> B1[A2[B2[l], m], n]] &,
numbers]]];
type[12] =
Union[Flatten[
Map[ReplaceAll[#, {l__, m_, n_} :> A1[B2[B2[l], m], n]] &,
numbers]]];
type[13] =
Union[Flatten[
Map[ReplaceAll[#, {l__, m_, n_} :> B1[B2[A1[l], m], n]] &,
numbers]]];
type[14] =
Union[Flatten[
Map[ReplaceAll[#, {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[15]]]]]
Applying this to previous examples we get:
In[2]:=
solution[{6, 7, 8, 12}]
Out[2]=
12 6 + 8 12 (6 + 8)
{(6 + 8) --, 12 -----, ----------}
7 7 7
(no change)
and
In[3]:=
solution[{1, 2, 3, 4}]
Out[3]=
{2 3 4, 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],
2
4 (3 + (1 + 2)), 4 (2 + (1 + 3)), 4 (1 + (2 + 3)), 3 4 -,
1
2 2 3 3 3 4 4 4
4 3 -, 3 4 -, 2 4 -, 4 2 -, 2 4 -, 2 3 -, 3 2 -, 2 3 -,
1 1 1 1 1 1 1 1
2 3 2 4 3 4 4 2 3 3 2 4 2 3 4
4 ---, 3 ---, 2 ---, -----, -----, -----}
1 1 1 1 1 1
(faster, somewhat improved output).
This is still unsatisfactory, and it would be much better not do not
distinguish expressions which are actually the same but for "bracketing" or
the order of factors or summands, or, if one really wants to distinguish
them, to distinguish all cases (which would make the answers and the
computations much longer. As it is we are somewhat falling in between two
stools, but as I do not really wish to spend any more time on this I shall
leave it at that.
on 00.10.29 11:11 AM, Andrzej Kozlowski at andrzej at tuins.ac.jp wrote:
>
> 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
>>
>>
Andrzej Kozlowski
Toyama International University
JAPAN
http://platon.c.u-tokyo.ac.jp/andrzej/
http://sigma.tuins.ac.jp/