マインクラフト:メンガーのスポンジをコマンドで作成

最近、子供と一緒にマインクラフトで遊んでいる。
先日、メンガーのスポンジを作るコマンドを作ってみたので、備忘録がてら紹介。
ja.wikipedia.org

  • X軸(よこ軸)
  • Y軸(高さ軸)
  • Z軸(たて軸)

とするとき、まず起点となるブロックを一つ置いてみる。
↓ 3×3×3の立方体の一段目。

この000(相対座標)のブロックを、適切な箇所にコピーしていく。
白抜きの箇所が、コピーしてはいけない箇所。

↓二段目(白抜きの箇所はコピー不可)。

↓三段目(白抜きの箇所はコピー不可)。

結果、このような基本形が出来上がる。

これを一つのブロックと見立てて、どうようにコピーを繰り返すことでフラクタル図形ができていく。

ところでこの「コピーする/しない」、何か法則を見つけて自動化できないか。
試しに表にしてみた。

・・・法則が見つけられない。ということで、試しに全部1引いてみた。すると、0の数が2以上のときにコピー不可であることが分かった。
※恐らくは、すでに広く一般的に知られている法則と思われる。

ここまでわかれば、あとはコマンド化するだけだ。というわけで作ってみた。

count_zeros = 0
def check_zeros(a: number, b: number, c: number):
    global count_zeros
    count_zeros = 0
    if a == 0:
        count_zeros += 1
    if b == 0:
        count_zeros += 1
    if c == 0:
        count_zeros += 1
    return count_zeros <= 1

def on_on_chat(origin_x, origin_y, origin_z):
    blocks.place(PLANKS_ACACIA, world(origin_x, origin_y, origin_z))
    for n in range(5):
        for index_x in range(3):
            for index_y in range(3):
                for index_z in range(3):
                    if check_zeros(index_x - 1, index_y - 1, index_z - 1):
                        blocks.clone(world(origin_x, origin_y, origin_z),
                            world(origin_x + 3 ** n - 1,
                                origin_y + 3 ** n - 1,
                                origin_z + 3 ** n - 1),
                            world(origin_x + index_x * 3 ** n,
                                origin_y + index_y * 3 ** n,
                                origin_z + index_z * 3 ** n),
                            CloneMask.REPLACE,
                            CloneMode.NORMAL)
player.on_chat("Menger_sponge", on_on_chat)

結果がこちら。

参考まで。

再びトーナメント表作成 ➈-6 特定名簿からの作成

特定名簿からのトーナメント作成ツールを、少しずつ紹介中。
本日も、昨日の続きから。

今日は、三つに分けたサブプロシージャの最後。

    Dim Sh As Worksheet
    Set Sh = ActiveSheet
        ' トーナメント作成用シートを変数にセットしてリネーム。
        Sh.Name = SheetName
        
        ' 各選手の「番号」を、辞書を利用して「人名」に置換。
        For Each r In Sh.UsedRange.Columns(1).Cells
            If r <> vbNullString Then
                r = PDict(r.Value)
            End If
        Next

        ' 配列内で、選手名が空欄であれば「不戦敗」に置き換える。これにより、
        ' 対戦相手がシード選手となる。
        For i = 1 To UBound(arr)
            If arr(i, 列名.enNo) = vbNullString Then
                arr(i, 列名.enNo) = "不戦敗"
            
            ' 形のトーナメント作成である場合、この後に続く組手トーナメント作成時に
            ' 形と同カードが発生しないよう、形の対戦組み合わせを辞書に記録する。
            ElseIf match_type = en形 Then
                If WorksheetFunction.IsOdd(i) Then
                    If arr(i, 列名.enNo) <> vbNullString And arr(i + 1, 列名.enNo) <> vbNullString Then
                        DDict(arr(i, 列名.enNo)) = arr(i + 1, 列名.enNo)
                        DDict(arr(i + 1, 列名.enNo)) = arr(i, 列名.enNo)
                    End If
                End If
            End If
        Next
        
        With DstTb
            If .ListRows.Count > 0 Then
                .DataBodyRange.Delete
            End If
            .ListRows.Add
            .DataBodyRange.Cells(1, 1).Resize(UBound(arr), UBound(arr, 2)) = arr
        End With
        
        If DuplicateTimes > 0 Then
            MsgBox SheetName & "で、二回戦までに " & DuplicateTimes & " 箇所で同所属選手対戦の恐れがあります。確認および調整をお願いします。"
        End If
        
End Sub

これで、対戦表およびトーナメント作成までの機能が完成した。

それでは次回、実際に作成されたものをみてみよう。

参考まで。

※その後、数々の仕様変更があって、いったん保留となりました。

再びトーナメント表作成 ➈-5 特定名簿からの作成

特定名簿からのトーナメント作成ツールを、少しずつ紹介中。
本日も、昨日の続きから。

