11
$\begingroup$

Given a list of numbers in decimal form, what is the most efficient way to determine if there are any consecutive 1s in the binary forms of those numbers? My solution so far:

dim = 3;
declist = Range[0, 2^dim - 1];
consecutiveOnes[binary_] := AnyTrue[Total /@ Split[binary], # > 1 &];
consecutiveOnes[#] & /@ IntegerDigits[declist, 2]

which gives {False, False, False, True, False, False, True, True}, in accordance with the binary representations {{0}, {1}, {1, 0}, {1, 1}, {1, 0, 0}, {1, 0, 1}, {1, 1, 0}, {1, 1, 1}}.

For dim=15 this takes ~600ms on my machine, which seems a little high, and I just want to see if there is a cleaner way to do it. I've tried using BlockMap with Times but it was much slower.

Two "extras":

  1. I guess as a comment, it is also acceptable if your method simply returns all decimal numbers up to some max number for which the binary representations have no consecutive 1s. In other words, I'm just going to run Pick on the declist with the negated results of this function, so if your solution just cuts out the middle man, that is great/acceptable.

  2. I also care about the possibility of "wrapping around", i.e. if the first and last binary digits are both 1s. Obviously I could just append the first digit to the end of each list, but perhaps this is not the most efficient way to proceed.

Addendum: Some great solutions! I took the liberty of implementing and speed testing them, with some minor modifications - hopefully I have not distorted your codes too badly:

dim = 15;
declist = Range[0, 2^dim - 1];

m1[range_] := 
  FromDigits[#, 2] & /@ 
   DeleteCases[IntegerDigits[range, 2], {___, 1, 1, ___}];

m2helper[num_] := NoneTrue[Total /@ Split[num], # > 1 &];
m2[range_] := Pick[declist, m2helper[#] & /@ IntegerDigits[range, 2]];

m3helper[num_] := 
 NestWhile[Quotient[#, 2] &, num, # > 0 && BitAnd[#, 3] != 3 &] > 0
m3[range_] := Pick[declist, Not[m3helper[#]] & /@ range];

m41 = (4^(Ceiling[dim/2]) - 1)/3;
m42 = 2 m41;
m4helper = Function[{n},
    Evaluate[
    Nor[BitAnd[BitAnd[n, m42], BitShiftLeft[BitAnd[n, m41], 1]] > 0,
        BitAnd[BitAnd[n, m42], BitShiftRight[BitAnd[n, m41], 1]] > 
      0]], {Listable}];
m4[range_] := Pick[declist, m4helper[range]];

Clear[m5];
m5[0] = {0};
m5[1] = {0, 1};
m5[n_?(IntegerQ[#] && # > 1 &)] := 
 m5[n] = Join[m5[n - 1], 2^(n - 1) + m5[n - 2]]

m6[range_] := 
  Pick[range, Thread[BitAnd[range, BitShiftRight[range, 1]] == 0]];


aa = m1[declist] // RepeatedTiming;
bb = m2[declist] // RepeatedTiming;
cc = m3[declist] // RepeatedTiming;
dd = m4[declist] // RepeatedTiming;
ee = m5[dim] // AbsoluteTiming;
ff = m6[declist] // RepeatedTiming;

Column[{aa[[1]], bb[[1]], cc[[1]], dd[[1]],ee[[1]],ff[[1]]}]

aa[[2]] == bb[[2]] == cc[[2]] == dd[[2]] == ee[[2]]==ff[[2]]

yields

0.0464
0.619
0.322
0.0974
0.00024
0.0086

True

So the direct construction method seems clearly the fastest - still this does "skip" the actual pruning step, which is not required for me, but maybe is in other use cases. If the actual pruning list is desired, it seems like the direct BitAnd+BitShiftRight method is fastest, followed by the SelectCases/DeleteCases. But if other people have other methods, certainly share them!

$\endgroup$
  • 1
    $\begingroup$ Out of curiosity, should 1 be True or False? $\endgroup$ – MassDefect Jun 1 at 22:30
  • $\begingroup$ Ultimately I want to reduce the list to the sublist which does not have consecutive 1s., so as long as you negate Trues/Falses accordingly, 1 can be either $\endgroup$ – KHAAAAAAAAN Jun 1 at 22:43
  • $\begingroup$ While I do think mine is probably the fastest so far, that 1 microsecond from RepeatedTiming won’t be correct. I use memoization to store the values. So m5[dim] will take a few milliseconds the first time, and will be almost instant every time after that until you clear the definition of m5. You can clear the definition and use AbsoluteTiming instead. $\endgroup$ – MassDefect Jun 2 at 8:58
  • $\begingroup$ Oh fair point - should've thought of that, but it was late. I'll update. $\endgroup$ – KHAAAAAAAAN Jun 2 at 16:54
12
$\begingroup$

It seems like directly constructing the list might be the fastest method. Most numbers will have consecutive ones. Based on the wrap-around criteria, we already know that testing any odd number is a waste of time. Playing around with the numbers and their binary representations, it seems like there's a pattern. Any integer power of 2 greater than 0 will definitely yield no consecutive ones (I'm defining $2^0$ to have no consecutive ones since you said that was fine).

If we look at all numbers up to, but not including $2^n$, that have no consecutive ones we get:

\begin{array}{cc} 1 & \{\} \\ 2 & \{2\} \\ 3 & \{2,4\} \\ 4 & \{2,4,8,10\} \\ 5 & \{2,4,8,10,16,18,20\} \\ 6 & \{2,4,8,10,16,18,20,32,34,36,40,42\} \\ \end{array}

If we define $n = 1, 2$ as base cases, it looks like we can calculate them recursively. Essentially, to the list at $n-1$, we need to add $2^{n-1}$, and $2^{n-1} +$ all of the values at position $n-2$. For example, at $n=5$, we know all the numbers from $n=4$ must be included. Then we add to the list $2^{5-1} = 16, 2^{5-1} + 2^{1} = 16 + 2 = 18, 2^{5-1} + 2^{2} = 16 + 4 = 20$. Since 2 and 4 are already in the list at $n = 3$, we can just reuse them.

gen[1] = {};
gen[2] = {2};
gen[n_?(IntegerQ[#] && # > 1 &)] := 
 Join[gen[n - 1], {2^(n - 1)}, 2^(n - 1) + gen[n - 2]]
AbsoluteTiming[result = gen[20];]

This takes about 0.031 seconds on my computer, and calculates all of the numbers up to $2^{20} - 1$ (a little over 1 million) that have no consecutive ones accounting for wraparound.

EDIT:

If you don't care about wrapping, basically you just need to change the base condition and slightly change the Join:

gen2[0] = {0};
gen2[1] = {0, 1};
gen2[n_?(IntegerQ[#] && # > 1 &)] := 
 gen2[n] = Join[gen2[n - 1], 2^(n - 1) + gen2[n - 2]]
AbsoluteTiming[res2 = gen2[20];]

This takes about 0.000432 seconds on my machine. I'm not actually sure why it's so much faster, maybe it's the way I'm joining the result. It does agree with the other answers posted here (except I return 0 and 1 as not having consecutive ones).

| improve this answer | |
$\endgroup$
  • $\begingroup$ I was thinking a direct construction might be best - but the wrap-around requirement is not always necessary. I guess its probably not too hard to generalize to include odd numbers for the case when wrap-around isn't needed - do you see a direct way to implement it? $\endgroup$ – KHAAAAAAAAN Jun 2 at 1:20
  • $\begingroup$ @KHAAAAAAAAN I've updated my answer to include the no wraparound case. $\endgroup$ – MassDefect Jun 2 at 2:03
  • $\begingroup$ Wow, indeed that is incredibly fast, coming in as the most efficient by orders of magnitude on my computer... $\endgroup$ – KHAAAAAAAAN Jun 2 at 7:55
19
$\begingroup$

Update: just use BitAnd[x, BitShiftRight[x, 1]] > 0. It's 10x faster than below. Bit-level parallelism beats multiple shifts every time.

This method is super fast and uses little memory all the way out to truly astronomical numbers like $2^{8192} + 2^{8191}$.

hasConsecBits[x_] := NestWhile[Quotient[#, 2] &, x, # > 0 && BitAnd[#, 3] != 3 &] > 0
(* hasConsecBits[2^8192 + 2^8191] == True *)
(* timing, around 0.015625 seconds *)

AbsoluteTiming for small numbers is on the order of 2.*10^-7. You can replace Quotient[#,2] with BitShiftRight[#,1] if you want - the performance gain is negligible.

For wraparound, it's a very simple extension. Since all binary numbers x > 0 start with a 1, any number with wraparound will have the top bit and bottom bit set - i.e it's an odd number bigger than 1 or it has consecutive bits in the middle:

hasConsecBitsWithWrap[x_] := ((x > 1) && OddQ[x]) || hasConsecBits[x]

On my machine this takes 1 second for one million numbers:

ParallelTable[hasConsecBits[x], {x, 0, 1000000}] // Timing
| improve this answer | |
$\endgroup$
10
$\begingroup$

For the sake of getting answers for higher values of dim, I present to you some bit manipulation hacking for dim=20:

dim = 20;

Find the binary numbers which encompass the range of interest in dim that are alternating 1s and 0s, one of which ends in 1 and one of which ends in 0.

x1 = (4^(Ceiling[dim/2]-1)/3;
x2 = 2 x1;

Carefully define a function which uses x1 and x2 to filter binary digits out of an input n, and then determine if right-shifting or left-shifting the result from one of these by one place causes any digits to overlap with the other:

f = Function[{n}, Evaluate[
        Or[BitAnd[BitAnd[n, x2], BitShiftLeft[BitAnd[n, x1], 1]] > 0,
           BitAnd[BitAnd[n, x2], BitShiftRight[BitAnd[n, x1], 1]] > 0]],
        {Listable}]

Then run this f on the range in question:

AbsoluteTiming[res = f[Range[0, 2^dim - 1]];]

On my machine this takes 2.5 seconds for dim = 20. It doesn't take too much longer before you're likely to run into RAM issues constructing the entirety of these lists, and if you're trying to apply this to very large numbers then Compile will restrict you to 128 bits or less (probably). I suspect this is fairly close to optimal time-wise, as a result.

This does not directly handle the 2nd case you provide, but you could construct the upper most bit of your dim of interest, add 1 to that, and use that to determine if both the highest and lowest bits are set:

x3 = 2^(dim-1)+1;
f2 = Function[{n}, BitAnd[n, x3] >= x3, {Listable}];
| improve this answer | |
$\endgroup$
6
$\begingroup$

You can use SequenceCases to check if there is 1,1 anywhere. For example

  SequenceCases[{0, 1, 1, 1, 0, 0, 1, 0, 1}, {___, 1, 1, ___}]

And check if the result is {} or not since you only care if there is at least one such case within.

Here is an example

data = {#, n = IntegerDigits[#, 2];         
     z1 = (StringJoin[ToString[#] & /@ n]);
     z2 = If[SequenceCases[n, {___, 1, 1, ___}] === {}, False, True];
     z1, z2} & /@ Range[0, 25];
Grid[data, Frame -> All]

enter image description here


I also care about the possibility of "wrapping around", i.e. if the first and last binary digits are both 1s.

The above does not now handle this special case, but could be easily added by one extra special check when it fail the first test. Here is an implementation of this

check[n_Integer] := Module[{z1, z2, m},
   m = IntegerDigits[n, 2];
   z1 = (StringJoin[ToString[#] & /@ m]);
   z2 = If[SequenceCases[m, {___, 1, 1, ___}] === {},
     If[First[m] == 1 && Last[m] == 1 && Length[m] > 1,
      True
      ,
      False
      ]
     ,
     True];
   {n, z1, z2}
   ];

Call it as

Grid[check[#] & /@ Range[0, 25], Frame -> All]

enter image description here


If you want the function to just return True/False, so you can use Pick, simply change to

check[n_Integer] := Module[{m},
   m = IntegerDigits[n, 2];
   If[SequenceCases[m, {___, 1, 1, ___}] === {},
    If[First[m] == 1 && Last[m] == 1 && Length[m] > 1,
     True
     ,
     False
     ]
    ,
    True]
   ];

And call it as

check[#] & /@ Range[0, 25]

{False, False, False, True, False, True, True, True, False, True, 
False, True, True, True, True, True, False, True, False, True, False, 
True, True, True, True, True}
| improve this answer | |
$\endgroup$
6
$\begingroup$

Too late for a party. Here is a one-liner

noZ[n_] := Map[Total[2^(Rest[FoldList[1 + #1 + #2 &, 0, #]] - 1)] &,IntegerPartitions[n]]

Input is the number of zeroes desired to have in the binary form. Output is the list of numbers whose binary representation has no neighboring 1s and contains exactly $n$ zeroes in the binary form. Thus, I am solving the extra question without creating a list first.

dec = noZ[5]
IntegerDigits[#, 2] & /@ dec

Out[1]= {32, 80, 72, 168, 164, 340, 682}    
Out[2]= {{1, 0, 0, 0, 0, 0}, 
         {1, 0, 1, 0, 0, 0, 0}, 
         {1, 0, 0, 1, 0, 0, 0}, 
         {1, 0, 1, 0, 1, 0, 0, 0}, 
         {1, 0, 1, 0, 0, 1, 0, 0}, 
         {1, 0, 1, 0, 1, 0, 1, 0, 0}, 
         {1, 0, 1, 0, 1, 0, 1, 0, 1, 0}} 

Algorithm

Given the total number of zeroes ($n$), split them in the groups (IntegerPartition), where each number indicates the number of 0es between 1s: $$ n=k_1+k_2+\ldots+k_s. $$ Next, directly construct the respective decimal number $d$ whose binary representation reads $$ 1\underbrace{0\ldots0}_{k_1}1\underbrace{0\ldots0}_{k_2}1\underbrace{0\ldots0}_{k_3}\ldots1\underbrace{0\ldots0}_{k_s} $$ for a given $n$, the minimal number is $$ d_{\text{min}}(n)=2^n=(1,\underbrace{0\ldots0}_{n})_2 $$ and the maximal number is $$ d_{\text{max}}(n)=\frac12\sum_{i=1}^n4^i=\frac23(4^n-1)=(\underbrace{101010\ldots 10}_{2n})_2.$$ Thus, for $n=5$ the numbers are in the range $[32_{10},682_{10}]=[100000_2,1010101010_2]$.

Remarks

  • For each number a Young diagram can be put in correspondence;
  • If needed, trailing 1 can easily be incorporated in the algorithm.

How many are there such numbers?

It is of interest to know how densely are the numbers without neighboring 1s are distributed. This can be inferred from the known asymptotic formula obtained by G. H. Hardy and Ramanujan in 1918 for the number of partitions $p(n)$

$$p(n)\stackrel{n\rightarrow\infty}{\sim} \frac {1} {4n\sqrt3} \exp\left({\pi \sqrt {\frac{2n}{3}}}\right).$$

Mathematica yields the number of partitions as PartitionsP. With the help of this function we can count the numbers as follows

CountZ[x_] := Module[{fn, cn, a, b},
  fn = Floor[Log[4, 3/2 x + 1]];
  cn = Floor[Log[2, x]];
  a = Sum[PartitionsP[i], {i, fn}];
  b = Table[Count[noZ[i], u_ /; u <= x], {i, fn + 1, cn}] // Total;
  a + b
  ]

CountZ[1000000]

Out[3]= 626

and plot

ListLogLogPlot[Table[{10^i, CountZ[10^i]}, {i, 10}]]

enter image description here

| improve this answer | |
$\endgroup$
3
$\begingroup$

Not very efficient, but perhaps in line with what you ultimately want to do?

positions= Position[IntegerDigits[declist,2], {___,1,1,___}];

With Extract

 numbers=Extract[declist, positions];

Output

numbers[[1;;1000]]

{3, 6, 7, 11, 12, 13, 14, 15, 19, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 35, 38, 39, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 67, 70, 71, 75, 76, 77, 78, 79, 83, 86, 87, 88, 89, 90, 91, 92, 93, 94, 95, 96, 97, 98, 99, 100, 101, 102, 103, 104, 105, 106, 107, 108, 109, 110, 111, 112, 113, 114, 115, 116, 117, 118, 119, 120, 121, 122, 123, 124, 125, 126, 127, 131, 134, 135, 139, 140, 141, 142, 143, 147, 150, 151, 152, 153, 154, 155, 156, 157, 158, 159, 163, 166, 167, 171, 172, 173, 174, 175, 176, 177, 178, 179, 180, 181, 182, 183, 184, 185, 186, 187, 188, 189, 190, 191, 192, 193, 194, 195, 196, 197, 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, 208, 209, 210, 211, 212, 213, 214, 215, 216, 217, 218, 219, 220, 221, 222, 223, 224, 225, 226, 227, 228, 229, 230, 231, 232, 233, 234, 235, 236, 237, 238, 239, 240, 241, 242, 243, 244, 245, 246, 247, 248, 249, 250, 251, 252, 253, 254, 255, 259, 262, 263, 267, 268, 269, 270, 271, 275, 278, 279, 280, 281, 282, 283, 284, 285, 286, 287, 291, 294, 295, 299, 300, 301, 302, 303, 304, 305, 306, 307, 308, 309, 310, 311, 312, 313, 314, 315, 316, 317, 318, 319, 323, 326, 327, 331, 332, 333, 334, 335, 339, 342, 343, 344, 345, 346, 347, 348, 349, 350, 351, 352, 353, 354, 355, 356, 357, 358, 359, 360, 361, 362, 363, 364, 365, 366, 367, 368, 369, 370, 371, 372, 373, 374, 375, 376, 377, 378, 379, 380, 381, 382, 383, 384, 385, 386, 387, 388, 389, 390, 391, 392, 393, 394, 395, 396, 397, 398, 399, 400, 401, 402, 403, 404, 405, 406, 407, 408, 409, 410, 411, 412, 413, 414, 415, 416, 417, 418, 419, 420, 421, 422, 423, 424, 425, 426, 427, 428, 429, 430, 431, 432, 433, 434, 435, 436, 437, 438, 439, 440, 441, 442, 443, 444, 445, 446, 447, 448, 449, 450, 451, 452, 453, 454, 455, 456, 457, 458, 459, 460, 461, 462, 463, 464, 465, 466, 467, 468, 469, 470, 471, 472, 473, 474, 475, 476, 477, 478, 479, 480, 481, 482, 483, 484, 485, 486, 487, 488, 489, 490, 491, 492, 493, 494, 495, 496, 497, 498, 499, 500, 501, 502, 503, 504, 505, 506, 507, 508, 509, 510, 511, 515, 518, 519, 523, 524, 525, 526, 527, 531, 534, 535, 536, 537, 538, 539, 540, 541, 542, 543, 547, 550, 551, 555, 556, 557, 558, 559, 560, 561, 562, 563, 564, 565, 566, 567, 568, 569, 570, 571, 572, 573, 574, 575, 579, 582, 583, 587, 588, 589, 590, 591, 595, 598, 599, 600, 601, 602, 603, 604, 605, 606, 607, 608, 609, 610, 611, 612, 613, 614, 615, 616, 617, 618, 619, 620, 621, 622, 623, 624, 625, 626, 627, 628, 629, 630, 631, 632, 633, 634, 635, 636, 637, 638, 639, 643, 646, 647, 651, 652, 653, 654, 655, 659, 662, 663, 664, 665, 666, 667, 668, 669, 670, 671, 675, 678, 679, 683, 684, 685, 686, 687, 688, 689, 690, 691, 692, 693, 694, 695, 696, 697, 698, 699, 700, 701, 702, 703, 704, 705, 706, 707, 708, 709, 710, 711, 712, 713, 714, 715, 716, 717, 718, 719, 720, 721, 722, 723, 724, 725, 726, 727, 728, 729, 730, 731, 732, 733, 734, 735, 736, 737, 738, 739, 740, 741, 742, 743, 744, 745, 746, 747, 748, 749, 750, 751, 752, 753, 754, 755, 756, 757, 758, 759, 760, 761, 762, 763, 764, 765, 766, 767, 768, 769, 770, 771, 772, 773, 774, 775, 776, 777, 778, 779, 780, 781, 782, 783, 784, 785, 786, 787, 788, 789, 790, 791, 792, 793, 794, 795, 796, 797, 798, 799, 800, 801, 802, 803, 804, 805, 806, 807, 808, 809, 810, 811, 812, 813, 814, 815, 816, 817, 818, 819, 820, 821, 822, 823, 824, 825, 826, 827, 828, 829, 830, 831, 832, 833, 834, 835, 836, 837, 838, 839, 840, 841, 842, 843, 844, 845, 846, 847, 848, 849, 850, 851, 852, 853, 854, 855, 856, 857, 858, 859, 860, 861, 862, 863, 864, 865, 866, 867, 868, 869, 870, 871, 872, 873, 874, 875, 876, 877, 878, 879, 880, 881, 882, 883, 884, 885, 886, 887, 888, 889, 890, 891, 892, 893, 894, 895, 896, 897, 898, 899, 900, 901, 902, 903, 904, 905, 906, 907, 908, 909, 910, 911, 912, 913, 914, 915, 916, 917, 918, 919, 920, 921, 922, 923, 924, 925, 926, 927, 928, 929, 930, 931, 932, 933, 934, 935, 936, 937, 938, 939, 940, 941, 942, 943, 944, 945, 946, 947, 948, 949, 950, 951, 952, 953, 954, 955, 956, 957, 958, 959, 960, 961, 962, 963, 964, 965, 966, 967, 968, 969, 970, 971, 972, 973, 974, 975, 976, 977, 978, 979, 980, 981, 982, 983, 984, 985, 986, 987, 988, 989, 990, 991, 992, 993, 994, 995, 996, 997, 998, 999, 1000, 1001, 1002, 1003, 1004, 1005, 1006, 1007, 1008, 1009, 1010, 1011, 1012, 1013, 1014, 1015, 1016, 1017, 1018, 1019, 1020, 1021, 1022, 1023, 1027, 1030, 1031, 1035, 1036, 1037, 1038, 1039, 1043, 1046, 1047, 1048, 1049, 1050, 1051, 1052, 1053, 1054, 1055, 1059, 1062, 1063, 1067, 1068, 1069, 1070, 1071, 1072, 1073, 1074, 1075, 1076, 1077, 1078, 1079, 1080, 1081, 1082, 1083, 1084, 1085, 1086, 1087, 1091, 1094, 1095, 1099, 1100, 1101, 1102, 1103, 1107, 1110, 1111, 1112, 1113, 1114, 1115, 1116, 1117, 1118, 1119, 1120, 1121, 1122, 1123, 1124, 1125, 1126, 1127, 1128, 1129, 1130, 1131, 1132, 1133, 1134, 1135, 1136, 1137, 1138, 1139, 1140, 1141, 1142, 1143, 1144, 1145, 1146, 1147, 1148, 1149, 1150, 1151, 1155, 1158, 1159, 1163, 1164, 1165, 1166, 1167, 1171, 1174, 1175, 1176, 1177, 1178, 1179, 1180, 1181, 1182, 1183, 1187, 1190, 1191, 1195, 1196, 1197, 1198}

Check

Length@numbers

31171

Input

dim = 15;
declist = Range[0, 2^dim - 1];
| improve this answer | |
$\endgroup$
  • $\begingroup$ In addition, numbers==declist[[Flatten@positions]] $\endgroup$ – user1066 Jun 4 at 10:15
1
$\begingroup$
dim = 3;
declist = Range[0, 2^dim - 1];   

consecutiveOnes[decimal_]:=If[StringCases["11"][IntegerString[decimal,2]]=={},False,True]

consecutiveOnes/@declist

enter image description here

Edit: A little improvement

consecutiveOnes[decimal_]:=StringMatchQ[IntegerString[decimal,2],___~~"11"~~___]
| 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.