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/