再びトーナメント表作成 ② 前大会の入賞者を良い感じに分散したい

昨日は、選手の人数からトーナメント表のサイズを求めるために、
常用対数を使ってみた。
infoment.hatenablog.com
今日は、前大会の入賞者が一回戦でぶつからないよう、良い感じに分散
させることに挑戦する。

以前トーナメント表作成マクロに挑戦した際は、

８人までの大会は組合せ決め打ち
９人以上の大会は指数関数などを用いて組合せ決定

という風に、非常に複雑なことを行っていた。しかし今回、改めて考えて
気が付いた。もっと簡単な方法があるのでは無いかと。

それは、

組合せを増やしたい場合は、既存の組合せをペロッとめくりコピーして、
片方を奇数に、片方を偶数にする

というもの。文字にすると「なんそれ！？」となるので、PowerPointで
動画を作ってみた。

これを繰り返せば、前大会の１位と２位は常に決勝戦でのみ対戦することに。
何回ペロッとめくれば良いかは、昨日求めた「トーナメントのサイズ」から
容易に求まる。例えば選手が１８人の場合、

１８人の選手が収まるトーナメントサイズは３２人である。
３２は２＾５であるから、５回ペロッとめくれば良い。

ことになる。

では、３２が２の５乗であることを求めるにはどうすればよいか。これは
LOG２関数があれば一発で求まるのだが、どうやら無いようなので、底の
変換公式で求めるとしよう。
manabitimes.jp

以上を踏まえて作成したのがこちら。

Function GetTournamentOrderArray(player_count As Long, _
                        Optional invers_flag As Boolean = False) As Variant
    
    ' 作業用配列。最終的に戻り値となる。
    Dim arr() As Variant
    ReDim arr(1 To 1)
    ' 初期値。選手が一人のとき。
        arr(1) = 1
        If player_count = 1 Then
            GetTournamentOrderArray = arr
            Exit Function
        End If
        
    ' WorksheetFunctionの表記短縮用。
    Dim Wf As WorksheetFunction
    Set Wf = WorksheetFunction
        
    ' 選手の数から求めるトーナメントサイズ。
    Dim TournamentSize As Long
        TournamentSize = 10 ^ (Wf.Ceiling_Math(Wf.Log10(player_count), Wf.Log10(2)))
    
    Dim i As Long
    Dim j As Long
    
    ' 選手の数に併せて大きくなるトーナメントの仮格納用配列。
    Dim TempArray As Variant
        ' 底の変換公式を用いて、配列を何回２倍するか求めている。
        For i = 1 To Wf.Log(TournamentSize) / Wf.Log(2)
            ReDim TempArray(1 To UBound(arr) * 2)
            For j = 1 To UBound(arr)
                ' 元の配列内の数値を、上から奇数で、下から偶数でセット。
                TempArray(j) = arr(j) * 2 - 1
                TempArray(UBound(TempArray) + 1 - j) = arr(j) * 2
            Next
            arr = TempArray
        Next
        
        ' 配列の最後を１位にしたい場合用。配列の順序をひっくり返す。
        If invers_flag Then
            For i = 1 To UBound(arr)
                arr(i) = TempArray(UBound(TempArray) - i + 1)
            Next
        End If
        
        GetTournamentOrderArray = arr

End Function

それでは早速、確認してみよう。

Sub Test()

    Dim arr As Variant
    Dim i As Long
        For i = 1 To 18
            arr = GetTournamentOrderArray(i, True)
        
            ' 貼り付けて確認。
            Cells(1, i).Resize(UBound(arr)) = WorksheetFunction.Transpose(arr)
        Next

End Sub