円の内側で円を転がす ～もう少し情報を整理～

前回は、円の内側で小さな円が転がっている感を出すために、点を一つ
追加した。仮に、動点Ｐとでも名付けよう。更にこれをもっと滑らかに
動かすために、表の更新は一旦計算した値を配列に格納し、丸ごと張り
直すことで更新してみた。
infoment.hatenablog.com
今回も、前回の続きから。

動点Ｐの動きとして、くるくる回って同じ位置に戻るまでを描きたい。
そのためには、何周回るかなどを予め計算し、配列の大きさを決めて
おく必要がある。

ラベル行数

Ｘ座標、Ｙ座標など、その列に入る値が何であるかを示す行が必要だ。
これは、一行あればよい。

大きな円の描画に必要な行数

滑らかな円を描くためには、円周上にある程度の点が必要だ。例えば4点では、
正方形を少し歪めたような形となって、とても円と呼ぶことは出来ない。

色々試してみたが、36点もあれば充分だろう。

大きな円は、分割数をとするならば、行必要だ。
なぜなら始点と終点を重ねないと、円が閉じないからだ。

小さな円の描画に必要な行数

これも大きな円の行数と同じ。この範囲を次々と更新することで、円が動いて
見えるようになる。

動点Ｐの行数

文字通り「点」なので、一行あればよい。

動点Ｐの軌跡に必要な行数

折角なので、動点Ｐの軌跡を描いてみよう。
大きな円の半径：
小さな円の半径：
とするとき、その円周の始めと終わりが重なる長さは、両者の最小公倍数である。
ExcelではLCM関数で求まる。従って小さな円の周回数は、
以下の式で求めることができる。

以上のことから、奇跡を描くための行数は以下のとおり。

※半径がの約数であるならば、がどんな数でも１周だけ回る。
※半径が素数であるならば、必ず周だけ回る。

行数の合計

今迄の行数を合計すると、以下のとおり。

一覧表にすると、このようになる。

マクロの改修

以上を踏まえて、修正したマクロがこちら。

Sub ぐるぐる()

        Cells(1, 1).Resize(Rows.Count - 1, 5).Clear

    Dim π As Double
        π = WorksheetFunction.Pi
    
    Dim r(1 To 3) As Long
    ' 大きな円の半径。
        r(1) = 61
    ' 小さな円の半径。
        r(2) = 12
    ' 小さな円の中心からのオフセット量。
        r(3) = 10
    
    ' ※r(1)とr(2)の最小公倍数÷r(1) ← 小さな円を何周回すか。
    ' RoundNumberの略。
    Dim rn As Long
        rn = WorksheetFunction.Lcm(r(1), r(2)) / r(1)
    
    ' 大きな円の中心座標。
    Dim ox1 As Double
    Dim oy1 As Double
        ox1 = 0: oy1 = 0
        
    ' 円周の分割数（Division Count）
    Dim dc As Double
        dc = 54
    
    ' 大きい円と小さい円を分割する角度（rad）。
    Dim dθ(1 To 2) As Double
        dθ(1) = 2 * π / dc
        dθ(2) = -r(1) / r(2) * dθ(1)
    
    ' 全描画に必要なグラフの行数。
    ' ※大きな円の描画に必要な点　dc+1 ←始点と終点を重ねないと円が閉じない。
    ' ※小さな円の描画に必要な点と動点Ｐの軌跡描画に必要な点の数は等しい。
    Dim iMax As Long
        iMax = (dc + 1) * 2 + (dc * rn + 1) + 1
               
    Dim myChart As ChartObject
    Set myChart = ActiveSheet.ChartObjects(1)
        myChart.Chart.SetSourceData Source:=Cells(1, 1).Resize(iMax + 1, 5)
               
    ' 各座標を格納するための配列。
    ' 一次元を０始まりにするのは、ラベル名を格納するため。
    Dim arr() As Variant
    ReDim arr(iMax, 1 To 5)
        arr(0, 1) = "X"
        arr(0, 2) = "Y1"
        arr(0, 3) = "Y2"
        arr(0, 4) = "Y3"
        arr(0, 5) = "Y4"
    
    ' 大きい円の座標。
    Dim x1() As Double: ReDim x1(1 To dc + 1)
    Dim y1() As Double: ReDim y1(1 To dc + 1)
    ' 小さい円の座標。
    Dim x2() As Double: ReDim x2(1 To dc * rn + 1)
    Dim y2() As Double: ReDim y2(1 To dc * rn + 1)
    ' 小さい円の中心。
    Dim ox2() As Double: ReDim ox2(1 To dc * rn + 1)
    Dim oy2() As Double: ReDim oy2(1 To dc * rn + 1)
    ' 小さい円の中心からr(3)オフセットしたポイント。
    Dim x3() As Double: ReDim x3(1 To dc * rn + 1)
    Dim y3() As Double: ReDim y3(1 To dc * rn + 1)
        
    Dim i As Long
    Dim j As Long
    Dim k As Long
    
        ' 大きな円の描画。
        For i = 1 To dc + 1
            x1(i) = r(1) * Cos(dθ(1) * (i - 1))
            y1(i) = r(1) * Sin(dθ(1) * (i - 1))
            arr(i, 1) = x1(i)
            arr(i, 2) = y1(i)
        Next
    
        ' 続けて描画するため、iの最終値を保存。
    Dim LastIndex As Long
        LastIndex = i
        
        For i = 1 To dc * rn + 1
            ' 小さな円の中心。
            ox2(i) = r(1) * Cos(dθ(1) * (i - 1)) * (r(1) - r(2)) / r(1)
            oy2(i) = r(1) * Sin(dθ(1) * (i - 1)) * (r(1) - r(2)) / r(1)

            Application.Wait [Now() + "00:00:00.03"]
            DoEvents
            
            ' 小さい円を描画。
            For j = 1 To dc + 1
                x2(i) = ox2(i) + r(2) * Cos(dθ(1) * (j - 1))
                y2(i) = oy2(i) + r(2) * Sin(dθ(1) * (j - 1))
                arr(LastIndex + j - 1, 1) = x2(i)
                arr(LastIndex + j - 1, 3) = y2(i)
            Next
            
            ' 中心からオフセットしたポイント。
            x3(i) = ox2(i) + r(3) * Cos(dθ(2) * (i - 1))
            y3(i) = oy2(i) + r(3) * Sin(dθ(2) * (i - 1))
            arr(LastIndex + j - 1, 1) = x3(i)
            arr(LastIndex + j - 1, 4) = y3(i)
            
            arr(LastIndex + j + k, 1) = x3(i)
            arr(LastIndex + j + k, 5) = y3(i)
            k = k + 1
            
            Cells(1, 1).Resize(iMax, 5) = arr
        Next

End Sub

実際に動かした結果がこちら。

ようやく、形になってきた。
次回に続きます。

参考まで。