(* From Primoz Pirnat, Jun 25 2024 *)
(* the program is written in Mathematica 11.3. *)

Fn[n_] := Fibonacci[n];

A005652[num_] := 
 Module[{n = 2 num - 1, st, stm, cif, fl = 1, tip, odm1, odm2, 
   d = {0, 0}, rd = 0, j, str = ""},
  stm = Quotient[Floor[Log[GoldenRatio, N[n + 3/(10 n), 50]] + 5.675],
      6]*6;
  odm1 = {{-1, 1}, {0, 0}, {-1, 1}, {0, 0}, {-1, 1}};
  odm2 = {{1, -1}, {-1, 1}, {1, -1}};
  For[st = stm, st >= 6, st -= 6,
   cif = {Fn[st]/2, Fn[st], 3 Fn[st]/2, 2 Fn[st], 5 Fn[st]/2};
   If[cif[[1]] > n, Goto[forward]];
   tip = 5;
   While[tip > 0,
    	If[n >= cif[[tip]], Break[]];
    tip--
    ];
   d += odm1[[tip]]*fl;
   n -= cif[[tip]];
   If[MemberQ[{1, 3, 5}, tip], fl *= -1];
   Label[forward];
   cif = {Fn[st - 4], Fn[st - 4] + Fn[st - 3]/2, Fn[st - 2]};
   If[st == 6 && n == 0, d -= {1, -1}*fl];
   If[cif[[1]] > n, Continue[]];
   tip = 3;
   While[tip > 0,
    	If[n >= cif[[tip]], Break[]];
    tip--
    ];
   If[st == 6, odm2 = {{0, 0}, {0, 0}, {0, 0}}];
   d += odm2[[tip]]*fl;
   n -= cif[[tip]];
   If[tip == 2, fl *= -1];
   ];
  Block[{$MaxExtraPrecision = Max[50, Round[N[Log[10, 2 num]]]]},
   For[j = 0, j <= Abs[d[[2]]], j++,
    If[FractionalPart[
       N[(2 num - 1 + 
           j*Sign[d[[2]]]) GoldenRatio, $MaxExtraPrecision + 10]] > 
      1/2, str = str <> "\[FilledCircle]", 
     str = str <> "\[EmptyCircle]"]
    ]
   ];
  If[d[[2]] != 0,
   If[d[[2]] > 0,
    rd = StringCount[str, "\[EmptyCircle]\[EmptyCircle]"] - 
      StringCount[str, "\[FilledCircle]\[FilledCircle]"],
    rd = StringCount[str, "\[FilledCircle]\[FilledCircle]"] - 
      StringCount[str, "\[EmptyCircle]\[EmptyCircle]"]
    ]
   ];
  Return[2 num - 1 + d[[2]] + rd]
  ]
SetAttributes[A005652, Listable];