Mathematica Pearls

Problems and Solutions					Vol 7  No 1

by Don Piele

Welcome back to Mathematica Pearls, the column devoted to examining interesting solutions to an assortment of simple yet appealing problems. At the 1997 Mathematica Developers Conference in Champaign, Illinois, a programming contest was held for the participants.  The problem, created by Matthew Cook of Wolfram Research, was to write a program to create a graphical object with certain properties. The problem, and the winning solution by Richard Mercer of Wright State University, is presented here along with Matthew's example solution.

THE PROBLEM
by Matthew Cook (mcook@wolfram.com)

\(TextForm
    \`Create\ the\ function\ TreeGraphic[d_Integer]\ \ that\ produces\ a\ 
      Graphics\ object\ for\ a\ tree\ with\ 3·2\^d\ leaves, \ 
    arranged\ and\ connected\ as\ shown\ below . \ In\ particular, \ 
    the\ 3·2\^d\ leaves\ should\ be\ arranged\ on\ a\ circle, \ 
    their\ 3·2\^\(d - 1\)\ neighbors\ should\ be\ arranged\ between
      \ them\ on\ a\ smaller\ concentric\ circle\ and\ so\ on, \ 
    until\ one\ vertex\ is\ placed\ at\ the\ center\ of\ all\ the\ 
      circles . \ As\ you\ can\ see, \ 
    every\ non\ leaf\ vertex\ is\ connected\ to\ exactly\ three\ other\ 
      vertices . \ If\ your\ output\ differs\ from\ that\ shown\ below\ by\ 
      only\ a\ rotation, \ that' s\ \(fine . \)\)

Show[GraphicsArray[{ TreeGraphic[3],  TreeGraphic[5]}]];

SOLUTION & REPORT
by Richard Mercer (richard@seuss.math.wright.edu)

Leaves[0,n_]:= Pi/2 + n*2Pi/3;
Leaves[k_,n_]:= 
	Leaves[k-1,Quotient[n,2]]+(-1)^Mod[n,2]*Pi/(3*2^k); 
Leaves[k_]:= Table[Leaves[k,n],{n,0,3*2^k-1}];
Polar[r_,th_]:= {r Cos[th],r Sin[th]};
Pts[k_]:= Polar[k+1,#]& /@ Leaves[k];
Lines[0] = Line[{{0,0},#}]& /@ Pts[0];
Lines[k_]:=
Apply[{Line[{#1,First[#2]}],Line[{#1,Last[#2]}]}&,
Transpose[{Pts[k-1],Partition[Pts[k],2]}],{1}];

TreeGraphic[d_Integer]:=
Show[Graphics[Table[Lines[k],{k,0,d}],
{AspectRatio->Automatic}]];

Examples

TreeGraphic[1];

TreeGraphic[2];

TreeGraphic[3];

REPORT

What is given above under SOLUTION and EXAMPLES is exactly what I submitted during the contest with two minor modifications : 
(1) "Pi" has replaced the actual Greek letter to improve readability.
(2) A semicolon was added to the line beginning "Lines[0] =" to suppress output.

We had 90 minutes to work on this problem and submit a solution. I thought that would be plenty of time, as  I had often done harder things in 90 minutes, as had many others in the room. Boy was I wrong! I felt like I was not thinking clearly, and the time went by quickly. One solution was submitted in a little over an hour, and one began to hear numerous muttered curses (including a few of my own) as the deadline approached. I was fortunate to find something that worked, and submitted my solution with a few minutes to spare. The deadline was extended to 10:20, and apparently two other solutions were submitted by that time. Reportedly solutions continued to come until after midnight; I left the room after the 10:20 deadline.

We had been told the solutions would be based on elegance. Elegance is subjective, of course. I spent a lot of time trying to decide whether to write a constructive program like Matthew Cook's  sample solution (below), or to write a recursive solution like the one I submitted. I would have preferred to use a constructive solution as they tend to be shorter and faster, but they are also more subtle to construct. As time grew shorter, I decided the first condition of elegance is that the program should work, and that was the only thing I could accomplish within the time limit! That turned out to be the right strategy. My solution won not because it was elegant (I don't claim that it is) but because it was the only one of the four submitted "on time" that actually did what it was supposed to do.

Incidentally, I just have to mention that my solution actually produces the picture given to us during the contest, without rotation. Matthew's solution produces an image rotated 90 degrees. But then he said it was OK to do so!

I want to express my thanks to: Wolfram Research for the generous prize of my choice of application package. (I chose Wavelet Explorer.) ;
Matthew Cook, who came up with a problem of appropriate difficulty, not too easy but not impossible , and the other employees of Wolfram Research who helped administer the contest that evening; and finally all the contestants in the competition, probably 25-30 altogether, who joined in the spirit of competition for the fun of it.

Matthew Cook's Example Solution

\(TreeGraphic[d_Integer] := 
      Show[\ Graphics[
          Table[\(Line[{k + 1, k, k + 1} #]&\)\ /@\ 
              Partition[
                Table[\({Cos[#], Sin[#]}&\)[2  Pi\ t/\((6*2^k)\)], 
                  
{t, 1 + 6*2^k}], 3, 4], {k, 0, d}], 
          AspectRatio -> Automatic]]\)

A PREVIOUS PROBLEM

KEITH NUMBERS

In Vol 6 No 3, a problem involving Keith numbers was presented. A Keith number is an n-digit integer N with the following property: If a Fibonacci-like sequence (in which each term in the sequence is the sum of the n previous terms) is formed, with the first n terms being the decimal digits of the number N, then N itself occurs as a term in the sequence. For example, 197 is a 3-digit Keith number since starting with the first three digits 1,9,7 the Fibonacci-like sequence of summing the previous 3 terms eventually includes the number 197.

              1, 9, 7, 17, 33, 57, 107, 197, ...

The problem was to write a function Keith[n] which returns the list of all n digit Keith numbers.

SOLUTION 
by Colin Rose (crose@c2.telstra-mm.net.au)

\(\(
Egbert\  = \ 
      Compile[{{num, \ _Integer}, \ {lis, \ _Integer, \ 1}}, \ 
        Block[{s = Plus@@lis, \ r = lis}, 
\ \ 
          While[s\  < \ num, \ r = Append[Rest[r], \ s]; \ s = Plus@@r]; \ 
          If[s\  === \ num, \ Print[num]]]]\ ; 


    Keith[n_]\  := \ 
      Module[{y, \ u}, \ u\  = \ Table[Unique[y], \ {n}]; 
\ \ \ 
        \(Do[\ Egbert[\ FromDigits[u], \ u], \ ##]&\)\ @@\ 
          ReplacePart[Map[{#, 0, 9}&, \ u], \ 1, \ {1, 2}]]\)\)

Keith[4] // Timing

NEW PROBLEM

The following problem comes from  the National Championship Round of the 1997 USA Computing Olympiad  (http://usaco.uwp.edu/usaco97/NationalChampProb.html#P1).

Stamps

Given a set of stamp values (e.g., {1 cent, 3 cents}) and an upper limit K to the number of stamps that can fit on an envelope, find the largest unbroken list of postages that can be created. 

For example, consider stamps whose values are limited to 1 cent and 3 cents; you can use at most 5 stamps. It's easy to see how to assemble postage of 1 through 5 cents (just use that many 1 cent stamps), and successive values aren't much harder: 6 = 3+3; 7 = 3+3+1; 8 = 3+3+1+1; 9=3+3+3; 10=3+3+3+1; 11=3+3+3+1+1; 12=3+3+3+3;  13=3+3+3+3+1 .

However, there is no way to make 14 cents of postage with 5 or fewer stamps of value 1 and 3 cents. Thus, for this set of two stamp values and a limit of K=5, the answer is {1,2,3,4,5,6,7,8,9,10,11,13}.

Write a function Stamps[mylist, K] which returns the largest unbroken list of postages with values in mylist which can fit on an envelope with at most K stamps. It is sufficient to output the lowest and highest values of the unbroken string. For example, 

In []:= Stamps[{1,3},5] 

Out[]:= {1,13}

If there is more than one answer, find them all.

Show me the pearls!

Have you got a Mathematica Pearl burried in your  files?  I invite you to share them in this column and add them to our string. If you have the goods, then send them along to piele@uwp.edu.

About The Editor

Don Piele has been interested in creating programming problems since he began the International Computer Problem Solving Contest in the pages of Creative Computing in 1981. In 1992, he organized the USA Computing Olympiad,  which selects the top four American high school computer programmers to represent the USA at the annual International Computing Olympiad. He also writes the column, Cowculations, devoted to computer algorithms using Mathematica in Quantum Magazine. The Web address for the USACO is: http:// usaco.uwp.edu.

Don Piele
Mathematics Department
University of Wisconsin-Parkside
Kenosha, WI 53141
piele@cs.uwp.edu