昨日は「前半と後半の二回に分ける」としたが、それでも長かった。
ということで、今日は中盤のご紹介。同一サブプロシージャの途中から始まるため分り難くなっているが、最後に改めてまとめて紹介するため、今はご勘弁。

        Do
            With New VBAProject.Tournament
                ' トーナメント作成の初期設定。
                ' 前回順位の最大値を取得し、それ以降をランダムに並び替える。
                .init Tb.ListColumns(列名.enNo).DataBodyRange, True, _
                      WorksheetFunction.Max(Tb.ListColumns(列名.en前回形順位).DataBodyRange) + 1
                      
                    ' トーナメントの配列取得。
                    arr = TournamentArray(.TournamentSortedOrderArray, match_type)
                    
                    ' 同所属対戦を不可とするブロック単位で、同所属の対戦が無いかを確認する。
                    For i = 1 To UBound(arr) Step DupTrial
                        
                        ' 重複の有無は辞書で行う。そのため、ループに入るたびに辞書を空にしている。
                        Dict.RemoveAll
                        
                        For j = 0 To DupTrial - 1
                            
                            ' 一回戦においては空欄=シードが存在するため、それ以外の場合で評価している。
                            ' keyの重複を不可とする仕様を利用しているため、itemは不問。今回はTrueとした。
                            If arr(i + j, 列名.en所属) <> vbNullString Then
                                If Not Dict.Exists(arr(i + j, 列名.en所属)) Then
                                    Dict(arr(i + j, 列名.en所属)) = True
                                Else
                                    ' 重複があった場合は、重複回数をカウントアップ。
                                    DuplicateTimes = DuplicateTimes + 1
                                End If
                            End If
                        Next
                    Next
                    
                    ' 重複回数が重複許容回数を下回る場合であって、且つ組手のトーナメントを作成している場合、
                    ' 一回戦で形トーナメントと同じ選手と対戦していないかを確認。対戦している場合は再組合せ。
                    If DuplicateTimes < AllowableDuplicateTimes And match_type = en組手 Then
                        For i = 1 To UBound(arr) Step 2
                            If DDict.Exists(arr(i, 列名.enNo)) Then
                                If DDict(arr(i, 列名.enNo)) = arr(i + 1, 列名.enNo) Then
                                    ' 同じ選手と対戦している場合、重複回数を強制的に重複許容回数とすることで
                                    ' 再抽選させる。
                                    DuplicateTimes = AllowableDuplicateTimes
                                    Exit For
                                End If
                            End If
                        Next
                    End If
                    
                    ' ループ回数が最大値を超えた場合の処理。
                    If LoopCount > LoopCountMax Then
                        MsgboxResult = MsgBox("組み合わせをランダムに" & LoopCountMax & "回作成しましたが、同所属の対戦を回避できませんでした。" & vbNewLine & _
                                                         "このままの組み合わせで継続しますか?", vbYesNo, "処理継続確認")
                        If MsgboxResult = vbNo Then
                            MsgBox "処理を中断しました。"
                            Exit Sub
                        Else
                            ' 同所属の対戦があるままトーナメント作成。人の手で最終調整。
                            .CreateTournament
                            Exit Do
                        End If
                    
                    ' 重複回数が許容重複回数を下回っている場合、トーナメント作成の条件達成。
                    ' トーナメントを作成してループを抜ける。
                    ElseIf DuplicateTimes < AllowableDuplicateTimes Then
                        .CreateTournament
                        Exit Do
                    End If
            End With
            LoopCount = LoopCount + 1
            
            ' 重複回数の初期化。
            DuplicateTimes = 0
        Loop

以下の条件においては、どうしても一回戦での同一所属対戦が増えてしまう。

  1. 選手数が多く、且つ、参加団体数が少ない場合。
  2. 2^nよりもほんの少しだけ、参加人数が多い場合。

例えば2^4=16人より一人多い17人の場合について考えてみる。この場合、一回戦は1組のみで、残りの対戦はすべてシードとなる。

そのため、一回戦だけ同所属対戦を回避しても、どうしても二回戦(実質一回戦)での同一所属対戦が発生してしまう。
例)一回戦シードのため、二回戦で長野県同士で対戦となる。

これを回避すべく、昨日紹介範囲になるが、4人一組で同一部門の人がいないことを条件としてみた。

次回に続きます。

参考まで。

再びトーナメント表作成 ➈-4 特定名簿からの作成

特定名簿からのトーナメント作成ツールを、少しずつ紹介中。
本日も、先日の続きから。

本日は、トーナメントの作成部分。長いので、前半と後半で日を分けて紹介。

