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

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

今日は、このトーナメント表に人を充てる順番を求めてみる。
f:id:Infoment:20191016193819p:plain

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

  • 2の1乗 参加選手は2人 1回戦まで
  • 2の2乗 参加選手は4人 2回戦まで
  • 2の3乗 参加選手は8人 3回戦まで

のような感じだ。

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

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

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

  • 2人の場合 シード無し
  • 4人の場合 2の0乗で1人。つまり前回優勝者のみ。
  • 8人の場合 2の1乗で2人まで。
  • 16人の場合2の2乗で4人まで。

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

  1. 一番上が1番、一番下が2番。これは常に固定(両名は必ず決勝で戦う)。
  2. 1番の相手は8番。2番の相手は7番。それぞれの和は9になる。つまり、2のn乗+1になる。

f:id:Infoment:20191016211436p:plain

16名の場合、3番と4番を背中合わせに配置する。すると、このようになる。
f:id:Infoment:20191016211635p:plain

32名の場合、これが更に倍になる。
f:id:Infoment:20191016211813p:plain

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

Sub Sample()

    Cells.Clear
    
    ' トーナメント参加者リスト。
    ' ※シート1のなんちゃって個人情報を参照。
    ' ※今回は、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
    
        ' 1回戦~準決勝戦まで。
        For j = 1 To iMax
            ' j回戦の一人一人について。
            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

結果の一部がこちら。
f:id:Infoment:20191016231524p:plain

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

参考まで。