Excelでぷよぷよ

　テトリスを作ったらぷよぷよも。ということで、作ってみました。

　実際に作ってみると、操作性とか、プログラムに大きく依存することがわかります。面白いゲームにするにはいろいろと調整が必要そうです。
　最近はe-sportsが話題に上りますが、ソフトウェアの仕様に影響されちゃうんだろうなぁ、と思います。

　例によって、動作保証はしませんが、ソースコードはご自由にお使いください。プログラミングを勉強しているどなたかの参考にでもなれば幸いです。


----------
2020/6/13 : Version 1
2020/7/24 : ちょっとだけオリジナリティを出すため、周期的境界条件にしてみました

----------

Option Explicit

'--------------------------------------------------
'                   APIの宣言
'--------------------------------------------------
'DWORD timeGetTime( VOID);
Public Declare PtrSafe Function timeGetTime Lib "WINMM.DLL" () As Long

'SHORT GetAsyncKeyState( int vKey);
Public Declare PtrSafe Function GetAsyncKeyState Lib "user32.dll" (ByVal vKey As Long) As Long
Public Const VK_ENTER As Integer = 13
Public Const VK_ESC As Integer = 27
Public Const VK_SPACE As Integer = 32
Public Const VK_LEFT As Integer = 37
Public Const VK_UP As Integer = 38
Public Const VK_RIGHT As Integer = 39
Public Const VK_DOWN As Integer = 40

'VOID Sleep( DWORD dwMilliseconds);
Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

'BOOL sndPlaySound( LPCSTR lpszSound, UINT fuSound);
Public Declare PtrSafe Function sndPlaySound Lib "WINMM.DLL" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long
Public Const SND_SYNC = &H0
Public Const SND_ASYNC = &H1
Public Const SND_NODEFAULT = &H2
Public Const SND_LOOP = &H8
Public Const SND_NOSTOP = &H10
'--------------------------------------------------

Private key(5) As Byte  'キー入力を保存するバッファ
Private key_enable(5) As Boolean

Private Const width As Long = 6
Private Const height As Long = 12
Private Const speed As Long = 4     'Game Speed (speed x 100 msec毎にブロックが落下)

Private block(width * height - 1) As Byte
Private remove(width * height - 1) As Byte

Private next_id(1) As Byte

Private drop_id(1) As Byte
Private drop_x(1) As Byte
Private drop_y(1) As Byte

Private mode As Long
Private counter As Long

Public Sub puyo()
    Dim timeNext As Long
    Dim loopFlag As Boolean
   
    timeNext = timeGetTime
    loopFlag = True
   
    Call init
   
    '----- メインループ -----
    Do While loopFlag = True
        If timeNext < timeGetTime Then
            If mode = 1 Then
                Call run1
            ElseIf mode = 2 Then
                Call run2
            ElseIf mode = 3 Then
                Call run3
            End If
           
            Call draw
           
            '----- ESC Keyで終了 -----
            If GetAsyncKeyState(VK_ESC) <> 0 Or mode = -1 Then
                loopFlag = False
            End If
           
            If GetAsyncKeyState(VK_LEFT) <> 0 Then
                Call key_on(0)
            Else
                Call key_off(0)
            End If
   
            If GetAsyncKeyState(VK_UP) <> 0 Then
                Call key_on(1)
            Else
                Call key_off(1)
            End If
   
            If GetAsyncKeyState(VK_RIGHT) <> 0 Then
                Call key_on(2)
            Else
                Call key_off(2)
            End If
   
            If GetAsyncKeyState(VK_DOWN) <> 0 Then
                Call key_on(3)
            Else
                Call key_off(3)
            End If
           
            '-------------------------
            timeNext = timeNext + 100
        End If
       
        '-------------------------
        Sheet1.Cells(1, 1).Select
        DoEvents
    Loop
    '------------------------
End Sub

Private Sub key_on(id As Long)
    key(id) = key(id) + 1
   
    If 4 < key(id) Then
        key(id) = 4
        key_enable(id) = True
    End If
End Sub

Private Sub key_off(id As Long)
    key(id) = 0
    key_enable(id) = True
End Sub