Sub 対戦表作成(Optional match_type As MatchType = en形)

    Call 名簿データ取得
    
    ' 形および組手の名簿は、PowerQueryで作成。
    ' 名簿テーブル。
    Dim Tb As ListObject
    ' 対戦表テーブル。
    Dim DstTb As ListObject
    ' トーナメントを作成するシート名。
    Dim SheetName As String
        Select Case match_type
            Case MatchType.en形
                Set Tb = S22_名簿_形.Tb
                Set DstTb = S24_対戦表_形.Tb
                Set DDict = New Scripting.Dictionary
                SheetName = "形トーナメント"
             Case MatchType.en組手
                Set Tb = S23_名簿_組手.Tb
                Set DstTb = S25_対戦表_組手.Tb
                SheetName = "組手トーナメント"
        End Select
    
    ' 作成済みシートの有無確認。ある場合は削除する。
    Dim Ws As Worksheet
        Application.DisplayAlerts = False
        For Each Ws In Worksheets
            If Ws.Name = SheetName Then
                Ws.Delete
                Exit For
            End If
        Next
        Application.DisplayAlerts = True
    
    ' 名簿テーブルの更新。BackgroundQueryをFalseにすることで、
    ' QueryTableの更新が終わってから次のステップに進む。
        Tb.QueryTable.Refresh BackgroundQuery:=False
    
    ' 組み合わせ表を格納するための配列。
    Dim arr As Variant
    ' 同一所属間対戦をチェックするための辞書。
    Dim Dict As Scripting.Dictionary
    Set Dict = New Scripting.Dictionary
    ' ループ用変数。
    Dim i As Long
    Dim j As Long
    ' ループカウンタ。
    Dim LoopCount As Long
    ' 重複数。形と組手で同じ人と対戦した回数。
    Dim DuplicateTimes As Long
    ' 許容重複回数。
    Dim AllowableDuplicateTimes As Long: AllowableDuplicateTimes = 2
    ' 再履行許容回数。重複などが解消できない場合、無限ループに入る恐れがある。
    ' そのため、再履行の最大値を設定しておく。
    Dim LoopCountMax As Long: LoopCountMax = 10000
    Dim MsgboxResult As VbMsgBoxResult
    Dim r As Range
    ' 同所属対戦を許容するブロックの人数。
    ' 例)2 とした場合、一回戦のみ同所属対戦不可とする。
    '    4 とした場合、二回戦まで同所属対戦不可とする。一回戦がシードの場合、
    '    二回戦まで不可としておくことで、シード戦の同所属対戦を回避できる。
    '    出場団体が少ないほど同所属対戦が起きやすくなるため、調整が必要。
    Dim DupTrial As Long: DupTrial = 4

以下の条件を如何に満足させるかが、今回苦労した点。

  1. 初戦での同門対決回避。
  2. 形と組手での同一組み合わせ回避。

結果、いくつかの辞書を作成しては中身を廃棄の繰り返しとなった。
きっと、もっとうまい方法があったに違いない。

次回に続きます。

参考まで。

再びトーナメント表作成 ➈-3 特定名簿からの作成

特定名簿からのトーナメント作成ツールを、少しずつ紹介中。
本日も、昨日の続きから。

昨日と同様の標準モジュールに、 以下を追加する。

' トーナメントの対戦順に並び替えられた配列に、その他の基本情報を付加して新たな配列を返す。
' source_array:トーナメント対戦表。
' match_type:形または組手の区分。
Function TournamentArray(source_array As Variant, match_type As MatchType) As Variant
    Dim i As Long
    ' データ格納用配列。
    Dim arr() As Variant
    ReDim arr(1 To UBound(source_array), 1 To 列名.[_eLast] - 3)
    
    ' No.は、キー情報。通し番号または各団体の登録番号などを想定。
        For i = 1 To UBound(source_array)
            arr(i, 1) = source_array(i)
            For Each p In Persons
                If source_array(i) = p.No Then
                    arr(i, 列名.en名前) = p.名前
                    arr(i, 列名.enふりがな) = p.ふりがな
                    arr(i, 列名.en性別) = p.性別
                    arr(i, 列名.en学校等区分) = p.学校等区分
                    arr(i, 列名.en学年) = p.学年
                    arr(i, 列名.en所属) = p.所属
                    Select Case match_type
                        Case MatchType.en形
                            arr(i, 列名.en形出場) = p.形出場
                            arr(i, 列名.en前回形順位) = p.前回形順位
                        Case MatchType.en組手
                            arr(i, 列名.en形出場) = p.組手出場
                            arr(i, 列名.en前回形順位) = p.前回組手順位
                    End Select
                End If
            Next
        Next
        
        TournamentArray = arr
End Function

少し短いが、しばらく毎日更新も目標の一つのため、今日はここまで。

参考まで。

再びトーナメント表作成 ➈-2 特定名簿からの作成

長らく温めてきたトーナメント作成ツールだが、一部からのリクエスト仕様に対し検討を重ね、汎用化を断念した。この辺りは、私の能力不足に尽きる。

