トーナメント作成 ④ 前回の上位者をシード選手に

昨日は、トーナメントの箱だけを取り敢えず作成した。
infoment.hatenablog.com

今日は、このトーナメント表に人を充てる順番を求めてみる。

トーナメント表において、一回戦がピッタリ埋まるのは２のｎ乗の場合。

• ２の１乗　参加選手は２人　１回戦まで
• ２の２乗　参加選手は４人　２回戦まで
• ２の３乗　参加選手は８人　３回戦まで

のような感じだ。

しかし参加者が常にピッタリのはずもなく、必ず一回戦で戦わない人が出てくる（＝シード選手）。

このシード選手をどう決めるか、色々な考え方があるが、今回は「前回の上位者は優先的にシード選手になる」モードを設けて配置してみようと思う。

そもそも、上位者とはどこからなのか。これも色々と考え方があるだろう。ここでは勝手ながら、ｎ回戦までのトーナメントに於いては、「２の（ｎ－２）乗」人までとしてみよう（※完全なる個人の感覚です）。

• ２人の場合　シード無し
• ４人の場合　２の０乗で１人。つまり前回優勝者のみ。
• ８人の場合　２の１乗で２人まで。
• １６人の場合２の２乗で４人まで。

とりあえず８名の場合を例に、このように考えてみた。
２名がシードであるなら、最初に埋める２マスを決定し、その対となる２マスの埋まる優先順位を最後にすればよい。例えば、こんな感じか。

1. 一番上が１番、一番下が２番。これは常に固定（両名は必ず決勝で戦う）。
2. １番の相手は８番。２番の相手は７番。それぞれの和は９になる。つまり、２のｎ乗＋１になる。

１６名の場合、３番と４番を背中合わせに配置する。すると、このようになる。

３２名の場合、これが更に倍になる。

ということで、半分に割って真ん中に背中合わせで番号を配置してみた。
※現時点で、６５人以上のトーナメント未対応。

Sub Sample()

    Cells.Clear
    
    ' トーナメント参加者リスト。
    ' ※シート１のなんちゃって個人情報を参照。
    ' ※今回は、50人決め打ち。
    Dim arr() As Variant
        arr = Sheet1.Range("B2:B51").Value
    
    ' 参加者人数から、トーナメントが何回戦まで必要かを求める。
    Dim iMax As Long
        iMax = WorksheetFunction.RoundUp(WorksheetFunction.Log(UBound(arr), 2), 0)
    Dim i As Long
    Dim j As Long
    
        ' １回戦～準決勝戦まで。
        For j = 1 To iMax
            ' ｊ回戦の一人一人について。
            For i = 1 To (2 ^ iMax) / (2 ^ (j - 1))
                With Cells((2 * i - 1) * 2 ^ (j - 1), 3 * j - 2)
                    Select Case j
                        ' 横の罫線だけ、先に描画しておく。
                        ' ※セル結合により、人名入力セル内は罫線が無くなる。
                        Case 1
                            .Resize(, 2).Borders(xlEdgeBottom).Weight = xlThin
                        Case Else
                            .Resize(, 3).Offset(, -1).Borders(xlEdgeBottom).Weight = xlThin
                    End Select
                    .Resize(2).Merge
                    .Resize(2).Borders.Weight = xlThin
                End With
            Next
        Next
    
        ' 決勝戦。
        With Cells(2 ^ iMax, 3 * j - 2)
            .Resize(, 2).Offset(, -1).Borders(xlEdgeBottom).Weight = xlThin
            .Resize(2).Merge
            .Resize(2).Borders.Weight = xlThin
        End With
        
        ' 縦の線。
        For j = 1 To iMax
            For i = 1 To 2 ^ (iMax - j)
                Cells((2 ^ (j + 1)) * i - (3 * 2 ^ (j - 1) - 1), 3 * j - 1).Resize(2 ^ j).Borders(xlEdgeRight).Weight = xlThin
            Next
        Next
        
        
        ' 境界線のセット。
        If iMax >= 4 Then
            Dim SetArrayBoundary() As Variant
            ReDim SetArrayBoundary(1 To 2 ^ (iMax - 3) - 1)
                For i = 1 To UBound(SetArrayBoundary)
                    Select Case i
                        Case 1
                            SetArrayBoundary(i) = (2 ^ iMax) / 2
                        Case Is <= 3
                            SetArrayBoundary(i) = (2 ^ iMax) / 4 * (2 * i - 3)
                        Case Is <= 7
                            SetArrayBoundary(i) = (2 ^ iMax) / 8 * (2 * i - 7)
                    End Select
                Next
        End If
        
        ' 取り敢えず番号をセット。
        ' 実際は、人の名前をセットしていく（今回は、その前段）
    Dim Counter As Long: Counter = 3
        Cells(1, 1) = 1
        Cells(3, 1) = 2 ^ iMax
        Cells(2 * (2 ^ iMax) - 3, 1) = 2 ^ iMax - 1
        Cells(2 * (2 ^ iMax) - 1, 1) = 2
        
        If iMax >= 4 Then
            For i = 1 To UBound(SetArrayBoundary)
                Cells(2 * SetArrayBoundary(i) - 3, 1) = 2 ^ iMax + 1 - Counter
                Cells(2 * SetArrayBoundary(i) - 1, 1) = Counter
                Cells(2 * SetArrayBoundary(i) + 1, 1) = Counter + 1
                Cells(2 * SetArrayBoundary(i) + 3, 1) = 2 ^ iMax - Counter
                Counter = Counter + 2
            Next
        End If
End Sub

結果の一部がこちら。

今日一日で、私の頭は３回ほど破裂しました。
明日に続きます。

参考まで。