'初期化
Private Sub init()
    Dim i As Long
   
    Sheet1.Cells.Delete
   
    '------------------------
    '行の高さ、列の幅を調整
    For i = 0 To height - 1
        Sheet1.Rows(i + 1).RowHeight = 13.5
    Next i
   
    For i = 0 To width - 1 + 1
        Sheet1.Columns(i + 1).ColumnWidth = 2.095
    Next i
   
    '------------------------
    For i = 0 To width * height - 1
        block(i) = 0
    Next i
   
    '------------------------
    key(0) = 0
    key(1) = 0
    key(2) = 0
    key(3) = 0
   
    key_enable(0) = True
    key_enable(1) = True
    key_enable(2) = True
    key_enable(3) = True
    '------------------------
    Call create
    Call create
   
    mode = 1
    counter = 0
End Sub

Private Sub create()
    drop_id(0) = next_id(0)
    drop_id(1) = next_id(1)
   
    next_id(0) = Int(5 * Rnd() + 1)
    next_id(1) = Int(5 * Rnd() + 1)
   
    drop_x(0) = width / 2
    drop_y(0) = height - 2
    drop_x(1) = width / 2
    drop_y(1) = height - 1
End Sub

Private Sub run1()
    Dim i As Long
    Dim temp_x(1) As Long
    Dim temp_y(1) As Long
   
    'キー入力
    Call run_key
   
    If 0 < counter Then
        counter = (counter + 1) Mod speed
        Exit Sub
    End If
   
    '落下処理
    For i = 0 To 1
        temp_x(i) = CLng(drop_x(i))
        temp_y(i) = CLng(drop_y(i) - 1)
    Next i
   
    If move(temp_x, temp_y) = True Then
        counter = 1
        Exit Sub
    End If
   
    '落下できないとき
    For i = 0 To 1
        block(drop_y(i) * width + drop_x(i)) = drop_id(i)
    Next i
   
    mode = 2
    counter = height
End Sub

Private Sub run2()
    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim id As Byte

    If counter = height Then
        counter = 1
        Exit Sub
    End If
   
    '------------------------
    'ブロックの落下
    For i = 0 To width - 1
        For j = 0 To height - 2
            If block(j * width + i) = 0 And 0 < block((j + 1) * width + i) Then
                For k = j To height - 2
                    block(k * width + i) = block((k + 1) * width + i)
                Next k
               
                counter = 0
                block((height - 1) * width + i) = 0
                j = j - 1
            End If
        Next j
    Next i
   
    If counter = 0 Then
        counter = 1
        Exit Sub
    End If
   
    '------------------------
    'ブロックのつながりを数える
    For i = 0 To height - 1
        For j = 0 To width - 1
            remove(i * width + j) = 0
        Next j
    Next i
   
    For i = 0 To height - 1
        For j = 0 To width - 1
            counter = 0
            id = block(i * width + j) Mod 8
            Call count(j, i, id)
            Call note(j, i, id)
           
            'ブロックのつながりを表示
            'Sheet1.Cells(2 * height + 4 - i, 1 + j) = remove(i * width + j)
        Next j
    Next i
   
    counter = 1
   
    '------------------------
    '消去処理
    For i = 0 To height - 1
        For j = 0 To width - 1
            If 0 < block(i * width + j) And 3 < remove(i * width + j) Then
                block(i * width + j) = 0
                counter = 0
            End If
        Next j
    Next i
   
    If counter = 0 Then
        counter = height
        Exit Sub
    End If
   
    'Game Overの確認
    If block((height - 2) * width + width / 2) <> 0 Then
        mode = 3
        counter = height
        Exit Sub
    End If

    Call create
    mode = 1
    counter = 0
End Sub

Private Sub count(x As Long, y As Long, id As Byte)
    If (block(y * width + x) And 8) = 0 And block(y * width + x) Mod 8 = id And remove(y * width + x) = 0 Then
        counter = counter + 1
        block(y * width + x) = block(y * width + x) + 8 '数え中の印をつける

        If 0 < x Then Call count(x - 1, y, id)
        If 0 < y Then Call count(x, y - 1, id)
        If x < width - 1 Then Call count(x + 1, y, id)
        If y < height - 1 Then Call count(x, y + 1, id)
    End If
End Sub

Private Sub note(x As Long, y As Long, id As Byte)
    If 0 < (block(y * width + x) And 8) And block(y * width + x) Mod 8 = id Then
        remove(y * width + x) = counter
        block(y * width + x) = block(y * width + x) - 8 '数え中の印を消す

        If 0 < x Then Call note(x - 1, y, id)
        If 0 < y Then Call note(x, y - 1, id)
        If x < width - 1 Then Call note(x + 1, y, id)
        If y < height - 1 Then Call note(x, y + 1, id)
    End If
End Sub

