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

先日から、トーナメント表の作成に取り組んでいる。数回前は、
前大会の入賞者を良い感じに分散させて、例えば前回の1位と2位が
一回戦で対戦しないよう工夫してみた。
infoment.hatenablog.com
この中で重大な考慮漏れがあったため、今回はそれを修正する。

例えば31人でトーナメントを作成する場合。今回の考え方では、架空の32人目も
加えてトーナメント表を作成し、32人目と対戦する人を不戦勝にする（=シード）
こととしていた。

しかし前回作成した関数では、1位と32位は対戦しない。そこも含めて、均等に
分散されてしまうからだ。

そこで、良い感じに分散したのちに、改めて1位と32位が、2位と31位が、3位と
30位が、・・・n位と32-n+1位が対戦するよう修正してみた。

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
        
        ' 上位半数の相手を改めてセット。
        ' 例えば32人のトーナメントでは、1と32が、2と31が、3と30が・・・nと33-nが
        ' ペアになるようにする。※優先的に前回上位者を一回戦シードとするため。
        For i = 1 To TournamentSize
            If arr(i) > TournamentSize / 2 Then
                ' ４人一組で評価するとき、２番目は１番目と、３番目は４番目と
                ' ペアになることから、４で割った余りで処理を変更する。
                Select Case i Mod 4
                    Case 2: arr(i) = TournamentSize - arr(i - 1) + 1
                    Case 3: arr(i) = TournamentSize - arr(i + 1) + 1
                End Select
            End If
        Next
        TempArray = arr
        
        ' 配列の最後を１位にしたい場合用。配列の順序をひっくり返す。
        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

結果がこちら。

今度こそ、前大会の上位者から優先的にシードされるようになった。
危ない、危ない。次回に続きます。

参考まで。