Find if there are consecutive 1s in a binary representation of a number

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

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).

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}];