前回作ったテトリスは、非常にシンプルな作りでした。それじゃ味気ないので、少しアニメーションとかをつけてみました。
キー入力もバッファを使ってます。バッファを使わないと、一度で2回キー入力処理がされているみたいになることがあります。こういったハードウェアに近いところの処理は奥が深いなぁと思います。
例によって、動作保証はしませんが、ソースコードはご自由にお使いください。
----------
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
'--------------------------------------------------
'---------- キー入力の注意事項 ----------
'_______kkk______kkk_____ (k : キーが押されているタイミング)
'_____p_____p_____p_____p (p : キー処理のタイミング (2,3番目のpだけ処理されるようにしたい))
'キー処理とキー処理の間でキーが押されてもキー処理されるようにキー入力を保存する
'(今回のプログラムでは、キー処理とGetAsyncKeyState関数が同じタイミングなので、回数に意味はない)
'1回のキー入力を2回と誤判定しないように、キー処理終了後から次のGetAsyncKeyState関数まではキー処理を無効にする
'本当はGetAsyncKeyState関数の戻り値で、"キーが押されているか"と"それまでにキーが押されたか"が分かるらしい。。。
'----------------------------------------
Private key(5) As Byte 'キー入力を保存するバッファ
Private key_enable(5) As Boolean
Private Const width As Long = 10
Private Const height As Long = 20
Private Const speed As Long = 4 'Game Speed (speed x 100 msec毎にブロックが落下)
Private block(width * height - 1) As Byte
Private remove(height - 1) As Byte
Private next_id As Byte
Private next_x(3) As Byte
Private next_y(3) As Byte
Private drop_id As Byte
Private drop_x(3) As Byte
Private drop_y(3) As Byte
Private mode As Long
Private counter As Long
Public Sub Tetris()
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 + 3
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()
Dim i As Long
'------------------------
drop_id = next_id
For i = 0 To 3
drop_x(i) = next_x(i)
drop_y(i) = next_y(i)
Next i
'------------------------
next_id = Int(7 * Rnd() + 1)
For i = 0 To 3
next_x(i) = width / 2
next_y(i) = height - 2
Next i
'I, O, S, Z, J, L, T
If next_id = 1 Then
'----- I -----
next_y(1) = next_y(1) + 1
next_y(2) = next_y(2) - 1
next_y(3) = next_y(3) - 2
ElseIf next_id = 2 Then
'----- O -----
next_x(1) = next_x(1) + 1
next_y(2) = next_y(2) + 1
next_x(3) = next_x(3) + 1
next_y(3) = next_y(3) + 1
ElseIf next_id = 3 Then
'----- S -----
next_x(1) = next_x(1) - 1
next_y(2) = next_y(2) + 1
next_x(3) = next_x(3) + 1
next_y(3) = next_y(3) + 1
ElseIf next_id = 4 Then
'----- Z -----
next_x(1) = next_x(1) - 1
next_y(1) = next_y(1) + 1
next_y(2) = next_y(2) + 1
next_x(3) = next_x(3) + 1
ElseIf next_id = 5 Then
'----- J -----
next_x(1) = next_x(1) - 1
next_x(2) = next_x(2) + 1
next_x(3) = next_x(3) - 1
next_y(3) = next_y(3) + 1
ElseIf next_id = 6 Then
'----- L -----
next_x(1) = next_x(1) - 1
next_x(2) = next_x(2) + 1
next_x(3) = next_x(3) + 1
next_y(3) = next_y(3) + 1
ElseIf next_id = 7 Then
'----- T -----
next_x(1) = next_x(1) - 1
next_x(2) = next_x(2) + 1
next_y(3) = next_y(3) + 1
End If
End Sub
Private Sub run1()
Dim i As Long
Dim temp_x(3) As Long
Dim temp_y(3) As Long
'キー入力
Call run_key
If 0 < counter Then
counter = (counter + 1) Mod speed
Exit Sub
End If
'落下処理
For i = 0 To 3
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 3
block(drop_y(i) * width + drop_x(i)) = drop_id
Next i
mode = 2
counter = width / 2
End Sub
Private Sub run2()
Dim i As Long
Dim j As Long
Dim k As Long
'消去する行に印をつける
If counter = width / 2 Then
counter = 0
For i = 0 To height - 1
remove(i) = 0
For j = 0 To width - 1
If block(i * width + j) = 0 Then
Exit For
End If
Next j
If j = width Then
remove(i) = 1
counter = width / 2
End If
Next i
End If
'ブロック消去のアニメーション
If 0 < counter Then
For i = 0 To height - 1
If remove(i) = 1 Then
block(i * width + counter - 1) = 0
block(i * width + width - counter) = 0
End If
Next i
counter = counter - 1
Exit Sub
End If
'消去処理
For i = 0 To height - 1
If remove(i) = 1 Then
'------------------------
For k = 0 To height - 2
remove(k) = remove(k + 1)
Next k
remove(height - 1) = 0
'------------------------
For j = 0 To width - 1
For k = i To height - 2
block(k * width + j) = block((k + 1) * width + j)
Next k
block((height - 1) * width + j) = 0
Next j
i = i - 1
End If
Next i
'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 run3()
Dim i As Long
If 0 < counter Then
For i = 0 To width - 1
block((height - counter) * width + i) = Int(7 * Rnd() + 1)
Next i
counter = counter - 1
Exit Sub
End If
mode = -1
End Sub
Private Sub run_key()
Dim i As Long
Dim temp_x(3) As Long
Dim temp_y(3) As Long
'---------- left ----------
If 0 < key(0) And key_enable(0) = True Then
key_enable(0) = False
For i = 0 To 3
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 3
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 3
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 3
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 3
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 3
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
temp(i * width + j) = 32
If 0 < block(i * width + j) Then
temp(i * width + j) = 96 + block(i * width + j)
End If
Next j
Next i
If mode = 1 Then
For i = 0 To 3
temp(drop_y(i) * width + drop_x(i)) = 96 + drop_id
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
'------------------------
ReDim temp(3 * 4 - 1) As Byte
For i = 0 To 3
For j = 0 To 2
temp(i * 3 + j) = 32
Next j
Next i
For i = 0 To 3
temp((next_y(i) + 2 - (height - 2)) * 3 + (next_x(i) + 1 - (width / 2))) = 96 + next_id
Next i
For i = 0 To 3
For j = 0 To 2
Sheet1.Cells(5 - i, 11 + j) = Chr(temp(i * 3 + j))
Next j
Next i
End Sub
0 件のコメント:
コメントを投稿