Skip to main content
added 53 characters in body
Source Link
Dr. belisarius
  • 116.2k
  • 13
  • 205
  • 456

Not very efficient, but you may find it useful for some experiments. I perused the code from the link you provided (kuba's), although there are better alternatives in the answers.

ClearAll[spiral, genTri, mp];
spiral[n_?OddQ] := Nest[
   With[{d = Length@#, l = #[[-1, -1]]},
     Composition[
       Insert[#, l + 3 d + 2 + Range[d + 2], -1] &,
       Insert[#\[Transpose], l + 2 d + 1 + Range[d + 1], 1]\[Transpose] &,
       Insert[#, l + d + Range[d + 1, 1, -1], 1] &,
       Insert[#\[Transpose], l + Range[d, 1, -1], -1]\[Transpose] &
       ][#]] &,
   {{1}},
   (n - 1)/2];
genTri[n_] := genTri[n] = IntegerQ[(-1 + Sqrt[1 + 8 #])/2] & /@ Range@n
mp[n_] := mp[n] = Image[Unitize[spiral[n] /.    
                             Thread[Flatten@Position[genTri[n^2], True] -> 0]]]

(* up to 36 10^4 *)
Erosion[mp[601], 1]

Mathematica graphics

There they are, your 17 arms

(* up to 10^6 *)
Erosion[mp[1001], 1]

Mathematica graphics

For the "stability" of the number of arms a reasonable condition (rule of dumb thumb) is that the density of triangular numbers remain almost constant in each "layer" of the spiral, so you are not "creating" or destroying arms. And that is what effectively seems to happen:

r[n_] := Range[(2 n + 1)^2 + 1, (2 n + 3)^2]
f[n_] := Count[IntegerQ[(-1 + Sqrt[1 + 8 #])/2] & /@ r[n], True]
ListLinePlot[f /@ Range[200]]

Mathematica graphics

I have no explanation on why the number of arms is 17, though.

Not very efficient, but you may find it useful for some experiments. I perused the code from the link you provided (kuba's), although there are better alternatives in the answers.

ClearAll[spiral, genTri, mp];
spiral[n_?OddQ] := Nest[
   With[{d = Length@#, l = #[[-1, -1]]},
     Composition[
       Insert[#, l + 3 d + 2 + Range[d + 2], -1] &,
       Insert[#\[Transpose], l + 2 d + 1 + Range[d + 1], 1]\[Transpose] &,
       Insert[#, l + d + Range[d + 1, 1, -1], 1] &,
       Insert[#\[Transpose], l + Range[d, 1, -1], -1]\[Transpose] &
       ][#]] &,
   {{1}},
   (n - 1)/2];
genTri[n_] := genTri[n] = IntegerQ[(-1 + Sqrt[1 + 8 #])/2] & /@ Range@n
mp[n_] := mp[n] = Image[Unitize[spiral[n] /.    
                             Thread[Flatten@Position[genTri[n^2], True] -> 0]]]

Erosion[mp[601], 1]

Mathematica graphics

There they are, your 17 arms

Erosion[mp[1001], 1]

Mathematica graphics

For the "stability" of the number of arms a reasonable condition (rule of dumb thumb) is that the density of triangular numbers remain almost constant in each "layer" of the spiral, so you are not "creating" or destroying arms. And that is what effectively seems to happen:

r[n_] := Range[(2 n + 1)^2 + 1, (2 n + 3)^2]
f[n_] := Count[IntegerQ[(-1 + Sqrt[1 + 8 #])/2] & /@ r[n], True]
ListLinePlot[f /@ Range[200]]

Mathematica graphics

I have no explanation on why the number of arms is 17, though.

Not very efficient, but you may find it useful for some experiments. I perused the code from the link you provided (kuba's), although there are better alternatives in the answers.

ClearAll[spiral, genTri, mp];
spiral[n_?OddQ] := Nest[
   With[{d = Length@#, l = #[[-1, -1]]},
     Composition[
       Insert[#, l + 3 d + 2 + Range[d + 2], -1] &,
       Insert[#\[Transpose], l + 2 d + 1 + Range[d + 1], 1]\[Transpose] &,
       Insert[#, l + d + Range[d + 1, 1, -1], 1] &,
       Insert[#\[Transpose], l + Range[d, 1, -1], -1]\[Transpose] &
       ][#]] &,
   {{1}},
   (n - 1)/2];
genTri[n_] := genTri[n] = IntegerQ[(-1 + Sqrt[1 + 8 #])/2] & /@ Range@n
mp[n_] := mp[n] = Image[Unitize[spiral[n] /.    
                             Thread[Flatten@Position[genTri[n^2], True] -> 0]]]

(* up to 36 10^4 *)
Erosion[mp[601], 1]

Mathematica graphics

There they are, your 17 arms

(* up to 10^6 *)
Erosion[mp[1001], 1]

Mathematica graphics

For the "stability" of the number of arms a reasonable condition (rule of dumb thumb) is that the density of triangular numbers remain almost constant in each "layer" of the spiral, so you are not "creating" or destroying arms. And that is what effectively seems to happen:

r[n_] := Range[(2 n + 1)^2 + 1, (2 n + 3)^2]
f[n_] := Count[IntegerQ[(-1 + Sqrt[1 + 8 #])/2] & /@ r[n], True]
ListLinePlot[f /@ Range[200]]

Mathematica graphics

I have no explanation on why the number of arms is 17, though.

deleted 3 characters in body
Source Link
Dr. belisarius
  • 116.2k
  • 13
  • 205
  • 456

Not very efficient, but you may find it useful for some experiments. I perused the code from the link you provided (kuba's), although there are better alternatives in the answers.

ClearAll[spiral, genTri, mp];
spiral[n_?OddQ] := Nest[
   With[{d = Length@#, l = #[[-1, -1]]},
     Composition[
       Insert[#, l + 3 d + 2 + Range[d + 2], -1] &,
       Insert[#\[Transpose], l + 2 d + 1 + Range[d + 1], 1]\[Transpose] &,
       Insert[#, l + d + Range[d + 1, 1, -1], 1] &,
       Insert[#\[Transpose], l + Range[d, 1, -1], -1]\[Transpose] &
       ][#]] &,
   {{1}},
   (n - 1)/2];
genTri[n_] := genTri[n] = IntegerQ[(-1 + Sqrt[1 + 8 #])/2] & /@ Range@n
mp[n_] := mp[n] = Image[Unitize[spiral[n] /.    
                             Thread[Flatten@Position[genTri[n^2], True] -> 0]]]

Erosion[mp[601], 1]

Mathematica graphics

There they are, your 17 arms

Erosion[mp[1001], 1]

Mathematica graphics

For the "stability" of the number of arms a reasonable condition (rule of dumb thumb) is that the density of triangular numbers remain almost constant in each "layer" of the spiral, so you are not "creating" or destroying arms. And that is what effectively seems to happen:

r[n_] := Range[(2 n + 1)^2 + 1, (2 n + 3)^2]
f[n_] := Count[IntegerQ[(-1 + Sqrt[1 + 8 #])/2] & /@ r[n], True]
ListLinePlot[f /@ Range[200]]

Mathematica graphics

I have no explanation abouton why the number of arms is 17, though.

Not very efficient, but you may find it useful for some experiments. I perused the code from the link you provided (kuba's), although there are better alternatives in the answers.

ClearAll[spiral, genTri, mp];
spiral[n_?OddQ] := Nest[
   With[{d = Length@#, l = #[[-1, -1]]},
     Composition[
       Insert[#, l + 3 d + 2 + Range[d + 2], -1] &,
       Insert[#\[Transpose], l + 2 d + 1 + Range[d + 1], 1]\[Transpose] &,
       Insert[#, l + d + Range[d + 1, 1, -1], 1] &,
       Insert[#\[Transpose], l + Range[d, 1, -1], -1]\[Transpose] &
       ][#]] &,
   {{1}},
   (n - 1)/2];
genTri[n_] := genTri[n] = IntegerQ[(-1 + Sqrt[1 + 8 #])/2] & /@ Range@n
mp[n_] := mp[n] = Image[Unitize[spiral[n] /.    
                             Thread[Flatten@Position[genTri[n^2], True] -> 0]]]

Erosion[mp[601], 1]

Mathematica graphics

There they are, your 17 arms

Erosion[mp[1001], 1]

Mathematica graphics

For the "stability" of the number of arms a reasonable condition (rule of dumb thumb) is that the density of triangular numbers remain almost constant in each "layer" of the spiral, so you are not "creating" or destroying arms. And that is what effectively seems to happen:

r[n_] := Range[(2 n + 1)^2 + 1, (2 n + 3)^2]
f[n_] := Count[IntegerQ[(-1 + Sqrt[1 + 8 #])/2] & /@ r[n], True]
ListLinePlot[f /@ Range[200]]

Mathematica graphics

I have no explanation about why the number of arms is 17, though.

Not very efficient, but you may find it useful for some experiments. I perused the code from the link you provided (kuba's), although there are better alternatives in the answers.

ClearAll[spiral, genTri, mp];
spiral[n_?OddQ] := Nest[
   With[{d = Length@#, l = #[[-1, -1]]},
     Composition[
       Insert[#, l + 3 d + 2 + Range[d + 2], -1] &,
       Insert[#\[Transpose], l + 2 d + 1 + Range[d + 1], 1]\[Transpose] &,
       Insert[#, l + d + Range[d + 1, 1, -1], 1] &,
       Insert[#\[Transpose], l + Range[d, 1, -1], -1]\[Transpose] &
       ][#]] &,
   {{1}},
   (n - 1)/2];
genTri[n_] := genTri[n] = IntegerQ[(-1 + Sqrt[1 + 8 #])/2] & /@ Range@n
mp[n_] := mp[n] = Image[Unitize[spiral[n] /.    
                             Thread[Flatten@Position[genTri[n^2], True] -> 0]]]

Erosion[mp[601], 1]

Mathematica graphics

There they are, your 17 arms

Erosion[mp[1001], 1]

Mathematica graphics

For the "stability" of the number of arms a reasonable condition (rule of dumb thumb) is that the density of triangular numbers remain almost constant in each "layer" of the spiral, so you are not "creating" or destroying arms. And that is what effectively seems to happen:

r[n_] := Range[(2 n + 1)^2 + 1, (2 n + 3)^2]
f[n_] := Count[IntegerQ[(-1 + Sqrt[1 + 8 #])/2] & /@ r[n], True]
ListLinePlot[f /@ Range[200]]

Mathematica graphics

I have no explanation on why the number of arms is 17, though.

added 29 characters in body
Source Link
Dr. belisarius
  • 116.2k
  • 13
  • 205
  • 456

Not very efficient, but you may find it useful for some experiments. I perused the code from the link you provided (kuba's), although there are better alternatives in the answers.

ClearAll[spiral, genTri, mp];
spiral[n_?OddQ] := Nest[
   With[{d = Length@#, l = #[[-1, -1]]},
     Composition[
       Insert[#, l + 3 d + 2 + Range[d + 2], -1] &,
       Insert[#\[Transpose], l + 2 d + 1 + Range[d + 1], 1]\[Transpose] &,
       Insert[#, l + d + Range[d + 1, 1, -1], 1] &,
       Insert[#\[Transpose], l + Range[d, 1, -1], -1]\[Transpose] &
       ][#]] &,
   {{1}},
   (n - 1)/2];
genTri[n_] := genTri[n] = IntegerQ[(-1 + Sqrt[1 + 8 #])/2] & /@ Range@n
mp[n_] := mp[n] = Image[Unitize[spiral[n] /.    
                             Thread[Flatten@Position[genTri[n^2], True] -> 0]]]

Erosion[mp[601], 1]

Mathematica graphics

There they are, your 17 arms

Erosion[mp[1001], 1]

Mathematica graphics

For the "stability" of the number of arms a reasonable condition (rule of dumb thumb) is that the density of triangular numbers remain almost constant in each "layer" of the spiral, so you are not "creating" or destroying arms. And that is what effectively seems to happen:

r[n_] := Range[(2 n + 1)^2 + 1, (2 n + 3)^2]
f[n_] := Count[IntegerQ[(-1 + Sqrt[1 + 8 #])/2] & /@ r[n], True]
ListLinePlot[f /@ Range[200]]

Mathematica graphics

The maths are left as an exercise :)I have no explanation about why the number of arms is 17, though.

Not very efficient, but you may find it useful for some experiments. I perused the code from the link you provided (kuba's), although there are better alternatives in the answers.

ClearAll[spiral, genTri, mp];
spiral[n_?OddQ] := Nest[
   With[{d = Length@#, l = #[[-1, -1]]},
     Composition[
       Insert[#, l + 3 d + 2 + Range[d + 2], -1] &,
       Insert[#\[Transpose], l + 2 d + 1 + Range[d + 1], 1]\[Transpose] &,
       Insert[#, l + d + Range[d + 1, 1, -1], 1] &,
       Insert[#\[Transpose], l + Range[d, 1, -1], -1]\[Transpose] &
       ][#]] &,
   {{1}},
   (n - 1)/2];
genTri[n_] := genTri[n] = IntegerQ[(-1 + Sqrt[1 + 8 #])/2] & /@ Range@n
mp[n_] := mp[n] = Image[Unitize[spiral[n] /.    
                             Thread[Flatten@Position[genTri[n^2], True] -> 0]]]

Erosion[mp[601], 1]

Mathematica graphics

There they are, your 17 arms

Erosion[mp[1001], 1]

Mathematica graphics

For the "stability" of the number of arms a reasonable condition (rule of dumb thumb) is that the density of triangular numbers remain almost constant in each "layer" of the spiral, so you are not "creating" or destroying arms. And that is what effectively seems to happen:

r[n_] := Range[(2 n + 1)^2 + 1, (2 n + 3)^2]
f[n_] := Count[IntegerQ[(-1 + Sqrt[1 + 8 #])/2] & /@ r[n], True]
ListLinePlot[f /@ Range[200]]

Mathematica graphics

The maths are left as an exercise :)

Not very efficient, but you may find it useful for some experiments. I perused the code from the link you provided (kuba's), although there are better alternatives in the answers.

ClearAll[spiral, genTri, mp];
spiral[n_?OddQ] := Nest[
   With[{d = Length@#, l = #[[-1, -1]]},
     Composition[
       Insert[#, l + 3 d + 2 + Range[d + 2], -1] &,
       Insert[#\[Transpose], l + 2 d + 1 + Range[d + 1], 1]\[Transpose] &,
       Insert[#, l + d + Range[d + 1, 1, -1], 1] &,
       Insert[#\[Transpose], l + Range[d, 1, -1], -1]\[Transpose] &
       ][#]] &,
   {{1}},
   (n - 1)/2];
genTri[n_] := genTri[n] = IntegerQ[(-1 + Sqrt[1 + 8 #])/2] & /@ Range@n
mp[n_] := mp[n] = Image[Unitize[spiral[n] /.    
                             Thread[Flatten@Position[genTri[n^2], True] -> 0]]]

Erosion[mp[601], 1]

Mathematica graphics

There they are, your 17 arms

Erosion[mp[1001], 1]

Mathematica graphics

For the "stability" of the number of arms a reasonable condition (rule of dumb thumb) is that the density of triangular numbers remain almost constant in each "layer" of the spiral, so you are not "creating" or destroying arms. And that is what effectively seems to happen:

r[n_] := Range[(2 n + 1)^2 + 1, (2 n + 3)^2]
f[n_] := Count[IntegerQ[(-1 + Sqrt[1 + 8 #])/2] & /@ r[n], True]
ListLinePlot[f /@ Range[200]]

Mathematica graphics

I have no explanation about why the number of arms is 17, though.

added 46 characters in body
Source Link
Dr. belisarius
  • 116.2k
  • 13
  • 205
  • 456
Loading
added 428 characters in body
Source Link
Dr. belisarius
  • 116.2k
  • 13
  • 205
  • 456
Loading
added 111 characters in body
Source Link
Dr. belisarius
  • 116.2k
  • 13
  • 205
  • 456
Loading
Source Link
Dr. belisarius
  • 116.2k
  • 13
  • 205
  • 456
Loading