Private Sub run3()
    Dim i As Long
    Dim j As Long

    If 0 < counter Then
        For i = 0 To height - 2
            For j = 0 To width - 1
                block(i * width + j) = block((i + 1) * width + j)
            Next j
        Next i
       
        For j = 0 To width - 1
            block((height - 1) * width + j) = 0
        Next j
       
        counter = counter - 1
        Exit Sub
    End If

    mode = -1
End Sub

Private Sub run_key()
    Dim i As Long
    Dim temp_x(1) As Long
    Dim temp_y(1) As Long
   
    '---------- left ----------
    If 0 < key(0) And key_enable(0) = True Then
        key_enable(0) = False
       
        For i = 0 To 1
            temp_x(i) = (CLng(drop_x(i)) - 1 + width) Mod width
            temp_y(i) = CLng(drop_y(i))
        Next i
       
        Call move(temp_x, temp_y)
    End If
   
    '---------- up ----------
    If 0 < key(1) And key_enable(1) = True Then
        key_enable(1) = False
       
        For i = 0 To 1
            'temp_x(i) = CLng(drop_x(0)) + drop_y(i) - drop_y(0)
            'temp_y(i) = CLng(drop_y(0)) - drop_x(i) + drop_x(0)
           
            temp_x(i) = (CLng(drop_x(0)) - drop_y(i) + drop_y(0) + width) Mod width
           
            temp_y(i) = CLng(drop_x(i)) - drop_x(0)
           
            '周期的境界条件の、周期にまたがっている場合
            If Math.Abs(CLng(drop_x(i)) - width - drop_x(0)) < Math.Abs(temp_y(i)) Then
                temp_y(i) = CLng(drop_x(i)) - width - drop_x(0)
            End If
           
            If Math.Abs(CLng(drop_x(i)) + width - drop_x(0)) < Math.Abs(temp_y(i)) Then
                temp_y(i) = CLng(drop_x(i)) + width - drop_x(0)
            End If
           
            temp_y(i) = CLng(drop_y(0)) + temp_y(i)
        Next i
       
        Call move(temp_x, temp_y)
    End If
   
    '---------- right ----------
    If 0 < key(2) And key_enable(2) = True Then
        key_enable(2) = False
       
        For i = 0 To 1
            temp_x(i) = (CLng(drop_x(i)) + 1) Mod width
            temp_y(i) = CLng(drop_y(i))
        Next i
       
        Call move(temp_x, temp_y)
    End If
   
    '---------- down ----------
    If 0 < key(3) And key_enable(3) = True Then
        key_enable(3) = False
       
        For i = 0 To 1
            temp_x(i) = CLng(drop_x(i))
            temp_y(i) = CLng(drop_y(i)) - 1
        Next i
       
        Call move(temp_x, temp_y)
    End If
End Sub

Private Function move(temp_x() As Long, temp_y() As Long) As Boolean
    Dim i As Long
    Dim flag As Boolean
   
    flag = True
   
    For i = 0 To 1
        If temp_x(i) < 0 Or width - 1 < temp_x(i) Then
            flag = False
            Exit For
        End If
       
        If temp_y(i) < 0 Or height - 1 < temp_y(i) Then
            flag = False
            Exit For
        End If
       
        If block(temp_y(i) * width + temp_x(i)) <> 0 Then
            flag = False
            Exit For
        End If
    Next i
   
    If flag = True Then
        For i = 0 To 1
            drop_x(i) = CByte(temp_x(i))
            drop_y(i) = CByte(temp_y(i))
        Next i
    End If
   
    move = flag
End Function

Private Sub draw()
    Dim i As Long
    Dim j As Long
    Dim temp() As Byte
   
    '------------------------
    ReDim temp(width * height - 1) As Byte
   
    For i = 0 To height - 1
        For j = 0 To width - 1
            If 0 < (block(i * width + j) Mod 8) Then
                temp(i * width + j) = 96 + block(i * width + j) Mod 8
            Else
                temp(i * width + j) = 32
            End If
        Next j
    Next i
   
    If mode = 1 Then
        For i = 0 To 1
            temp(drop_y(i) * width + drop_x(i)) = 96 + drop_id(i)
        Next i
    End If
   
    For i = 0 To height - 1
        For j = 0 To width - 1
            Sheet1.Cells(height - i, j + 1) = Chr(temp(i * width + j))
        Next j
    Next i
   
    '------------------------
    Sheet1.Cells(2, width + 1) = Chr(96 + next_id(0))
    Sheet1.Cells(1, width + 1) = Chr(96 + next_id(1))
End Sub