有限逆コラッツ展開

説明下手なので、VBAで作ってみました。

使い方：ExcelVBAの標準モジュールにそのままコピペします。
奇数の入ったセルを1個選択した状態でマクロを実行するだけです。

結果：コラッツ予想の操作をすると選択した奇数になる奇数をすべて列挙していきます。
ただし、最初の数以下に限定しているのでかならず有限になります。

問題：このような操作において、最初の奇数を6k-1としたときに得られるすべての奇数の数(操作回数ゼロのときはゼロとして数えます)をp(k)とおくと

p(k + 3 ^ p(k) ) = p(k)

が成立するのか。

といった問題を考えています。

Sub LRCollatzExtend()

Dim pcount As Long

Dim flag As Long
Dim gq As Long
Dim p As Variant
Dim limitNum As Long
Dim val As Variant
Dim count As Integer
Dim arr1() As Variant
Dim arr2() As Variant
Dim arr3() As Variant



'選択範囲を取得
Set Rng = Selection


For Each cell In Rng.Cells
limitNum = cell.Value
count = 0
pcount = 0
flag = 1

ReDim arr1(0)
ReDim arr2(0)
ReDim arr3(0)

arr1(0) = "初週"

Do While Not flag = 0


    flag = 0
    
    
    If arr1(0) = "初週" Then
        p = cell.Value
        arr1(0) = p
    
    End If
    
    
    
    For Each p In arr1
                
        If IsNumeric(p) Then
            If Not p Mod 2 = 0 Then '値が偶数の場合を除外
            
                ReDim Preserve arr2(UBound(arr2) + 1)
                arr2(UBound(arr2)) = "---↓" & p & "の計算結果↓---"

            
                gq = p Mod 3   '偶奇の判定式 0→３倍数,1→nは奇数,2→nは偶数
            
            
                If gq = 0 Then
            
                    val = p & "(三)"
            
                    ReDim Preserve arr2(UBound(arr2) + 1)
                    arr2(UBound(arr2)) = val
                
                ElseIf gq = 1 Or gq = 2 Then   '主計算
                    i = 2 - gq
                    val = 0
                        
                    Do While Not val Like "*超*"
                        
                        val = ((gq * p * (4 ^ i)) - 1) / 3

                        i = i + 1
                    
                                                    
                        If limitNum > val Then
                                                
                            flag = 1
                            pcount = pcount + 1
                        
                        Else
                    
                            val = val & "(超過)"
                        
                        End If
                                    
                        ReDim Preserve arr2(UBound(arr2) + 1)
                        arr2(UBound(arr2)) = val
                
                    Loop

    
                End If
            End If
        End If
    
    Next p
    
    
   ReDim arr3(0)
    
    i = 0
    Do While i < UBound(arr1)
        ReDim Preserve arr3(i)
        arr3(i) = arr1(i)
        i = i + 1
    Loop
    
   ReDim arr1(0)
            
    
    i = 0
    Do While i < UBound(arr2) + 1
        ReDim Preserve arr1(i)
        arr1(i) = arr2(i)
        i = i + 1
    Loop
    
    ReDim arr2(0)
            
    count = count + 1
    
    '全ルート書き出し
    i = 0
    For Each j In arr1
        With cell.Offset(i, count)
            If IsNumeric(j) Then
                .Font.Color = RGB(0, 0, 0)
            ElseIf j Like "---*" Then
                .Font.Color = RGB(0, 255, 0)
            Else
                .Font.Color = RGB(255, 0, 0)
            End If
                If IsEmpty(j) Then
                    .Value = count
                Else
                    .Value = j
                End If
                i = i + 1
        End With
    
    Next j


    
Loop


cell.Offset(2, 0).Value = "最多操作："
cell.Offset(3, 0).Value = count - 1        '最も遠い値まで要する操作回数
cell.Offset(4, 0).Value = "全要素数："
cell.Offset(5, 0).Value = pcount        '全要素数

cell.Offset(7, 0).Value = "【計算停止条件】"
cell.Offset(8, 0).Value = "・（超過）＝最初の値を超過した場合は数えません"
cell.Offset(9, 0).Value = "・（三）＝三の倍数からは奇数が出ません"

Next cell

End Sub