1999 Mathematica  Developer Conference Programming Challenge

A Mathematica programming contest

Prepared and presented by Matthew Szudzik (mszudzik@wolfram.com)

Background

At 7 pm on 21 October 1999, participants in the 1999 Mathematica 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.

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.

Challenge

It is well known that every positive integer has a binary representation—that is, every positive integer can be written in base 2 as a sequence of 1's and 0's.  In Mathematica, IntegerDigits[i,2] gives the binary representation of i.  For example, the binary representation of 13 is {1, 1, 0, 1}.

IntegerDigits[13, 2]

A number is found from its binary representation by adding together the corresponding powers of two.

1*(2^3) + 1*(2^2) + 0*(2^1) + 1*(2^0)

Knowing this, it is easy to write a function that finds an integer, given its binary representation (in fact, Mathematica's built-in function FromDigits does this automatically).

FromBinary[
        list_]  :=  (∑_(n = 1)^(Length[list]))Part[
            list, -n]*(2^(n - 1))

FromBinary[{1, 1, 0, 1}]

It is not well known that every integer has a negabinary representation—that is, every integer can be written in base -2 as a sequence of 1's and 0's.  A number is found from its negabinary representation by adding together the corresponding powers of negative two.  For example, the negabinary representation of 20 is {1, 0, 1, 0, 0}.

1*(((-2))^4) + 0*(((-2))^3) + 1*(((-2))^2) + 
      0*(((-2))^1) + 0*(((-2))^0)

Knowing this, it is easy to write a function that finds an integer, given its negabinary representation.

FromNegabinary[
        list_]  :=  (∑_(n = 1)^(Length[list]))Part[
            list, -n]*(((-2))^(n - 1))

So, the negabinary representation of 20 is {1, 0, 1, 0, 0} and the negabinary representation of -10 is {1, 0, 1, 0}.

FromNegabinary[{1, 0, 1, 0, 0}]

FromNegabinary[{1, 0, 1, 0}]

Unfortunately, Mathematica's built-in function IntegerDigits cannot automatically find the negabinary representation of an integer.

IntegerDigits[20, -2]

Write a function ToNegabinary[i] that can find the negabinary representation of any integer i.  Solutions will be judged based on efficiency and elegance of code.

Entries

A

ToNegabinary[int_Integer]:=
int
 // 
                          Abs
 // (3/2) # &
 // Ceiling
//Table[IntegerDigits[i, 2],{i,0,#}]&
//Times[#, #
 // 
                                  Length
 // 
                                Table[(((-2))^(i - 1)), {i, #}] &
 // Reverse] & /@ # &
//Fold[Plus@## &, 0, #] & /@ # &
//Rest
//MapIndexed[Join[{#1}, #2] &, #] &
//Cases[#, {int, binaryequivolent_} -> 
                  binaryequivolent] &
//IntegerDigits[#, 2] & @@ # &

B

ToNegabinary[0] := {0}
ToNegabinary[1] := {1}
ToNegabinary[n_Integer?EvenQ] := 
      Append[ToNegabinary[Quotient[n, -2]], 0]
ToNegabinary[n_Integer?OddQ] := 
      Append[ToNegabinary[Quotient[n - 1, -2]], 1]

C

ToNegabinary[n : 0 | 1] := {n}
ToNegabinary[n_Integer] := 
      With[{m = Mod[n, 2]}, 
        Append[ToNegabinary[Quotient[n - m, -2]], m]]

D

\(pigeonHole[nn_, ee_, bb_, dd_, pp_] := 
      Module[{quad, n = nn, e = ee, b = bb, d = dd, p = pp}, 
	
		If[
          n == 0, \ Return[d], Null]; \ \  (*\ 
          in\ this\ case\ we' re\ done\ *) 
		
		q = 
          b/4; 
		
		 (*\ 
          which\ \*"""quad \*"" is n currently in "*) 
		If[\((n ≥ \(-e\) + 2  q)\)\  && \ \((n\  ≤ \ \(-e\)\  + 
                  3  q\  - 1)\), quad = 0, 
          Null]; 
		If[\((n ≥ \(-e\) + 
                  3  q)\)\  && \ \((n\  ≤ \ \(-e\)\  + 4  q\  - 
                  1)\), quad = 1, 
          Null]; 
		If[\((n ≥ \(-e\))\)\  && \ \((n\  ≤ \ \(-e\)\  + q\  - 1)\), quad = 2, 
          Null]; 
		If[\((n ≥ \(-e\) + 
                  q)\)\  && \ \((n\  ≤ \ \(-e\)\  + 2  q\  - 1)\), 
          quad = 3, Null]; 
		
		 (*\ prepare\ new, \ 
          smaller\ partitions\ *) 
			\(p--\); 
			e = 
          e - 2\^\(2  p + 1\); 
			b = 2\^\(2  p\); \ \  (*\ 
          new\ b\ is\ same\ as\ old\ q\ *) 
			
		 (*\ 
          increment\ \*"""distance \*"" traveled, and offset n into new quadA "*) 
		Switch[
          quad, 
			0,  (*\ quadA, \ 
            n\ is\ already\ in\ this\ quadrant, \ 
            d\ does\ not\ change\ *) 
						Null, 																		
			1,  (*\ quadB\ *) 
							d = 
            d + b; 
							n = n - q, 	
			2, \  (*\ 
            quadC\ *) 
							d = d + 2  b; 
							n = 
            n + 2  q, 
			3, \  (*\ quadD\ *) 
							d = 
            d + 3  b; 
							n = n + q
		]\ ; \  (*\ 
          end\ Switch\ *) 
		
		pigeonHole[n, e, b, d, p]\  (*\ 
          call\ recursively\ at\ new\ depth\ *) 
		
]\)

\(ToNegabinary[i_Integer] := 
      Module[{e, b, q, 
          p}, 
		
		 (*\ \(initialization\ --\)\ establish\ worst\ case\ bracketing\ of\ i\ *) 
		 (*\ 
          i . e . \ 
              we\ want\ our\ first\ 4\ partitions\ to\ span\ i\ *) 
	
		ii = Abs[i]; 
		p = 1; 
		e = 2; 
		While[ii > 2\^\(2\ p\), \(p++\); 
          e = e + 2\^\(2  p - 1\)]; 
		\(p++\); \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \  (*\ we\ need\ one\ more\ increment*) 
		e = 
          e + 2\^\(2  p - 1\); 
		b = 2\^\(2  p\); 
		d = 
          0; \ \ 

		 (*\ now, \ recursively\ grind\ away\ *) 
		d = 
          pigeonHole[i, e, b, d, p]; \ \ 
		
		IntegerDigits[d, 
          2]
]\)

E

ToNegabinary[i_Integer] := 
        Module[{bin, j, nb}, 
bin = 
            IntegerDigits[i, 2]; 
bin = 
            PadLeft[bin, Length[bin] + 3]; 
j = 
            Min[Sign[i], 0]; 
nb = 
            Mod[Reverse[
FoldList[(j++; 
                      If[#1 ≥ (1 + Mod[j, 2]), #2 + 
                          1, #2]) &, 
Last[bin], 
                  Rest[Reverse[bin]]]], 2]; 
Return[
            Drop[nb, 
              Max[0, -1 + 
                  Flatten[
                    Position[nb, 1, 1, 
                      1]]]]];
];

F

ToNegabinary[i_]:=
	Module[{d={},r=i,n=0},
		While[r != 0,
			PrependTo[d,Mod[r,2]];
			r = (r - Mod[r,2]*(-1)^n++)/2
		];
		d /. {}->{0}
	];

G

HighestPower[x_Integer] := 
      Module[{kk, xx}, 
          If[Sum[2^kk, {kk, 0, xx = IntegerPart[Log[2, x]], 
                  2}] ≥ x, xx, xx + 1]] /; 
        Positive[x]

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]

replaceinteger[x_, aa_List] := 
      Module[{zz, kk}, zz = x - Sign[x]*2^HighestPower[x]; 
        kk = ReplacePart[aa, 1, Length[aa] - HighestPower[x]]; 
        If[zz ≠ 0, replaceinteger[zz, kk], kk]]

ToNegabinary[0] = {0};

ToNegabinary[x_] := 
      replaceinteger[x, Table[0, {HighestPower[x] + 1}]]

H

nextNegabinaryBit[{i_, sofar_}] := 
      Module[{place = (-2)^Length[sofar]}, 
        If[OddQ[i/place], {i - place, 
            Prepend[sofar, 1]}, 
{i, 
            Prepend[sofar, 0]}]]

ToNegabinary[
        i_] := NestWhile[nextNegabinaryBit, {i, {}}, 
          First[#] ≠ 0 &][[2]]

I

ToNegabinary[0, sofar_: {}] := sofar
ToNegabinary[i_, sofar_: {}] := 
      Module[{place = (-2)^Length[sofar]}, 
        If[OddQ[i/place], 
          ToNegabinary[i - place, 
            Prepend[sofar, 1]], 
ToNegabinary[i, 
            Prepend[sofar, 0]]]]

J

ToNegabinaryPainfullySlowly[i_] := 
      breadthFirstSearch[{}, 
        i == FromNegabinary[#] &, {Append[#, 0], 
            Append[#, 1]} &]

FromNegabinary[
        list_]  :=  (∑_(n = 1)^(Length[list]))Part[
            list, -n]*(((-2))^(n - 1))

(* Standard implementation of BFS,  
      using general tree search function. *) 
breadthFirstSearch[start_, goal_, successors_] := 
      treeSearch[{start}, goal, successors, Join[#2, #1] &]

treeSearch[states_List, goal_, successors_, 
        combiner_] := 
Which[
states == {}, $Failed, 
goal[First[states]], 
        First[states], 
True, 
        treeSearch[combiner[successors[First[states]], Rest[states]], goal, 
          successors, combiner]]

K

ToNegBinary[i_Integer] := 
      If[MemberQ[{0, 1}, i], {i},  
        Flatten[If[
            OddQ[i],  {ToNegBinary[(i - 1)/(-2)], 
              1},  {ToNegBinary[i/(-2)], 0}]]]

L

\(ToNegabinary[i_]\  := \ 

        Rest[Reverse[
            Mod[NestWhileList[\((#1\  - \ Mod[#1, \ 2])\)/\(-2\)\  &\ , \ 
                i, \ #1\  != \ 0\  &\ ], \ 2]]]\)

M

ToNegabinary[i_Integer] := 
      Rest@Reverse@
          Mod[NestWhileList[((# - Mod[#, 2])/(-2)) &, 
              i, # ≠ 0 &], 2]

Judging

Entries to the 1999 Mathematica Developer Conference Programming Challenge were judged as follows.  First, each prospective solution ToNegabinary was tested to verify that it gives the correct output for all integer inputs between -500 and 500.

And  @@  
      Table[FromDigits[ToNegabinary[i], -2] === i, {i, -500, 
          500}]

Any entry for which this test failed to output True was disqualified.

Next, a large integer biginteger was randomly chosen.

SeedRandom[1];
biginteger  =  
      Random[Integer, {2^(2^13), 2^(2^14) - 1}]

The efficiency of each remaining entry was judged by timing its output for this large input.

Timing[ToNegabinary[biginteger];]

Many entries produced recursion errors for large inputs, so it was necessary to set $RecursionLimit to Infinity in those cases.

$RecursionLimit = Infinity;

Lastly, the judges carefully looked at each entry and subjectively evaluated its elegance.

Winners

The Most Efficient Entry

Submitted by Mark Reeve (msreeve@earthlink.net).

ToNegabinary[i_Integer] := 
        Module[{bin, j, nb}, 
bin = 
            IntegerDigits[i, 2]; 
bin = 
            PadLeft[bin, Length[bin] + 3]; 
j = 
            Min[Sign[i], 0]; 
nb = 
            Mod[Reverse[
FoldList[(j++; 
                      If[#1 ≥ (1 + Mod[j, 2]), #2 + 
                          1, #2]) &, 
Last[bin], 
                  Rest[Reverse[bin]]]], 2]; 
Return[
            Drop[nb, 
              Max[0, -1 + 
                  Flatten[
                    Position[nb, 1, 1, 
                      1]]]]];
];

The Most Elegant Entry

Submitted by Jarl Sobel (jsobel@sdav01.seinf.abb.se).

\(ToNegabinary[i_]\  := \ 

        Rest[Reverse[
            Mod[NestWhileList[\((#1\  - \ Mod[#1, \ 2])\)/\(-2\)\  &\ , \ 
                i, \ #1\  != \ 0\  &\ ], \ 2]]]\)

Other Solutions

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 1's and 0's until it finds the desired negabinary representation.

ToNegabinary[i_]  := 
IntegerDigits[
        NestWhile[# + 1 &, 0, 
          i ≠ FromDigits[IntegerDigits[#, 2], -2] &], 
        2]

David Librik (dlibrik@wolfram.com) found what is perhaps the ultimate solution—it is extremely efficient and elegant.

ToNegabinary[
        i_]  :=  
Module[{t = (2/
                  3) (4^Floor[Log[4, Abs[i] + 1] + 2] - 1)}, 
        IntegerDigits[BitXor[i + t, t], 2]]

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 Mathematica's ability to follow commands written in PostScript, and wrote the following solution.  Note that it requires Mathematica's front end.

\(ToNegabinary[n_Integer]\  := \ 
\ \ \ \ ToExpression /@ 
        Reverse[Cases[
              ImportString[
\ \ \ \ \ \ \ \ ToString[
                    n] <> " /Helvetica findfont setfont  0 0 moveto " <> 
\ \ \ \ \ \ \ \ "dup 0 eq { (0) show } { { dup 0 eq { exit } if dup 2 mod abs " <> 
\ \ \ \ \ \ \ \ "1 string cvs show 2 div floor neg cvi } loop pop } ifelse", \ "EPS"], \ 
\ \ \ \ _Text, \ \(-1\)]\  /. \ 
            Text[nn_, \ ___]\  -> \ nn]\)

References

See Donald E. Knuth's The Art of Computer Programming (volume 2): Seminumerical Algorithms for a discussion of negative base number representations.