Searching for 10-base number $n$ that follow two rules when written in base

Questions
1

Well, I am trying to write a clever code that looks for a 10-base number n such that:

  1. The digit sum of n in base 2 must be equal to k;
  2. The GCD of the n in base 2 and the integer reverse of the number n in base 2 must be equal to k.

I already proved that the number k must end with a 1,3,7 or 9. Otherwise, there is no solution possible for n. That sequence can be found using the following Mathematica-code:

In[1]=Map[(1/2*(5*# + Mod[3*# + 2, 4] - 4)) &, Range[25]]

Out[1]={1, 3, 7, 9, 11, 13, 17, 19, 21, 23, 27, 29, 31, 33, 37, 39, 41, 43, 47, 49, 51, 53, 57, 59, 61}

Question: how can I find the minimal value of n such that it obeys the rules stated above?

My work: the rules from above can be written as Mathematica-code as follows:

  1. k==Total[IntegerDigits[n,2]]
  2. k==GCD[FromDigits[IntegerDigits[n,2]],IntegerReverse[FromDigits[IntegerDigits[n,2]]]]

And I know the following solutions \left(k,n\right):

\left(k,n\right)\in\left\{\left(1,1\right),\left(3,11\right),\left(9,767\right),\left(11,4543829\right),\left(17,1041919\right),\left(19,4120511\right)\right\}\tag1

But I am especially interested in k=39 and k=41.

I tried running the following code:

In[2]:=Clear["Global`*"];
DeleteCases[ParallelTable[
   First[ParallelTable[
       If[k == Total[IntegerDigits[n, 2]] && 
         k == GCD[FromDigits[IntegerDigits[n, 2]], 
           IntegerReverse[FromDigits[IntegerDigits[n, 2]]]], {k, n}, 
        Nothing], {n, 0, 10^7}] //. {} -> Nothing] // Quiet, {k, 
    Map[(1/2*(5*# + Mod[3*# + 2, 4] - 4)) &, Range[25]]}], 
  First[Nothing]] // Quiet

Out[2]={{1, 1}, {3, 11}, {9, 767}, {11, 4543829}, {17, 1041919}, {19, 
  4120511}}

But it gave limited solutions and not the one I am especially interested in.

2

Here are a few thoughts:

First, you’re interested in k=39 and k=41, but you’re using a list of 25 possible k. You might want to reduce your scope until you start finding things that you’re interested in.

Second, for each k you’re only searching the first 10^7 integers. If there don’t exist any solutions for k=39 below that threshold, then you won’t find them. Do you have reason to believe that all solutions will be below that threshold?

Third, your approach is very inefficient. For example, you’re building large lists only to take the first element. You’re pattern matching/replacing to remove degenerate cases. All of this means that you are wasting a huge amount of computation effort.

I replaced Range[25] in your code with Range[1] and it took about 15 seconds to complete. That doesn’t bode well for finding solutions for the higher k values.

For this kind of search problem, it can be better to use a more imperative style. Specifically, you might use a Do loop and Throw as soon as you find a solution.

Here is an example. I’ve used some helper functions to clarify/simplify, and I used AboluteTiming to get a sense of how this scales.

BinaryDigitSum[n_] := Total[IntegerDigits[n, 2]]

SpecialGCD[n_] :=
     With[
      {newNum = FromDigits[IntegerDigits[n, 2]]},
      GCD[newNum, IntegerReverse[newNum]]]

IsSolution[k_, n_] := Equal[k, BinaryDigitSum[n], SpecialGCD[n]]

AbsoluteTiming[Catch[Do[If[IsSolution[17, i], Throw[i]], {i, 10^7}]]]

This gave:

{7.83031, 1041919}

So, it took about 8 seconds to find a solution for k=17. I replaced 17 with 19, and it took about 33 seconds. For k=39, it took 84 seconds to search up to 10^7, but it didn’t find a solution. My next attempt would be to increase the search space to 10^8, but I didn’t actually try that. It looks like this might take a long time to find your solutions. You may need to find more optimizations.

3

Using the nice code above and changing Do to ParallelDo, no solutions are found for 39 up to 10^10. Took ~2h on my M1 Max Macbook Pro running 8 kernels.

(* {6988.55, Null} *)

Seems to scale exponentially so testing up to 10^11 will take ~10 times as long.