# How to find all binary numbers with the kth =0 and smaller than 2^n?

I have been stuck in this problem for a long time.

I need to find a general code to collect all binary numbers which are at most n digits (<2^(n-1)) with the kth digit equal to 0. For example, I need to find all binary numbers in the form of x0xx (4 digits with the second one equal to 0), then I need to write three For loops and get the answer: {0000,0001,0010,0011,1000,1001,1010,1011}. However, if I change the value of n or k, I need to modify my code, so now I am trying to find a general code for any n and k.

My idea is

ithzero = Compile[{{k, _Integer},{n,_Integer}}, nul = {};Do[nul = Append[nul, BaseForm[i, 2]*Boole[IntegerDigits[i, 2, n][[k]] == 0]], {i, 0, 2^n - 1}]];


However, I am not satisfied with this code, because it gives many 0s due to Boole. By the way, I still don't have any idea about how to verify if x is in ithzero[n,k]. I thought 5\[Element]ithzero[5,2] is a logic expression, but it isn't.

I am very grateful to any help!

• ToString /@ Row /@ Select[Tuples[{0, 1}, n /. n -> 4], (#[[k /. k -> 2]] == 0) &] May 16 '17 at 6:04

Consider Tuples. For example:

fn[n_, k_] /; 0 < k <= n :=
Tuples @ ReplacePart[Table[{0, 1}, {n}], k -> {0}]

FromDigits[fn[4, 2]\[Transpose]]

{0, 1, 10, 11, 1000, 1001, 1010, 1011}


Or as strings:

ToString /@ Row /@ fn[4, 2]

{"0000", "0001", "0010", "0011", "1000", "1001", "1010", "1011"}

• Nice work, Thanks! May 16 '17 at 16:17
• By the way, is there a neat way to convert {0, 1, 10, 11, 1000, 1001, 1010, 1011} into decimal numbers? May 16 '17 at 17:57
• @JieyuYou Certainly, just specify the correct base in FromDigits: FromDigits[fn[4, 2]\[Transpose], 2] gives {0, 1, 2, 3, 8, 9, 10, 11} May 17 '17 at 5:07

Could use bit operations:

f[n_, k_] := Union @ BitAnd[Range[0,2^n-1], BitXor[2^n-1, 2^k]]

f[4, 2]
IntegerDigits[f[4, 2], 2, 4]


{0, 1, 2, 3, 8, 9, 10, 11}

{{0, 0, 0, 0}, {0, 0, 0, 1}, {0, 0, 1, 0}, {0, 0, 1, 1}, {1, 0, 0, 0}, {1, 0, 0, 1}, {1, 0, 1, 0}, {1, 0, 1, 1}}

Another faster possibility:

g[n_, k_] := Flatten @ Outer[Plus, 2^(k+1) Range[0, 2^(n-k-1)-1], Range[0, 2^k-1]]

g[4, 2]
IntegerDigits[g[4, 2], 2, 4]


{0, 1, 2, 3, 8, 9, 10, 11}

{{0, 0, 0, 0}, {0, 0, 0, 1}, {0, 0, 1, 0}, {0, 0, 1, 1}, {1, 0, 0, 0}, {1, 0, 0, 1}, {1, 0, 1, 0}, {1, 0, 1, 1}}

• Fortunately, BitClear[] is now built-in: Union[BitClear[Range[0, 2^n - 1], k]] May 18 '17 at 8:52
f1[n_, k_] := Insert[#, 0, k] & /@ Tuples[{0, 1}, n - 1]
f1[4, 2]
(*{{0, 0, 0, 0}, {0, 0, 0, 1}, {0, 0, 1, 0}, {0, 0, 1, 1}, {1, 0, 0, 0},
{1, 0, 0, 1}, {1, 0, 1, 0}, {1, 0, 1, 1}}*)


Instead of mapping each element and inserting 0, we can transpose the list and use Insert[] to insert a ConstantArray.

f2[n_, k_] := Insert[#, ConstantArray[0, 2^(n - 1)], k] &@
Transpose@Tuples[{0, 1}, n - 1] // Transpose

f1[20,3]//AbsoluteTiming
f2[20,3]//AbsoluteTiming
fn[20,3]//AbsoluteTiming (*Mr.Wizard's solution*)


0.21

0.14

0.02

• Insert while clear is orders of magnitude slower than using Tuples alone, and uses far more memory. I encourage you compare the two. May 16 '17 at 6:41
• @Mr.Wizard Yes, you are right. I checked it and it is almost an order of magnitude slower compared to yours. I don't seem to understand the purpose of insert at all if it can't be applied even for a question like this. It might be because of mapping the list. I tried to use Insertin a different way, but it is still slower than yours, please check the edit. Can I include the timing of your solution for the purpose of comparison? May 16 '17 at 7:04
• Of course you may include timings for my function if you wish. Insert is very useful it just isn't particularly fast as it must be applied once for each element. It is almost always faster to perform vectorized operations in Mathematica, apart from compilation. See e.g. (7996) for some possibly useful examples. May 16 '17 at 7:17
• Also Tuples is especially fast (see (4751)) so it is best for performance to use it directly rather than further processing its output, where possible. May 16 '17 at 7:19

In:

Clear[f]
f[n_, k_] := Module[{xss},
xss = Tuples[{0, 1}, n];
xss [[All, k]] = 0 xss [[All, k]] ;
Union[xss]]
f[5, 1]


Out:

{{0, 0, 0, 0, 0}, {0, 0, 0, 0, 1}, {0, 0, 0, 1, 0}, {0, 0, 0, 1,
1}, {0, 0, 1, 0, 0}, {0, 0, 1, 0, 1}, {0, 0, 1, 1, 0}, {0, 0, 1, 1,
1}, {0, 1, 0, 0, 0}, {0, 1, 0, 0, 1}, {0, 1, 0, 1, 0}, {0, 1, 0, 1,
1}, {0, 1, 1, 0, 0}, {0, 1, 1, 0, 1}, {0, 1, 1, 1, 0}, {0, 1, 1, 1,
1}}


Where k is position from right:

f[n_, k_] :=
Flatten[IntegerDigits[2^k # + Range[0, 2^(k - 1) - 1], 2, n] & /@
Range[0, 2^(n - k) - 1], 1]
Row@(ArrayPlot[f[6, #], PlotLabel -> Row[{"k=", #}],
ImageSize -> 100] & /@ Range) Where k is position from left:

g[n_, k_] := f[n, n - k + 1]
Row@(ArrayPlot[g[6, #], PlotLabel -> Row[{"kl=", #}],
ImageSize -> 100] & /@ Range) 