(*********************************************************************** Mathematica-Compatible Notebook This notebook can be used on any computer system with Mathematica 4.0, MathReader 4.0, or any compatible application. The data for the notebook starts with the line containing stars above. To get the notebook into a Mathematica-compatible application, do one of the following: * Save the data starting with the line of stars above into a file with a name ending in .nb, then open the file inside the application; * Copy the data starting with the line of stars above to the clipboard, then use the Paste menu command inside the application. Data for notebooks contains only printable 7-bit ASCII and can be sent directly in email or through ftp in text mode. Newlines can be CR, LF or CRLF (Unix, Macintosh or MS-DOS style). NOTE: If you modify the data for this notebook not in a Mathematica- compatible application, you must delete the line below containing the word CacheID, otherwise Mathematica-compatible applications may try to use invalid cache data. For more information on notebooks and Mathematica-compatible applications, contact Wolfram Research: web: http://www.wolfram.com email: info@wolfram.com phone: +1-217-398-0700 (U.S.) Notebook reader applications are available free of charge from Wolfram Research. ***********************************************************************) (*CacheID: 232*) (*NotebookFileLineBreakTest NotebookFileLineBreakTest*) (*NotebookOptionsPosition[ 33814, 997]*) (*NotebookOutlinePosition[ 34547, 1023]*) (* CellTagsIndexPosition[ 34503, 1019]*) (*WindowFrame->Normal*) Notebook[{ Cell[CellGroupData[{ Cell[TextData[{ "1999 ", StyleBox["Mathematica", FontSlant->"Italic"], " Developer Conference Programming Challenge" }], "Title", FontFamily->"Futura Extra Bold", FontSize->24], Cell[TextData[{ "A ", StyleBox["Mathematica", FontSlant->"Italic"], " programming contest" }], "Subtitle", FontFamily->"Futura Extra Bold", FontSize->18], Cell["\<\ Prepared and presented by Matthew Szudzik (mszudzik@wolfram.com)\ \>", "Subsubtitle", FontFamily->"Futura"], Cell[CellGroupData[{ Cell["Background", "Section", FontFamily->"Futura Demi"], Cell[TextData[{ "At 7 pm on 21 October 1999, participants in the 1999 ", StyleBox["Mathematica", FontSlant->"Italic"], " Developer conference were challenged to construct a function which can \ calculate the negabinary representation of any integer (see below). Entries \ were due by noon the next day. Of the 13 solutions which were received, two \ solutions caught the attention of the judges. The first, by Mark Reeve, took \ a particularly original approach to the problem and performed its \ computations with far greater efficiency than any of the other entries. The \ second, by Jarl Sobel, was written with unparalleled elegance while \ maintaining a respectable degree of efficiency. These two solutions were \ deemed the winners of the contest." }], "Text"], Cell["\<\ The sections below contain the original statement of the challenge, the \ entries which were received before the deadline, an explanation of the \ criteria on which they were judged, and an exhibition of the winners. After \ the deadline for the contest, a few especially stunning solutions were \ devised by Wolfram Research employees. Although they were exempt from the \ contest, these solutions are included below.\ \>", "Text"] }, Open ]], Cell[CellGroupData[{ Cell["Challenge", "Section", FontFamily->"Futura Demi"], Cell[TextData[{ "It is well known that", " every positive integer has a ", StyleBox["binary", FontSlant->"Italic"], " representation\[LongDash]that is, every positive integer can be written \ in base ", Cell[BoxData[ FormBox[ StyleBox["2", FontFamily->"Courier"], TraditionalForm]]], " as a sequence of ", Cell[BoxData[ FormBox[ StyleBox["1", FontFamily->"Courier"], TraditionalForm]]], "'s and ", Cell[BoxData[ FormBox[ StyleBox["0", FontFamily->"Courier"], TraditionalForm]]], "'s. In ", StyleBox["Mathematica", FontSlant->"Italic"], ", ", Cell[BoxData[ FormBox[ RowBox[{ StyleBox["IntegerDigits", FontFamily->"Courier"], StyleBox["[", FontFamily->"Courier"], RowBox[{ StyleBox["i", FontFamily->"Times"], StyleBox[",", FontFamily->"Courier"], StyleBox["2", FontFamily->"Courier"]}], StyleBox["]", FontFamily->"Courier"]}], TraditionalForm]]], " gives the binary representation of ", Cell[BoxData[ FormBox[ StyleBox["i", FontFamily->"Times"], TraditionalForm]]], ". For example, the binary representation of ", Cell[BoxData[ \(TraditionalForm\`13\)]], " is ", Cell[BoxData[ FormBox[ StyleBox[\({1, 1, 0, 1}\), FontFamily->"Courier"], TraditionalForm]]], "." }], "Text"], Cell[CellGroupData[{ Cell[BoxData[ \(IntegerDigits[13, 2]\)], "Input"], Cell[BoxData[ \({1, 1, 0, 1}\)], "Output"] }, Open ]], Cell["\<\ A number is found from its binary representation by adding together the \ corresponding powers of two.\ \>", "Text"], Cell[CellGroupData[{ Cell[BoxData[ \(1*2\^3 + 1*2\^2 + 0*2\^1 + 1*2\^0\)], "Input"], Cell[BoxData[ \(13\)], "Output"] }, Open ]], Cell[TextData[{ "Knowing this, it is easy to write a function that finds an integer, given \ its binary representation (in fact, ", StyleBox["Mathematica", FontSlant->"Italic"], "'s built-in function ", Cell[BoxData[ FormBox[ StyleBox["FromDigits", FontFamily->"Courier"], TraditionalForm]]], " does this automatically)." }], "Text"], Cell[BoxData[ \(FromBinary[ list_]\ := \ \[Sum]\+\(n = 1\)\%\(Length[list]\)Part[ list, \(-n\)]*2\^\(n - 1\)\)], "Input"], Cell[CellGroupData[{ Cell[BoxData[ \(FromBinary[{1, 1, 0, 1}]\)], "Input"], Cell[BoxData[ \(13\)], "Output"] }, Open ]], Cell[TextData[{ "It is not well known that ", StyleBox["every", FontWeight->"Bold"], " integer has a ", StyleBox["negabinary", FontSlant->"Italic"], " representation\[LongDash]that is, every integer can be written in base ", Cell[BoxData[ FormBox[ StyleBox[\(-2\), FontFamily->"Courier"], TraditionalForm]]], " as a sequence of ", Cell[BoxData[ FormBox[ StyleBox["1", FontFamily->"Courier"], TraditionalForm]]], "'s and ", Cell[BoxData[ FormBox[ StyleBox["0", FontFamily->"Courier"], TraditionalForm]]], "'s. A number is found from its negabinary representation by adding \ together the corresponding powers of ", StyleBox["negative two", FontWeight->"Bold"], ". For example, the negabinary representation of ", Cell[BoxData[ FormBox[ StyleBox["20", FontFamily->"Courier"], TraditionalForm]]], " is", " ", Cell[BoxData[ FormBox[ StyleBox[\({1, 0, 1, 0, 0}\), FontFamily->"Courier"], TraditionalForm]]], "." }], "Text"], Cell[CellGroupData[{ Cell[BoxData[ \(1*\((\(-2\))\)\^4 + 0*\((\(-2\))\)\^3 + 1*\((\(-2\))\)\^2 + 0*\((\(-2\))\)\^1 + 0*\((\(-2\))\)\^0\)], "Input"], Cell[BoxData[ \(20\)], "Output"] }, Open ]], Cell["\<\ Knowing this, it is easy to write a function that finds an integer, given its \ negabinary representation.\ \>", "Text"], Cell[BoxData[ \(FromNegabinary[ list_]\ := \ \[Sum]\+\(n = 1\)\%\(Length[list]\)Part[ list, \(-n\)]*\((\(-2\))\)\^\(n - 1\)\)], "Input"], Cell[TextData[{ "So, the negabinary representation of ", Cell[BoxData[ \(TraditionalForm\`20\)]], " is ", Cell[BoxData[ FormBox[ StyleBox[\({1, 0, 1, 0, 0}\), FontFamily->"Courier"], TraditionalForm]]], " and the negabinary representation of ", Cell[BoxData[ \(TraditionalForm\`\(-10\)\)]], " is ", Cell[BoxData[ FormBox[ StyleBox[\({1, 0, 1, 0}\), FontFamily->"Courier"], TraditionalForm]]], "." }], "Text"], Cell[CellGroupData[{ Cell[BoxData[ \(FromNegabinary[{1, 0, 1, 0, 0}]\)], "Input"], Cell[BoxData[ \(20\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(FromNegabinary[{1, 0, 1, 0}]\)], "Input"], Cell[BoxData[ \(\(-10\)\)], "Output"] }, Open ]], Cell[TextData[{ "Unfortunately, ", StyleBox["Mathematica", FontSlant->"Italic"], "'s built-in function ", Cell[BoxData[ FormBox[ StyleBox["IntegerDigits", FontFamily->"Courier"], TraditionalForm]]], " cannot automatically find the negabinary representation of an integer." }], "Text"], Cell[CellGroupData[{ Cell[BoxData[ \(IntegerDigits[20, \(-2\)]\)], "Input"], Cell[BoxData[ \(IntegerDigits::"ibase" \(\(:\)\(\ \)\) "Base \!\(-2\) is not an integer greater than 1."\)], "Message"], Cell[BoxData[ \(IntegerDigits[20, \(-2\)]\)], "Output"] }, Open ]], Cell[TextData[{ StyleBox["Write a function ", FontVariations->{"CompatibilityType"->0}], Cell[BoxData[ FormBox[ RowBox[{ StyleBox["ToNegabinary", FontFamily->"Courier"], StyleBox["[", FontFamily->"Courier"], StyleBox["i", FontFamily->"Times"], StyleBox["]", FontFamily->"Courier"]}], TraditionalForm]]], StyleBox[" that can find the negabinary representation of any integer ", FontVariations->{"CompatibilityType"->0}], Cell[BoxData[ \(TraditionalForm\`i\)]], StyleBox[". Solutions will be judged based on efficiency and elegance of \ code.", FontVariations->{"CompatibilityType"->0}] }], "Text", CellFrame->True, Background->None] }, Open ]], Cell[CellGroupData[{ Cell["Entries", "Section", FontFamily->"Futura Demi"], Cell[CellGroupData[{ Cell["A", "Subsection", FontFamily->"Futura Demi"], Cell[BoxData[ RowBox[{ StyleBox[\(ToNegabinary[int_Integer]\), FontFamily->"Courier"], StyleBox[":=", FontFamily->"Courier"], "\[IndentingNewLine]", RowBox[{ RowBox[{ RowBox[{ RowBox[{ RowBox[{ RowBox[{ RowBox[{\(\(\(int\[IndentingNewLine] // Abs\)\[IndentingNewLine] // \(3\/2\) # &\)\ \[IndentingNewLine] // Ceiling\), "\[IndentingNewLine]", "//", RowBox[{ RowBox[{ StyleBox["Table", FontFamily->"Courier"], StyleBox["[", FontFamily->"Courier"], RowBox[{ StyleBox[\(IntegerDigits[i, 2]\), FontFamily->"Courier"], StyleBox[",", FontFamily->"Courier"], RowBox[{ StyleBox["{", FontFamily->"Courier"], RowBox[{ StyleBox["i", FontFamily->"Courier"], StyleBox[",", FontFamily->"Courier"], StyleBox["0", FontFamily->"Courier"], StyleBox[",", FontFamily->"Courier"], "#"}], StyleBox["}", FontFamily->"Courier"]}]}], StyleBox["]", FontFamily->"Courier"]}], StyleBox["&", FontFamily->"Courier"]}]}], StyleBox["\[IndentingNewLine]", FontFamily->"Courier"], StyleBox["//", FontFamily->"Courier"], StyleBox[\(\(Times[#, \(\(#\[IndentingNewLine] // Length\)\[IndentingNewLine] // Table[\((\(-2\))\)\^\(i - 1\), {i, #}] &\)\ \[IndentingNewLine] // Reverse] &\) /@ # &\), FontFamily->"Courier"]}], StyleBox["\[IndentingNewLine]", FontFamily->"Courier"], StyleBox["//", FontFamily->"Courier"], StyleBox[\(\(Fold[Plus@## &, 0, #] &\) /@ # &\), FontFamily->"Courier"]}], StyleBox["\[IndentingNewLine]", FontFamily->"Courier"], StyleBox["//", FontFamily->"Courier"], StyleBox["Rest", FontFamily->"Courier"]}], StyleBox["\[IndentingNewLine]", FontFamily->"Courier"], StyleBox["//", FontFamily->"Courier"], StyleBox[\(MapIndexed[Join[{#1}, #2] &, #] &\), FontFamily->"Courier"]}], StyleBox["\[IndentingNewLine]", FontFamily->"Courier"], StyleBox["//", FontFamily->"Courier"], StyleBox[\(Cases[#, {int, binaryequivolent_} -> binaryequivolent] &\), FontFamily->"Courier"]}], StyleBox["\[IndentingNewLine]", FontFamily->"Courier"], StyleBox["//", FontFamily->"Courier"], StyleBox[\(\(IntegerDigits[#, 2] &\) @@ # &\), FontFamily->"Courier"]}]}]], "Input"] }, Open ]], Cell[CellGroupData[{ Cell["B", "Subsection", FontFamily->"Futura Demi"], Cell[BoxData[{ \(ToNegabinary[0] := {0}\), "\n", \(ToNegabinary[1] := {1}\), "\n", \(ToNegabinary[n_Integer?EvenQ] := Append[ToNegabinary[Quotient[n, \(-2\)]], 0]\), "\n", \(ToNegabinary[n_Integer?OddQ] := Append[ToNegabinary[Quotient[n - 1, \(-2\)]], 1]\)}], "Input"] }, Open ]], Cell[CellGroupData[{ Cell["C", "Subsection", FontFamily->"Futura Demi"], Cell[BoxData[{ \(ToNegabinary[n : 0 | 1] := {n}\), "\n", \(ToNegabinary[n_Integer] := With[{m = Mod[n, 2]}, Append[ToNegabinary[Quotient[n - m, \(-2\)]], m]]\)}], "Input"] }, Open ]], Cell[CellGroupData[{ Cell["D", "Subsection", FontFamily->"Futura Demi"], Cell[BoxData[ \(pigeonHole[nn_, ee_, bb_, dd_, pp_] := Module[{quad, n = nn, e = ee, b = bb, d = dd, p = pp}, \n\t\n\t\tIf[ n == 0, \ Return[d], Null]; \ \ (*\ in\ this\ case\ we' re\ done\ *) \n\t\t\n\t\tq = b/4; \n\t\t\n\t\t (*\ which\ \*"\""quad \*"\"\< is n currently in \>"*) \n\t\tIf[\((n \ \[GreaterEqual] \(-e\) + 2 q)\)\ && \ \((n\ \[LessEqual] \ \(-e\)\ + 3 q\ - 1)\), quad = 0, Null]; \n\t\tIf[\((n \[GreaterEqual] \(-e\) + 3 q)\)\ && \ \((n\ \[LessEqual] \ \(-e\)\ + 4 q\ - 1)\), quad = 1, Null]; \n\t\tIf[\((n \[GreaterEqual] \(-e\))\)\ && \ \((n\ \ \[LessEqual] \ \(-e\)\ + q\ - 1)\), quad = 2, Null]; \n\t\tIf[\((n \[GreaterEqual] \(-e\) + q)\)\ && \ \((n\ \[LessEqual] \ \(-e\)\ + 2 q\ - 1)\), quad = 3, Null]; \n\t\t\n\t\t (*\ prepare\ new, \ smaller\ partitions\ *) \n\t\t\t\(p--\); \n\t\t\te = e - 2\^\(2 p + 1\); \n\t\t\tb = 2\^\(2 p\); \ \ (*\ new\ b\ is\ same\ as\ old\ q\ *) \n\t\t\t\n\t\t (*\ increment\ \*"\""distance \*"\"\< traveled, and offset n into new \ quadA \>"*) \n\t\tSwitch[ quad, \n\t\t\t0, (*\ quadA, \ n\ is\ already\ in\ this\ quadrant, \ d\ does\ not\ change\ *) \n\t\t\t\t\t\tNull, \t\t\t\t\t\t\t\t\t\t\ \t\t\t\t\t\t\t\t\n\t\t\t1, (*\ quadB\ *) \n\t\t\t\t\t\t\td = d + b; \n\t\t\t\t\t\t\tn = n - q, \t\n\t\t\t2, \ (*\ quadC\ *) \n\t\t\t\t\t\t\td = d + 2 b; \n\t\t\t\t\t\t\tn = n + 2 q, \n\t\t\t3, \ (*\ quadD\ *) \n\t\t\t\t\t\t\td = d + 3 b; \n\t\t\t\t\t\t\tn = n + q\n\t\t]\ ; \ (*\ end\ Switch\ *) \n\t\t\n\t\tpigeonHole[n, e, b, d, p]\ (*\ call\ recursively\ at\ new\ depth\ *) \n\t\t\n]\)], "Input"], Cell[BoxData[ \(ToNegabinary[i_Integer] := Module[{e, b, q, p}, \n\t\t\n\t\t (*\ \(initialization\ --\)\ establish\ worst\ case\ \ bracketing\ of\ i\ *) \n\t\t (*\ i . e . \ we\ want\ our\ first\ 4\ partitions\ to\ span\ i\ *) \n\t\n\t\t\ ii = Abs[i]; \n\t\tp = 1; \n\t\te = 2; \n\t\tWhile[ii > 2\^\(2\ p\), \(p++\); e = e + 2\^\(2 p - 1\)]; \n\t\t\(p++\); \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ (*\ we\ need\ one\ more\ increment*) \n\t\te = e + 2\^\(2 p - 1\); \n\t\tb = 2\^\(2 p\); \n\t\td = 0; \ \ \n\n\t\t (*\ now, \ recursively\ grind\ away\ *) \n\t\td = pigeonHole[i, e, b, d, p]; \ \ \n\t\t\n\t\tIntegerDigits[d, 2]\n]\)], "Input"] }, Open ]], Cell[CellGroupData[{ Cell["E", "Subsection", FontFamily->"Futura Demi"], Cell[BoxData[ \(\(\(ToNegabinary[i_Integer] := Module[{bin, j, nb}, \[IndentingNewLine]bin = IntegerDigits[i, 2]; \[IndentingNewLine]bin = PadLeft[bin, Length[bin] + 3]; \[IndentingNewLine]j = Min[Sign[i], 0]; \[IndentingNewLine]nb = Mod[Reverse[\[IndentingNewLine]FoldList[\((\(j++\); If[#1 \[GreaterEqual] \((1 + Mod[j, 2])\), #2 + 1, #2])\) &, \[IndentingNewLine]Last[bin], Rest[Reverse[bin]]]], 2]; \[IndentingNewLine]Return[ Drop[nb, Max[0, \(-1\) + Flatten[ Position[nb, 1, 1, 1]]]]];\[IndentingNewLine]];\)\(\ \)\)\)], "Input"] }, Open ]], Cell[CellGroupData[{ Cell["F", "Subsection", FontFamily->"Futura Demi"], Cell["\<\ ToNegabinary[i_]:= \tModule[{d={},r=i,n=0}, \t\tWhile[r != 0, \t\t\tPrependTo[d,Mod[r,2]]; \t\t\tr = (r - Mod[r,2]*(-1)^n++)/2 \t\t]; \t\td /. {}->{0} \t];\t\ \>", "Input"] }, Open ]], Cell[CellGroupData[{ Cell["G", "Subsection", FontFamily->"Futura Demi"], Cell[BoxData[ \(HighestPower[x_Integer] := Module[{kk, xx}, If[Sum[2^kk, {kk, 0, xx = IntegerPart[Log[2, x]], 2}] \[GreaterEqual] x, xx, xx + 1]] /; Positive[x]\)], "Input"], Cell[BoxData[ \(HighestPower[x_Integer] := Module[{kk, xx}, xx = IntegerPart[Log[2, \(-x\)]]; If[EvenQ[xx], \(xx++\); If[Sum[2^kk, {kk, 1, xx, 2}] >= \(-x\), xx, xx + 1], If[Sum[2^kk, {kk, 1, xx, 2}] >= \(-x\), xx, xx + 2]]] /; Negative[x]\)], "Input"], Cell[BoxData[ \(replaceinteger[x_, aa_List] := Module[{zz, kk}, zz = x - Sign[x]*2^HighestPower[x]; kk = ReplacePart[aa, 1, Length[aa] - HighestPower[x]]; If[zz \[NotEqual] 0, replaceinteger[zz, kk], kk]]\)], "Input"], Cell[BoxData[ \(\(ToNegabinary[0] = {0};\)\)], "Input"], Cell[BoxData[ \(ToNegabinary[x_] := replaceinteger[x, Table[0, {HighestPower[x] + 1}]]\)], "Input"] }, Open ]], Cell[CellGroupData[{ Cell["H", "Subsection", FontFamily->"Futura Demi"], Cell[BoxData[ \(nextNegabinaryBit[{i_, sofar_}] := Module[{place = \((\(-2\))\)^Length[sofar]}, If[OddQ[i/place], {i - place, Prepend[sofar, 1]}, \[IndentingNewLine]{i, Prepend[sofar, 0]}]]\)], "Input"], Cell[BoxData[ \(ToNegabinary[ i_] := \(NestWhile[nextNegabinaryBit, {i, {}}, First[#] \[NotEqual] 0 &]\)[\([2]\)]\)], "Input"] }, Open ]], Cell[CellGroupData[{ Cell["I", "Subsection", FontFamily->"Futura Demi"], Cell[BoxData[{ \(ToNegabinary[0, sofar_: {}] := sofar\), "\[IndentingNewLine]", \(ToNegabinary[i_, sofar_: {}] := Module[{place = \((\(-2\))\)^Length[sofar]}, If[OddQ[i/place], ToNegabinary[i - place, Prepend[sofar, 1]], \[IndentingNewLine]ToNegabinary[i, Prepend[sofar, 0]]]]\)}], "Input"] }, Open ]], Cell[CellGroupData[{ Cell["J", "Subsection", FontFamily->"Futura Demi"], Cell[BoxData[ \(ToNegabinaryPainfullySlowly[i_] := breadthFirstSearch[{}, i \[Equal] FromNegabinary[#] &, {Append[#, 0], Append[#, 1]} &]\)], "Input"], Cell[BoxData[ \(FromNegabinary[ list_]\ := \ \[Sum]\+\(n = 1\)\%\(Length[list]\)Part[ list, \(-n\)]*\((\(-2\))\)\^\(n - 1\)\)], "Input"], Cell[BoxData[ \(\(\( (*\ Standard\ implementation\ of\ BFS, \ using\ general\ tree\ search\ \(\(function\)\(.\)\)\ *) \)\(\ \[IndentingNewLine]\)\(breadthFirstSearch[start_, goal_, successors_] := treeSearch[{start}, goal, successors, Join[#2, #1] &]\)\)\)], "Input"], Cell[BoxData[ \(treeSearch[states_List, goal_, successors_, combiner_] := \[IndentingNewLine]Which[\[IndentingNewLine]states \ \[Equal] {}, $Failed, \[IndentingNewLine]goal[First[states]], First[states], \[IndentingNewLine]True, treeSearch[combiner[successors[First[states]], Rest[states]], goal, successors, combiner]]\)], "Input"] }, Open ]], Cell[CellGroupData[{ Cell["K", "Subsection", FontFamily->"Futura Demi"], Cell[BoxData[ \(ToNegBinary[i_Integer] := If[MemberQ[{0, 1}, i], {i}, \ Flatten[If[ OddQ[i], \ {ToNegBinary[\((i - 1)\)/\((\(-2\))\)], 1}, \ {ToNegBinary[i/\((\(-2\))\)], 0}]]]\)], "Input"] }, Open ]], Cell[CellGroupData[{ Cell["L", "Subsection", FontFamily->"Futura Demi"], Cell[BoxData[ StyleBox[\(ToNegabinary[i_]\ := \ \n Rest[Reverse[ Mod[NestWhileList[\((#1\ - \ Mod[#1, \ 2])\)/\(-2\)\ &\ , \ i, \ #1\ != \ 0\ &\ ], \ 2]]]\), FormatType->StandardForm]], "Input"] }, Open ]], Cell[CellGroupData[{ Cell["M", "Subsection", FontFamily->"Futura Demi"], Cell[BoxData[ \(ToNegabinary[i_Integer] := Rest@\(Reverse@ Mod[NestWhileList[\(# - Mod[#, 2]\)\/\(-2\) &, i, # \[NotEqual] 0 &], 2]\)\)], "Input"] }, Open ]] }, Open ]], Cell[CellGroupData[{ Cell["Judging", "Section", FontFamily->"Futura Demi"], Cell[TextData[{ "Entries to the 1999 ", StyleBox["Mathematica", FontSlant->"Italic"], " Developer Conference Programming Challenge were judged as follows. \ First, each prospective solution ", Cell[BoxData[ FormBox[ StyleBox["ToNegabinary", FontFamily->"Courier"], TraditionalForm]]], " was tested to verify that it gives the correct output for all integer \ inputs between -500 and 500." }], "Text"], Cell[BoxData[ \(And\ @@ \ Table[FromDigits[ToNegabinary[i], \(-2\)] === i, {i, \(-500\), 500}]\)], "Input"], Cell[TextData[{ "Any entry for which this test failed to output ", Cell[BoxData[ FormBox[ StyleBox["True", FontFamily->"Courier"], TraditionalForm]]], " was disqualified." }], "Text"], Cell[TextData[{ "Next, a large integer ", Cell[BoxData[ FormBox[ StyleBox["biginteger", FontFamily->"Courier"], TraditionalForm]]], " was randomly chosen." }], "Text"], Cell[CellGroupData[{ Cell[BoxData[{ \(\(SeedRandom[1];\)\), "\[IndentingNewLine]", \(biginteger\ = \ Random[Integer, {2^\((2^13)\), 2^\((2^14)\) - 1}]\)}], "Input"], Cell[BoxData[ \(551370123140488990341955917804097475215390080035540410143194782530781469\ 156159123148081832735462820242627812517246814659222661173400902898771130959091\ 257438994272318668396933099257466575949117553138992228156155558012834927791333\ 853353693206109719491828354990453484756724957735650573632140777837319699928715\ 394939328852817240409285729003230745374030402243601006034753959883721431238496\ 095018825850867715811673625411096534558500862397603476555494704522048418149611\ 002472586978431491664549613327582216045637794483962189144011720943603979878384\ 158643729866859367942623387212748656354833918131896883907445222868839354743558\ 633110152031643136299375052762399606153135852658740079244815851981105249157562\ 100057364598804015508200848324822078812506132280706772805393289432491014306672\ 658087131554148570255519446708591654413013263859921013257200583138499747681161\ 256956210648597787548010900312688906210842363030262546250829080442564116049773\ 763816603162220841093603175824897290272747681272682024212489247121132887003019\ 252876703715937732600703283558242598922032488881575139327869955553346102505668\ 779749636657911889654377851260888567787856937024118335574365420201874960397163\ 951134068585407522180006159492387656875185195221661904784441041833436449156470\ 668047673702565761487131691770176389549619744821644020171797885923058193022868\ 237578646228240130542998740278861583024380180032697060963500984053429821606719\ 044438675728034380091150413307302046234669840840527586280389190270108489048841\ 724563028560480446457380622394523530347836016833845833775423611595350270951729\ 916170831839503522470623573007470268180029777375992422958853725168570354227253\ 021505259959323895768689992247910925154492846858332194804243020794558827439482\ 717645436929207471207919310848323985490157063570124501610567472698927882807415\ 505716535775802409912546838958521505966847329817857606109113652516763254780046\ 047444931249661473361138743713846495815368852035740261337564045195297027875180\ 679925177194250078287954968938631866909928847753669707126946515669199368615913\ 957326969910972168169045554300442510832367768578247539929457448600893342916646\ 487468802331335139244768431695246537423226489645019433547204711088040692006926\ 024502042928153685887040106739026308188128536772198846440571263510027397805421\ 001901358399809069513569436936239108712636107918166672967173055394141187332531\ 087504048546946047417911710999687623964681750554645548754914539681863624958421\ 558469658678527776901811824319657927043920305452362501573366972298707887883940\ 611567831714527658199460147150558127585518137275297291841920776916529872676964\ 855539553829561126130957567471365820883892003438882509997237813457617705162428\ 268152454032953457245271384969894964915943133831470769623493866200880876292859\ 235109775148751161638753951981441109509637445986895750331609390651001950380301\ 490924902705681515230984058515361031266701158566697778641126917726382731595752\ 833937744788857208469856063712360349490801721308256860762478219130140825208247\ 418717649758047674712079910897260139931302254631498719206249150683398624978974\ 259211419339621717086412360404937636967918251842444456165851181581213641065056\ 118065677914873802101713891605308070606672249155222410036920324892498532088812\ 077928618194100299461282562112606976703071258464264075907879093347122498758888\ 363418545519743602902216574156174134927993444125223626931437186538840542944705\ 439601504000171619733375382208133497567897061397602439219222452542990533963887\ 236532430400827066233380992879061832925947538075595116666605824297365456336055\ 155722420247803108058059110989061306552358390521871779117181830022072407879385\ 579090947414568837909839939081289170420686486056893803112593192695722849153898\ 770782369160222298975335978189359594137816687994629228292533150059795177512929\ 222116183128278856999903292793163597710436058222863270337944592325070259308136\ 752250820230652263814112029271644797411874089271527524516719465204198276364323\ 965078208507308434137741413736685132737997840383156197507506357983741347971943\ 498727957025848664227366862557172971287985931728282859545302068284772932790635\ 111071299776358964618075375704854393344492713690519831698965020061106302246902\ 254215929991044933312762011957687194997116223359326022153280634691425809260825\ 278473323764445727835398179599019490467789115225656175273420220246906246734483\ 763405622960357305789036949556656107701885319241484360730470628083766405974732\ 728953449754750520345447997779545664839062097769303614707709104747749795512136\ 770602350818005569236690180098802604115657740985576911997568864944166773118604\ 322930778892468893849501193862653421527349322834697887796389272185433277420669\ 988880689403944192372821075428568498787246526790566008131565592591511957038948\ 178237498086431732940219677671892512853562234249112827475862023541109254736467\ 150725582250784842110444538237087430736445834781861365562148956193376908947319\ 097125786317556549727354205894470539984029891517261964521608904419494228771411\ 961127136567494586784117\)], "Output"] }, Closed]], Cell["\<\ The efficiency of each remaining entry was judged by timing its output for \ this large input.\ \>", "Text"], Cell[BoxData[ \(Timing[\(ToNegabinary[biginteger];\)]\)], "Input"], Cell[TextData[{ "Many entries produced recursion errors for large inputs, so it was \ necessary to set ", Cell[BoxData[ FormBox[ StyleBox["$RecursionLimit", FontFamily->"Courier"], TraditionalForm]]], " to ", Cell[BoxData[ FormBox[ StyleBox["Infinity", FontFamily->"Courier"], TraditionalForm]]], " in those cases." }], "Text"], Cell[BoxData[ \(\($RecursionLimit = Infinity;\)\)], "Input"], Cell["\<\ Lastly, the judges carefully looked at each entry and subjectively evaluated \ its elegance.\ \>", "Text"] }, Open ]], Cell[CellGroupData[{ Cell["Winners", "Section", FontFamily->"Futura Demi"], Cell[CellGroupData[{ Cell["The Most Efficient Entry", "Subsection", FontFamily->"Futura Demi"], Cell["Submitted by Mark Reeve (msreeve@earthlink.net).", "Text"], Cell[BoxData[ \(\(\(ToNegabinary[i_Integer] := Module[{bin, j, nb}, \[IndentingNewLine]bin = IntegerDigits[i, 2]; \[IndentingNewLine]bin = PadLeft[bin, Length[bin] + 3]; \[IndentingNewLine]j = Min[Sign[i], 0]; \[IndentingNewLine]nb = Mod[Reverse[\[IndentingNewLine]FoldList[\((\(j++\); If[#1 \[GreaterEqual] \((1 + Mod[j, 2])\), #2 + 1, #2])\) &, \[IndentingNewLine]Last[bin], Rest[Reverse[bin]]]], 2]; \[IndentingNewLine]Return[ Drop[nb, Max[0, \(-1\) + Flatten[ Position[nb, 1, 1, 1]]]]];\[IndentingNewLine]];\)\(\ \)\)\)], "Input"] }, Open ]], Cell[CellGroupData[{ Cell["The Most Elegant Entry", "Subsection", FontFamily->"Futura Demi"], Cell["Submitted by Jarl Sobel (jsobel@sdav01.seinf.abb.se).", "Text"], Cell[BoxData[ StyleBox[\(ToNegabinary[i_]\ := \ \n Rest[Reverse[ Mod[NestWhileList[\((#1\ - \ Mod[#1, \ 2])\)/\(-2\)\ &\ , \ i, \ #1\ != \ 0\ &\ ], \ 2]]]\), FormatType->StandardForm]], "Input"] }, Open ]] }, Open ]], Cell[CellGroupData[{ Cell["Other Solutions", "Section", FontFamily->"Futura Demi"], Cell[TextData[{ "Members of the Wolfram Research staff devised a number of notable \ solutions. To demonstrate that a working solution could be written by a \ participant with limited mathematical skill, Matthew Szudzik \ (mszudzik@wolfram.com) found a short algorithm which searches through all \ possible sequences of ", Cell[BoxData[ FormBox[ StyleBox["1", FontFamily->"Courier"], TraditionalForm]]], "'s and ", Cell[BoxData[ FormBox[ StyleBox["0", FontFamily->"Courier"], TraditionalForm]]], "'s until it finds the desired negabinary representation." }], "Text"], Cell[BoxData[ \(ToNegabinary[i_]\ := \[IndentingNewLine]IntegerDigits[ NestWhile[# + 1 &, 0, i \[NotEqual] FromDigits[IntegerDigits[#, 2], \(-2\)] &], 2]\)], "Input"], Cell["\<\ David Librik (dlibrik@wolfram.com) found what is perhaps the ultimate \ solution\[LongDash]it is extremely efficient and elegant.\ \>", "Text"], Cell[BoxData[ \(ToNegabinary[ i_]\ := \ \[IndentingNewLine]Module[{t = \((2/ 3)\) \((4^Floor[Log[4, Abs[i] + 1] + 2] - 1)\)}, IntegerDigits[BitXor[i + t, t], 2]]\)], "Input"], Cell[TextData[{ "Many of the programmers at Wolfram Research experimented with solutions \ written in different computer languages. Perhaps the most unusual language \ in which a solution was written is PostScript. Brian Downing \ (bdowning@wolfram.com) exploited ", StyleBox["Mathematica", FontSlant->"Italic"], "'s ability to follow commands written in PostScript, and wrote the \ following solution. Note that it requires ", StyleBox["Mathematica", FontSlant->"Italic"], "'s front end." }], "Text"], Cell[BoxData[ \(ToNegabinary[n_Integer]\ := \ \n\ \ \ \ ToExpression /@ Reverse[Cases[ ImportString[\n\ \ \ \ \ \ \ \ ToString[ n] <> "\< /Helvetica findfont setfont 0 0 moveto \>" \ <> \n\ \ \ \ \ \ \ \ "\" <> \n\ \ \ \ \ \ \ \ "\<1 string cvs show 2 div floor neg cvi } \ loop pop } ifelse\>", \ "\"], \ \n\ \ \ \ _Text, \ \(-1\)]\ /. \ Text[nn_, \ ___]\ -> \ nn]\)], "Input"] }, Open ]], Cell[CellGroupData[{ Cell["References", "Section", FontFamily->"Futura Demi"], Cell[TextData[{ "See Donald E. Knuth's ", StyleBox["The Art of Computer Programming", FontSlant->"Italic"], StyleBox[" (volume 2): ", FontSlant->"Italic", FontVariations->{"CompatibilityType"->0}], StyleBox["Seminumerical Algorithms", FontSlant->"Italic"], " for a discussion of negative base number representations." }], "Text"] }, Open ]] }, Open ]] }, FrontEndVersion->"4.0 for Microsoft Windows", ScreenRectangle->{{0, 1280}, {0, 936}}, WindowSize->{799, 668}, WindowMargins->{{9, Automatic}, {Automatic, 0}}, PrintingCopies->1, PrintingPageRange->{Automatic, Automatic}, Magnification->1 ] (*********************************************************************** Cached data follows. If you edit this Notebook file directly, not using Mathematica, you must remove the line containing CacheID at the top of the file. The cache data will then be recreated when you save this file from within Mathematica. ***********************************************************************) (*CellTagsOutline CellTagsIndex->{} *) (*CellTagsIndex CellTagsIndex->{} *) (*NotebookFileOutline Notebook[{ Cell[CellGroupData[{ Cell[1739, 51, 191, 7, 122, "Title"], Cell[1933, 60, 167, 7, 60, "Subtitle"], Cell[2103, 69, 119, 3, 53, "Subsubtitle"], Cell[CellGroupData[{ Cell[2247, 76, 58, 1, 53, "Section"], Cell[2308, 79, 782, 13, 109, "Text"], Cell[3093, 94, 444, 7, 71, "Text"] }, Open ]], Cell[CellGroupData[{ Cell[3574, 106, 57, 1, 53, "Section"], Cell[3634, 109, 1519, 55, 52, "Text"], Cell[CellGroupData[{ Cell[5178, 168, 53, 1, 30, "Input"], Cell[5234, 171, 46, 1, 29, "Output"] }, Open ]], Cell[5295, 175, 126, 3, 33, "Text"], Cell[CellGroupData[{ Cell[5446, 182, 66, 1, 28, "Input"], Cell[5515, 185, 36, 1, 27, "Output"] }, Open ]], Cell[5566, 189, 371, 11, 48, "Text"], Cell[5940, 202, 146, 3, 52, "Input"], Cell[CellGroupData[{ Cell[6111, 209, 57, 1, 28, "Input"], Cell[6171, 212, 36, 1, 27, "Output"] }, Open ]], Cell[6222, 216, 1088, 38, 83, "Text"], Cell[CellGroupData[{ Cell[7335, 258, 137, 2, 28, "Input"], Cell[7475, 262, 36, 1, 27, "Output"] }, Open ]], Cell[7526, 266, 130, 3, 31, "Text"], Cell[7659, 271, 161, 3, 52, "Input"], Cell[7823, 276, 486, 18, 48, "Text"], Cell[CellGroupData[{ Cell[8334, 298, 64, 1, 28, "Input"], Cell[8401, 301, 36, 1, 27, "Output"] }, Open ]], Cell[CellGroupData[{ Cell[8474, 307, 61, 1, 28, "Input"], Cell[8538, 310, 41, 1, 27, "Output"] }, Open ]], Cell[8594, 314, 322, 10, 48, "Text"], Cell[CellGroupData[{ Cell[8941, 328, 58, 1, 28, "Input"], Cell[9002, 331, 130, 2, 23, "Message"], Cell[9135, 335, 59, 1, 27, "Output"] }, Open ]], Cell[9209, 339, 769, 23, 64, "Text"] }, Open ]], Cell[CellGroupData[{ Cell[10015, 367, 55, 1, 52, "Section"], Cell[CellGroupData[{ Cell[10095, 372, 52, 1, 46, "Subsection"], Cell[10150, 375, 3635, 86, 290, "Input"] }, Open ]], Cell[CellGroupData[{ Cell[13822, 466, 52, 1, 48, "Subsection"], Cell[13877, 469, 301, 6, 114, "Input"] }, Open ]], Cell[CellGroupData[{ Cell[14215, 480, 52, 1, 48, "Subsection"], Cell[14270, 483, 196, 4, 80, "Input"] }, Open ]], Cell[CellGroupData[{ Cell[14503, 492, 52, 1, 48, "Subsection"], Cell[14558, 495, 1907, 31, 738, "Input"], Cell[16468, 528, 749, 13, 357, "Input"] }, Open ]], Cell[CellGroupData[{ Cell[17254, 546, 52, 1, 46, "Subsection"], Cell[17309, 549, 757, 14, 184, "Input"] }, Open ]], Cell[CellGroupData[{ Cell[18103, 568, 52, 1, 46, "Subsection"], Cell[18158, 571, 182, 9, 134, "Input"] }, Open ]], Cell[CellGroupData[{ Cell[18377, 585, 52, 1, 46, "Subsection"], Cell[18432, 588, 223, 5, 80, "Input"], Cell[18658, 595, 309, 6, 97, "Input"], Cell[18970, 603, 246, 4, 80, "Input"], Cell[19219, 609, 59, 1, 28, "Input"], Cell[19281, 612, 110, 2, 45, "Input"] }, Open ]], Cell[CellGroupData[{ Cell[19428, 619, 52, 1, 46, "Subsection"], Cell[19483, 622, 248, 5, 80, "Input"], Cell[19734, 629, 149, 3, 45, "Input"] }, Open ]], Cell[CellGroupData[{ Cell[19920, 637, 52, 1, 46, "Subsection"], Cell[19975, 640, 352, 7, 114, "Input"] }, Open ]], Cell[CellGroupData[{ Cell[20364, 652, 52, 1, 46, "Subsection"], Cell[20419, 655, 183, 4, 62, "Input"], Cell[20605, 661, 161, 3, 52, "Input"], Cell[20769, 666, 285, 4, 80, "Input"], Cell[21057, 672, 374, 6, 114, "Input"] }, Open ]], Cell[CellGroupData[{ Cell[21468, 683, 52, 1, 46, "Subsection"], Cell[21523, 686, 236, 5, 80, "Input"] }, Open ]], Cell[CellGroupData[{ Cell[21796, 696, 52, 1, 46, "Subsection"], Cell[21851, 699, 246, 5, 97, "Input"] }, Open ]], Cell[CellGroupData[{ Cell[22134, 709, 52, 1, 46, "Subsection"], Cell[22189, 712, 182, 4, 83, "Input"] }, Open ]] }, Open ]], Cell[CellGroupData[{ Cell[22420, 722, 55, 1, 52, "Section"], Cell[22478, 725, 439, 12, 66, "Text"], Cell[22920, 739, 130, 3, 45, "Input"], Cell[23053, 744, 213, 7, 31, "Text"], Cell[23269, 753, 197, 7, 31, "Text"], Cell[CellGroupData[{ Cell[23491, 764, 160, 3, 45, "Input"], Cell[23654, 769, 5092, 64, 998, "Output"] }, Closed]], Cell[28761, 836, 118, 3, 26, "Text"], Cell[28882, 841, 70, 1, 28, "Input"], Cell[28955, 844, 385, 13, 48, "Text"], Cell[29343, 859, 64, 1, 28, "Input"], Cell[29410, 862, 116, 3, 31, "Text"] }, Open ]], Cell[CellGroupData[{ Cell[29563, 870, 55, 1, 52, "Section"], Cell[CellGroupData[{ Cell[29643, 875, 75, 1, 46, "Subsection"], Cell[29721, 878, 64, 0, 31, "Text"], Cell[29788, 880, 757, 14, 184, "Input"] }, Open ]], Cell[CellGroupData[{ Cell[30582, 899, 73, 1, 46, "Subsection"], Cell[30658, 902, 69, 0, 31, "Text"], Cell[30730, 904, 246, 5, 97, "Input"] }, Open ]] }, Open ]], Cell[CellGroupData[{ Cell[31025, 915, 63, 1, 52, "Section"], Cell[31091, 918, 625, 16, 83, "Text"], Cell[31719, 936, 199, 4, 80, "Input"], Cell[31921, 942, 153, 3, 48, "Text"], Cell[32077, 947, 214, 4, 62, "Input"], Cell[32294, 953, 522, 12, 100, "Text"], Cell[32819, 967, 514, 8, 166, "Input"] }, Open ]], Cell[CellGroupData[{ Cell[33370, 980, 58, 1, 52, "Section"], Cell[33431, 983, 355, 10, 48, "Text"] }, Open ]] }, Open ]] } ] *) (*********************************************************************** End of Mathematica Notebook file. ***********************************************************************)