トーナメント作成 ④ 前回の上位者をシード選手に
昨日は、トーナメントの箱だけを取り敢えず作成した。
infoment.hatenablog.com
今日は、このトーナメント表に人を充てる順番を求めてみる。
トーナメント表において、一回戦がピッタリ埋まるのは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番、一番下が2番。これは常に固定(両名は必ず決勝で戦う)。
- 1番の相手は8番。2番の相手は7番。それぞれの和は9になる。つまり、2のn乗+1になる。
16名の場合、3番と4番を背中合わせに配置する。すると、このようになる。
32名の場合、これが更に倍になる。
ということで、半分に割って真ん中に背中合わせで番号を配置してみた。
※現時点で、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
結果の一部がこちら。
今日一日で、私の頭は3回ほど破裂しました。
明日に続きます。
参考まで。