5
$\begingroup$

Here is some code to visualize Project Euler Problem 502. The code scans for runs of bits in the binary representation of an integer, and outputs the beginning position of each run and the length of each run. The code is written in naive procedural style.

binaryRowGenAnalyze[w_,i_]:=Block[
  {bits,state,newstate,c,starts,lengths},
  bits=Reverse@PadLeft[IntegerDigits[i,2],w+1];
  state="outside";
  c=0;
  Do[
   newstate=bits[[j]]/.{0->"outside",1->"inside"};
   If[{state,newstate}==={"outside","inside"},
    c++;starts[c]=j
   ];
   If[{state,newstate}==={"inside","outside"},
    lengths[c]=j-starts[c]
   ];
   state=newstate,
   {j,w+1}
  ];
  {
   ArrayPlot[{Drop[bits,-1]/.{0->None,1->Brown}},Mesh->True,
    Background->White],
   Thread[{starts/@Range[c],lengths/@Range[c]}]
  }
 ]

The only advantage of the code is that it runs correctly. Here is a tiny test suite:

binaryRowGenAnalyze[4,15]
(* {XXXX,{{1,4}}} *)

binaryRowGenAnalyze[4,5]
(* {XOXO,{{1,1},{3,1}}} *)

binaryRowGenAnalyze[4,10]
(* {OXOX,{{2,1},{4,1}}} *)

binaryRowGenAnalyze[4,11]
(* {XXOX,{{1,2},{4,1}}} *)

binaryRowGenAnalyze[4,14]
(* {OXXX,{{2,3}}} *)

The function Split (Edit: not Gather) seems tailor made for this problem, but I need some wizardry to recognize runs of ones over runs of zero, and to calculate the start positions.

Improve this question
$\endgroup$
2
$\begingroup$

Like this?

bra[j_] := Module[{i,s, runLengths, startPos},
  i = Reverse@IntegerDigits[j, 2];
  s = Split[i];
  runLengths = Length /@ s;
  startPos = Most@Accumulate@Join[{1}, runLengths];
  Pick[Transpose[{startPos, runLengths}], s[[All, 1]], 1]
  ]

bra[11]

(* {{1, 2}, {4, 1}} *)

bra[101010010101]

(* {{1, 1}, {3, 1}, {5, 8}, {14, 2}, {18, 1}, {20, 1}, {22, 1}, 
    {24, 1}, {27, 1}, {32, 4}, {37, 1}}
 *)

But I guess you'll be better off by using Run Length Encoding. It's cheaper and mostly the same for this problem)

Improve this answer
$\endgroup$
3
  • $\begingroup$ Not really optimized. Just want to know if it is near your target. Compiling and other tricks available :) $\endgroup$ – Dr. belisarius Mar 1 '16 at 3:49
  • $\begingroup$ Just looked at the speed of this solution to my SequencePosition solution. I would have expected SequencePosition to be faster since it is a single pattern matching call versus the many calls and variables created in your bra solution. However, it is slower, though not noticeable until executing many runs. It seems odd that a function optimised for a specific purpose would run slower than a collection of functions for other purposes. What do you make of it? $\endgroup$ – Edmund Mar 2 '16 at 14:21
  • $\begingroup$ @Edmund I always expect pattern matching to be slower than a direct calculation. $\endgroup$ – Dr. belisarius Mar 2 '16 at 15:01
1
$\begingroup$

Here is an alternative approach using string patterns:

ClearAll[brAnalyze]

brAnalyze[n_Integer, digit_] :=
  Module[
    {tworep, str = ToString[digit], patterns},
    tworep = StringJoin@(ToString /@ Reverse@IntegerDigits[n, 2]);
    patterns = StringCases[tworep, Repeated[str]];
   {tworep, {#1, #2 - #1 + 1} & @@@ StringPosition[tworep, patterns, Overlaps -> False]}
  ]

brAnalyze[15, 1]
brAnalyze[5, 1]
brAnalyze[10, 1]
brAnalyze[11, 1]
brAnalyze[14, 1]

(* Out: 
{"1111", {{1, 4}}}
{"101", {{1, 1}, {3, 1}}}
{"0101", {{2, 1}, {4, 1}}}
{"1101", {{1, 2}, {4, 1}}}
{"0111", {{2, 3}}}
*)

The first argument to brAnalyze is the number you want to analyze, the second one is the digit whose runs you want to track, i.e. $0$ or $1$. The results shown above are for your test suite (thanks for providing that!) for the digit $1$.

Improve this answer
$\endgroup$
4
  • $\begingroup$ So the OP is asking for recognizing runs of ones AND runs of zeroes? $\endgroup$ – Dr. belisarius Mar 1 '16 at 3:36
  • $\begingroup$ The word over confuses me here "but I need some wizardry to recognize runs of ones over runs of zero," $\endgroup$ – Dr. belisarius Mar 1 '16 at 3:37
  • 2
    $\begingroup$ @Dr.belisarius Good point. I had overlooked that. I'll admit that I did not take a good look at the linked problem at Project Euler though. I thought that it would be interesting to have both the ones AND the zeros, but perhaps it's not important since it appears that the total length of the binary representation is fixed by the problem's constraint (i.e. the size of the "box"). Perhaps OP can shed some light on this. In any case, my attempt should return either kind, but not both at the same time (-: $\endgroup$ – MarcoB Mar 1 '16 at 3:40
  • $\begingroup$ Thanks for the explanation. Let's see what he actually is after $\endgroup$ – Dr. belisarius Mar 1 '16 at 3:42
1
$\begingroup$

This problem is a very good candidate for SequencePosition added in version 10.1

oneRuns[x_Integer?NonNegative] := {First@#, Subtract @@ Reverse@# + 1} & /@ 
  SequencePosition[Reverse@IntegerDigits[x, 2], {1 ..}, Overlaps -> False]

Then

oneRuns[15]
(* {{1, 4}} *)

oneRuns[11]
(* {{1, 2}, {4, 1}} *)

and so on.

Hope his helps.

Improve this answer
$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.