Re: Fun 7th grade Algebra problem
- To: mathgroup at smc.vnet.net
- Subject: [mg34773] Re: [mg34731] Fun 7th grade Algebra problem
- From: Andrzej Kozlowski <andrzej at platon.c.u-tokyo.ac.jp>
- Date: Thu, 6 Jun 2002 01:54:55 -0400 (EDT)
- Sender: owner-wri-mathgroup at wolfram.com
I guess I should have know this sort of thing is addictive. Anyway, I
could not resist trying to get a few more answers, although this is
definitely my last attempt. This is what I did. First I added a few
improvements to the code. I replaced the built-in function Factorial by
factorial defined by:
Clear[factorial];
factorial[n_Integer?(# < 100 &)] = Factorial[n];
factorial[n_] := Indeterminate;
The purpose was to avoid computations of huge factorials which are not
likely to be of any use. I also added an additional set of rules:
rules3 = Map[Thread,
Map[RuleDelayed[{C1, C2, C3, C4}, #] &,
Distribute[{{factorial, (1/#) &, -# &,
sqrt}, {factorial, (1/#) &, -# &,
sqrt}, {factorial, (1/#) &, -# &,
sqrt}, {factorial, (1/#) &, -# &, sqrt}}, List]]];
These do not include Identity and are useful when we want to avoid
considering some patterns that have already been considered in earlier
computations.
After doing the above I tested a few patterns which produced nothing
new, and then this one:
sols7 = Flatten[
Union[Union[C1[A1[A3[B1[4], A2[B2[4], B3[4]]], B4[4]]] /.
rules2] /.
rules3 /. rules1]];
In[37]:=
sols7=Union[Select[sols7,Element[#,Integers]&&1â?¤#â?¤99&]]
Out[37]=
{1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,28,30,
\
31,32,33,34,36,40,42,44,46,48,52,56,60,62,63,64,65,66,68,70,72,73,76,78,80,
81,\
84,86,88,90,92,93,94,95,96,98}
In[38]:=
Complement[sols7,sols1,sols2,sols4]
Out[38]=
{62,73,86}
giving three more solutions. This now leaves only 20 open cases:
{35,37,38,43,51,53,55,57,59,61,67,69,71,75,77,79,83,87,89,91}
Andrzej
On Wednesday, June 5, 2002, at 02:41 PM, Andrzej Kozlowski wrote:
> A few additional remarks. First of all, the choice of 0 as a value in
> the definition of power and sqrt is unfortunate. It better to use:
>
> In[29]:=
> power[x_Integer?(#>0&),y_Integer?(-16â?¤#â?¤16&)]:=x^y;
> power[x_,y_]:=Indeterminate;power[x_]=Indeterminate;
>
>
> In[35]:=
> sqrt[x_?(#>0&)]:=Sqrt[x];sqrt[x_]:=Indeterminate;
>
> This will produce fewer error messages when we try using different
> arrangements of operators which may evaluate to 1/0. Even this change
> does nto eliminate the problem, but it's not a serious one. As I
> pointed out, to find more solutions one needs to try other arrangements
> of operators,e .g.
>
>
> sols4 = Flatten[
> Union[Union[A1[B1[A2[4, B2[4]]], A3[B3[4], B4[4]]] /. rules2] /.
> rules1]];
>
> (error messages about division by 0)
>
> In[41]:=
> sols4=Union[Select[sols4,Element[#,Integers]&&1â?¤#â?¤99&]]
>
> Out[41]=
> {1,2,3,4,5,6,7,8,9,10,12,14,15,16,17,18,19,20,21,22,24,25,26,27,28,29,30,
> 32,
> \
> 34,36,40,42,44,45,47,48,49,54,56,60,63,64,68,72,76,80,85,88,90,94,95,96,97}
>
> In[33]:=
> Complement[sols4,sols1,sols2]
>
> Out[33]=
> {90}
>
> In[38]:=
> patterns=Flatten[
> Union[HoldForm/@(Union[
>
> A1[B1[A2[4,B2[4]]],A3[B3[4],B4[4]]]]/.rules2)/.rules1]];
>
> In[39]:=
> Select[patterns,ReleaseHold[#]==90&]
>
> Out[39]=
> {4 24-(4+2),4 24-(4+2),4 24-(4+2),4 24-(4+2),4 24-(4+2),24 4-(4+2),24
> 4-(4+2),
> 24 4-(4+2),24 4-(4+2),24 4-(4+2)}
>
> So we found that 90 can be represented as 4*4!-(4+Sqrt[4]). So far we
> have found
>
> In[40]:=
> sols=Union[sols1,sols2,sols4]
>
> Out[40]=
> {1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,
> 28,
> \
> 29,30,31,32,33,34,36,39,40,41,42,44,45,46,47,48,49,50,52,54,56,58,60,63,64,
> 65,\
> 66,68,70,72,74,76,78,80,81,82,84,85,88,90,92,93,94,95,96,97,98,99}
>
> which means that there are
>
> In[410]:=
> Complement[Range[99],sols]//Length
>
> Out[41]=
> 23
>
> left for those who like this sort of thing.
>
> Andrzej
>
>
>
>
> On Wednesday, June 5, 2002, at 01:02 PM, Andrzej Kozlowski wrote:
>
>> Similar questions to this one are periodically sent to this list, I
>> remember myself answering one about 2 years ago (it concenred a
>> Chinese card game). There are countless ways of doing this sort of
>> thing in Mathematica, and the programming is not difficult but
>> tedious. Since this is hardly an Nobel prize level problem you won't
>> find many people willing to devote serious time to it. Having said
>> that, here is a quick attempt with a brief commentary:
>>
>> First I define modified functions power and sqrt to avoid errors due
>> to the wrong type of arguments and overflow problems which you get if
>> you use to large powers.
>>
>> power[x_Integer?(# > 0 &), y_Integer?(-16 â?¤ # â?¤ 16 &)] := x^y;
>> power[x_, y_] := 0; power[x_] = 0;
>>
>> sqrt[x_?(# â?¥ 0 &)] := Sqrt[x]; sqrt[x_] := 0;
>>
>> We shall use two types of functions, those that take two (actually
>> more) arguments: {Times, Plus, power} and those that accept only one
>> argument:
>> {Identity, Factorial, (1/#) &, -# &, sqrt}. We shall make two sets of
>> rules for each type of functions which we regard as interchangable in
>> our expressions:
>>
>> In[3]:=
>> rules1=Map[Thread,
>> Map[RuleDelayed[{A1, A2,A3}, #] &,
>> Distribute[{{Times, Plus,power}, {Times, Plus,power}, {Times,
>> Plus,
>> power}},List]]];
>>
>> In[4]:=
>> rules2=Map[Thread,
>> Map[RuleDelayed[{B1, B2,B3,B4,B5}, #] &,
>> Distribute[{{Identity,Factorial, (1/#)&,-#&,sqrt}, {Identity,
>> Factorial, (1/#)&,-#&,sqrt},{Identity,Factorial,
>> (1/#)&,-#&,
>> sqrt},{Identity,Factorial, (1/#)&,-#&,sqrt},{Identity,
>> Factorial, (1/#)&,-#&,sqrt}},List]]];
>>
>> The variables A1, A2, A3 stand for any function of the first type, B1
>> etc for any function of the second type. Now all we need to do is to
>> write a typical algebraic expression with four 4's and a suitable
>> number of A's and B's and substitute our rules.
>>
>> sols1 = Flatten[
>> Union[Union[A1[A2[B1[4], B2[4]], A3[B3[4], B4[4]]] /. rules2] /.
>> rules1]];
>>
>> We select from these those that satisfy the conditions of the problem:
>>
>> In[7]:=
>> sols1=Union[Select[sols1,Element[#,Integers]&&1â?¤#â?¤99&]]
>>
>> Out[7]=
>> {1,2,3,4,5,6,7,8,9,10,12,13,14,15,16,17,18,19,20,21,22,24,25,26,27,28,29,
>> 30,
>> 32,34,36,40,42,44,45,46,47,48,49,52,54,56,60,63,64,68,74,76,80,85,88,94,
>> 95,
>> 96,
>> 97}
>>
>> of course these are only the answers you get from the arrangement of
>> operators: A1[A2[B1[4], B2[4]], A3[B3[4], B4[4]].Suppose we would like
>> to know how, say, 74 was represented in this form. We must first make
>> a list of unevaluated patterns:
>>
>> In[8]:=
>> patterns=Flatten[
>> Union[HoldForm/@(Union[
>>
>> A1[A2[B1[4],B2[4]],A3[B3[4],B4[4]]]/.rules2])/.rules1]];
>>
>> In[9]:=
>> Select[patterns,ReleaseHold[#]==74&]
>>
>> Out[9]=
>> {(2+24)+2 24,(2+24)+24 2,(24+2)+2 24,(24+2)+24 2,2 24+(2+24),2
>> 24+(24+2),
>> 24 2+(2+24),24
>> 2+(24+2),(2+24)+(24+24),(24+2)+(24+24),(24+24)+(2+24),(24+24)+(24+2)}
>>
>> Of course 24 is 4! and 2 is Sqrt[4] (they got evaluated before we
>> applied HoldForm). We coudl have aranged for these expressions to be
>> held also but it will further slow down the computation and we can
>> indentify them anyway. So you can tell that the first answer is
>> Sqrt[4]+4!+Sqrt[4]*4! and so on.
>>
>> Next we try another arrangement of the operators:
>>
>> In[10]:=
>> sols2=Flatten[
>>
>> Union[Union[A1[A3[B1[4],A2[B2[4],B3[4]]],B4[4]]/.rules2]/.rules1]];
>>
>> In[11]:=
>> sols2=Union[Select[sols2,Element[#,Integers]&&1â?¤#â?¤99&]]
>>
>> Out[11]=
>> {1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,
>> 28,
>> \
>> 29,30,31,32,33,34,36,39,40,41,42,44,46,47,48,49,50,52,54,56,58,60,63,64,
>> 65,
>> 66,\
>> 68,70,72,74,76,78,80,81,82,84,88,92,93,94,96,97,98,99}
>>
>> Let's see if we got anything new.
>>
>> In[12]:=
>> Complement[sols2,sols1]
>>
>> Out[12]=
>> {11,23,31,33,39,41,50,58,65,66,70,72,78,81,82,84,92,93,98,99}
>>
>> We can check how many numbers we still have not accounted for so far :
>>
>> In[13]:=
>> Complement[Range[99],sols1,sols2]
>>
>> Out[13]=
>> {35,37,38,43,51,53,55,57,59,61,62,67,69,71,73,75,77,79,83,86,87,89,90,91}
>>
>> In[14]:=
>> Length[%]
>>
>> Out[14]=
>> 24
>>
>> You can try more arrangements of operators and perhaps you can
>> represent some or all of the remaining numbers. However, Since you
>> have allowed Sqrt and Factorial to be used and since 0!==1!=1 and
>> Sqrt[0]==0, Sqrt[1]==1, every number that can be represented can be
>> represented in infinitely many ways, so there is no point trying to
>> write a program that will find all of them.
>>
>
>>
>>
>> On Tuesday, June 4, 2002, at 04:41 PM, johnnyturpin wrote:
>>
>>> I know this as the "four fours" problem, and I remember it from my
>>> 7th grade
>>> Algebra class as an extra credit assignment, but recently it has been
>>> entertaining all the puzzle solvers at my work. Being a 'C'
>>> programmer, I am
>>> sure I could whip out a 'C' program to help solve this, but being new
>>> to
>>> Mathematica I don't know where to start. Here is the problem:
>>>
>>> Find the numbers 0 to 99 using any rational operator (i.e. an
>>> operation
>>> which results in a rational number) and 4 fours, i.e., each equation
>>> must
>>> contain no more or no less than 4 fours. Not all numbers may be
>>> possible.
>>>
>>> Some examples:
>>>
>>> 0 = 4 + 4 - 4 - 4
>>> 1 = 4/4 + (4 - 4)
>>> 2 = 4/4 + 4/4
>>> 27 = 4! + 4/4 + sqrt(4)
>>>
>>>
>>> The operators I remember to be valid (other than the
>>> obvious +, -, *, /
>>> include:
>>>
>>> () (Parenthesis for grouping)
>>> ! (factorial)
>>> Sqrt ( square root)
>>> X^y (exponent)
>>>
>>> --- I am not sure about the following:
>>> Min()
>>> Max()
>>> Floor()
>>> Ceiling()
>>>
>>> I am not sure if these can be thought of as "operators" and I don't
>>> remember
>>> using them...
>>>
>>>
>>>
>>>
>>> Ok, I realize that fundamentally factorial and square root include
>>> numbers
>>> which are not fours (4 factorial = 4 * 3 * 2 * 1, and sqrt(4) =
>>> 4^1/2, but
>>> for the sake of this puzzle, these can be thought of as integer
>>> operators
>>> when applied to the number 4.
>>>
>>> We are still working on 0 - 50 manually. 31 stumped us for several
>>> days...
>>>
>>>
>>>
>>>
>>>
>>
>
>
Andrzej Kozlowski
Toyama International University
JAPAN
http://platon.c.u-tokyo.ac.jp/andrzej/