cp's OEIS Frontend

A131967 Farey fractal sequence.

%I A131967 #8 Nov 30 2016 23:48:33
%S A131967 1,2,1,3,2,1,4,3,5,2,1,6,4,3,5,7,2,1,8,6,4,9,3,10,5,7,11,2,1,12,8,6,4,
%T A131967 9,3,10,5,7,11,13,2,1,14,12,8,6,15,4,9,16,3,17,10,5,18,7,11,13,19,2,1,
%U A131967 20,14,12,8,6,15,4,21,9,16,3,17,10,22,5,18,7,11,13,19,23,2
%N A131967 Farey fractal sequence.
%C A131967 As a fractal sequence, A131967 properly contains itself as a subsequence (infinitely many times).
%C A131967 Step 1: List the Farey fractions by order, like this:
%C A131967 order 1: 0/1 1/1
%C A131967 order 2: 0/1 1/2 1/1
%C A131967 order 3: 0/1 1/3 1/2 2/3 1/1, etc.
%C A131967 Step 2: Replace each a/b by its position when all the segments in Step 1 are concatenated and each distinct predecessor of a/b is counted just once, getting
%C A131967 1 2
%C A131967 1 3 2
%C A131967 1 4 3 5 2, etc.
%C A131967 Step 3: Concatenate the segments found in Step 2.
%D A131967 C. Kimberling, "Fractal sequences and interspersions," Ars Combinatoria 45 (1997) 157-168.
%e A131967 The Farey fractions of order 4 are
%e A131967 0 1/4 1/3 1/2 2/3 3/4 1, having position numbers
%e A131967 1 6 4 3 5 7 2, which is the fourth segment in the formation of A131967.
%t A131967 Farey[n_] :=
%t A131967   Select[Union@
%t A131967     Flatten@Outer[Divide, Range[n + 1] - 1, Range[n]] , # <= 1 &];
%t A131967 newpos[n_] :=
%t A131967   Module[{length = Total@Array[EulerPhi, n] + 1, f1 = Farey[n],
%t A131967     f2 = Farey[n - 1], to},
%t A131967    to = Complement[Range[length], Flatten[Position[f1, #] & /@ f2]];
%t A131967    ReplacePart[Array[0 &, length],
%t A131967     Inner[Rule, to, Range[length - Length[to] + 1, length], List]]];
%t A131967 a[n_] := Flatten@
%t A131967    Table[Fold[
%t A131967      ReplacePart[Array[newpos, i][[#2 + 1]],
%t A131967        Inner[Rule,
%t A131967         Flatten@Position[Array[newpos, i][[#2 + 1]], 0], #1, List]] &,
%t A131967       Array[newpos, i][[1]], Range[i - 1]], {i, n}];
%t A131967 a[10] (* _Birkas Gyorgy_, Feb 21 2011 *)
%Y A131967 Cf. A131968.
%K A131967 nonn
%O A131967 1,2
%A A131967 _Clark Kimberling_, Aug 02 2007