ということで、特定名簿からの作成に特化したものを、少しずつ紹介していく。

まずは標準モジュールの、モジュールレベル変数などから。解説はすべてコメント文を参照されたし。

' 表の列番号をラベル名称で指定するためのEnum。
Public Enum 列名
    enNo = 1
    en名前
    enふりがな
    en性別
    en学校等区分
    en学年
    en所属
    en形出場
    en前回形順位
    en組手出場
    en前回組手順位
    [_eLast]
End Enum

' 形と組手の指定を引数で明示するためのEnum。
Public Enum MatchType
    en形
    en組手
End Enum

' 選手情報を格納するためのコレクション。
Public Persons As Collection
' 選手情報を格納するためのクラスモジュール。
Public p As Person
' 所属が同じ選手間での対戦をなるべく回避するための辞書。
Public PDict As Scripting.Dictionary
' 形と組手で同じ選手と対戦しないための辞書。
Public DDict As Scripting.Dictionary

次に、名簿から選手情報を取得する部分がこちら。同じく標準モジュール。

' 選手の基本情報取り込み。
Sub 名簿データ取得()
    Set Persons = New Collection
    ' トーナメント表に表示するための辞書。
    ' key情報:各選手に付された通し番号。
    ' item情報:選手名と所属名称。
    Set PDict = New Scripting.Dictionary
    Dim i As Long
        For i = 1 To S21_名簿_元データ.Tb.ListRows.Count
            With New Person
                .No = S21_名簿_元データ.Tb.ListRows(i).Range(列名.enNo)
                .名前 = S21_名簿_元データ.Tb.ListRows(i).Range(列名.en名前)
                .ふりがな = S21_名簿_元データ.Tb.ListRows(i).Range(列名.enふりがな)
                .性別 = S21_名簿_元データ.Tb.ListRows(i).Range(列名.en性別)
                .学校等区分 = S21_名簿_元データ.Tb.ListRows(i).Range(列名.en学校等区分)
                .学年 = S21_名簿_元データ.Tb.ListRows(i).Range(列名.en学年)
                .所属 = S21_名簿_元データ.Tb.ListRows(i).Range(列名.en所属)
                .形出場 = S21_名簿_元データ.Tb.ListRows(i).Range(列名.en形出場)
                .前回形順位 = S21_名簿_元データ.Tb.ListRows(i).Range(列名.en前回形順位)
                .組手出場 = S21_名簿_元データ.Tb.ListRows(i).Range(列名.en組手出場)
                .前回組手順位 = S21_名簿_元データ.Tb.ListRows(i).Range(列名.en前回組手順位)
                
                ' ↓表現は自由に変更可能。
                PDict(.No) = .名前 & "(" & .所属 & ")"
                Persons.Add .Self
            End With
        Next
End Sub

なお、昨日も紹介したシート名がこちら。

シート名を変更されても対応できるよう、オブジェクト名で指定している。
例)
シート名「名簿_元データ」ではなく、「S21_名簿_元データ」で指定。
頭のSは単純に、SheetのSの意。管理しやすいように、並んでほしい順で
21などの番号を振っている。

次いで、名簿データ取得に登場したクラスモジュール「Person」がこちら。

Public No As Variant
Public 名前 As Variant
Public ふりがな As Variant
Public 性別 As Variant
Public 学校等区分 As Variant
Public 学年 As Variant
Public 所属 As Variant
Public 形出場 As Variant
Public 前回形順位 As Variant
Public 組手出場 As Variant
Public 前回組手順位 As Variant

Public Property Get Self() As Person
    Set Self = Me
End Property

これについては、Thomさんのブログからほぼ原形で引用している。
(いつもありがとうございます)。
thom.hateblo.jp

今日はここまで。明日に続きます。

参考まで。

再びトーナメント表作成 ➈-1 特定名簿からの作成

前回は、トーナメント作成クラスモジュールを一旦完成させるところまでを紹介した。
infoment.hatenablog.com
ところがその後、トーナメント作成時の様々な制約が明らかとなって、結果これを一般化するのは至極煩雑であると感じた。そこで路線を変更して、特定名簿からの作成に特化することにした。

まず、「名簿_元データ」シートを準備した。

ここに、これらの項目を記入する。

あとは、自動でトーナメント作成までもっていく。作成するシートはこちら。

何も、すべてマクロでやる必要はない。↓ この二つは、PowerQueryで編集した。

シート名が示すように、形と組手により分けたうえで、前回の順位でソート。

これを対戦表の形に並べ替えたのがこちら。

一回戦はシードが発生する場合がある。シードの場合、相手は「不戦敗」とした。
形の場合、「形_トーナメント」シートで、トーナメントの形で確認できる。

それでは次回以降、実際のコードを紹介していくとしよう。

参考まで。