読み人知らず

2020年6月13日土曜日

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

Excelでテトリス 2

　前回作ったテトリスは、非常にシンプルな作りでした。それじゃ味気ないので、少しアニメーションとかをつけてみました。

　キー入力もバッファを使ってます。バッファを使わないと、一度で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

Excelでテトリス 1

　前回に引き続きExcelでタイマー処理を使って遊んでます。

　例によって、動作保証はしませんが、ソースコードはご自由にお使いください。

----------
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 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 drop_id As Byte
Private drop_x(3) As Byte
Private drop_y(3) As Byte

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
Call run

Call draw

'----- ESC Keyで終了 -----
If GetAsyncKeyState(VK_ESC) <> 0 Or counter = -1 Then
loopFlag = False
End If

'-------------------------
timeNext = timeNext + 100
End If

'-------------------------
Sheet1.Cells(1, 1).Select
DoEvents
Loop
'------------------------
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
Sheet1.Columns(i + 1).ColumnWidth = 2.095
Next i

'------------------------
For i = 0 To width * height - 1
block(i) = 0
Next i

'------------------------
Call create
counter = 0
End Sub

Private Sub create()
Dim i As Long

drop_id = Int(7 * Rnd() + 1)

For i = 0 To 3
drop_x(i) = width / 2
drop_y(i) = height - 2
Next i

'I, O, S, Z, J, L, T
If drop_id = 1 Then
'----- I -----
drop_y(1) = drop_y(1) + 1
drop_y(2) = drop_y(2) - 1
drop_y(3) = drop_y(3) - 2
ElseIf drop_id = 2 Then
'----- O -----
drop_x(1) = drop_x(1) + 1
drop_y(2) = drop_y(2) + 1
drop_x(3) = drop_x(3) + 1
drop_y(3) = drop_y(3) + 1
ElseIf drop_id = 3 Then
'----- S -----
drop_x(1) = drop_x(1) - 1
drop_y(2) = drop_y(2) + 1
drop_x(3) = drop_x(3) + 1
drop_y(3) = drop_y(3) + 1
ElseIf drop_id = 4 Then
'----- Z -----
drop_x(1) = drop_x(1) - 1
drop_y(1) = drop_y(1) + 1
drop_y(2) = drop_y(2) + 1
drop_x(3) = drop_x(3) + 1
ElseIf drop_id = 5 Then
'----- J -----
drop_x(1) = drop_x(1) - 1
drop_x(2) = drop_x(2) + 1
drop_x(3) = drop_x(3) - 1
drop_y(3) = drop_y(3) + 1
ElseIf drop_id = 6 Then
'----- L -----
drop_x(1) = drop_x(1) - 1
drop_x(2) = drop_x(2) + 1
drop_x(3) = drop_x(3) + 1
drop_y(3) = drop_y(3) + 1
ElseIf drop_id = 7 Then
'----- T -----
drop_x(1) = drop_x(1) - 1
drop_x(2) = drop_x(2) + 1
drop_y(3) = drop_y(3) + 1
End If
End Sub

Private Sub run()
Dim i As Long
Dim j As Long
Dim k 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

'消去処理
For i = 0 To height - 1
For j = 0 To width - 1
If block(i * width + j) = 0 Then
Exit For
End If
Next j

If j = width Then
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
counter = -1
Exit Sub
End If

Call create
counter = 0
End Sub

Private Sub run_key()
Dim i As Long
Dim temp_x(3) As Long
Dim temp_y(3) As Long

'---------- left ----------
If GetAsyncKeyState(VK_LEFT) <> 0 Then
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 GetAsyncKeyState(VK_UP) <> 0 Then
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 GetAsyncKeyState(VK_RIGHT) <> 0 Then

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 GetAsyncKeyState(VK_DOWN) <> 0 Then

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

For i = 0 To 3
temp(drop_y(i) * width + drop_x(i)) = 96 + drop_id
Next i

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
End Sub

Excelでライフゲーム

　前回、Excelでタイマー処理をするサンプルを作ったので、今回はそれを利用して、ライフゲームを作ってみました。
　Excelのセルを見続けていると、こんな感じで遊びたくなるのが普通です。たぶん。。。

　例によって、動作保証はしませんが、ソースコードはご自由にお使いください。

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 Const width As Long = 10
Private Const height As Long = 10
Private block(width * height - 1) As Byte '0 or 1

Public Sub lifeGame()
Dim timeNext As Long
Dim loopFlag As Boolean

timeNext = timeGetTime
loopFlag = True

Call init

'----- メインループ -----
Do While loopFlag = True
If timeNext < timeGetTime Then
Call run

'----- ESC Keyで終了 -----
If GetAsyncKeyState(VK_ESC) <> 0 Then
loopFlag = False
End If

'-------------------------
timeNext = timeNext + 500
End If

'-------------------------
Sheet1.Cells(1, 1).Select
DoEvents
Loop
'------------------------
End Sub

'初期化
Private Sub init()
Dim i As Long
Dim j As Long

'------------------------
'行の高さ、列の幅を調整
For i = 0 To width - 1
Sheet1.Columns(i + 1).ColumnWidth = 2.095
Next i

For i = 0 To height - 1
Sheet1.Rows(i + 1).RowHeight = 13.5
Next i

'------------------------
'適当なサンプル
Sheet1.Cells(4, 5) = "a"
Sheet1.Cells(5, 5) = "a"
Sheet1.Cells(6, 5) = "a"
Sheet1.Cells(7, 5) = "a"
Sheet1.Cells(8, 5) = "a"

'------------------------
For i = 0 To height - 1
For j = 0 To width - 1
block(i * width + j) = 0

If Sheet1.Cells(i + 1, j + 1) = "a" Then
block(i * width + j) = 1
End If
Next j
Next i
End Sub

'メインループの処理
Private Sub run()
Dim i As Long
Dim j As Long
Dim pos 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) = 0
Next j
Next i

For i = 0 To height - 1
For j = 0 To width - 1
pos = ((i + height - 1) Mod height) * width + ((j + width - 1) Mod width)
If block(pos) <> 0 Then temp(i * width + j) = temp(i * width + j) + 1

pos = ((i + height - 1) Mod height) * width + j
If block(pos) <> 0 Then temp(i * width + j) = temp(i * width + j) + 1

pos = ((i + height - 1) Mod height) * width + ((j + 1) Mod width)
If block(pos) <> 0 Then temp(i * width + j) = temp(i * width + j) + 1

pos = i * width + ((j + width - 1) Mod width)
If block(pos) <> 0 Then temp(i * width + j) = temp(i * width + j) + 1

pos = i * width + ((j + 1) Mod width)
If block(pos) <> 0 Then temp(i * width + j) = temp(i * width + j) + 1

pos = ((i + 1) Mod height) * width + ((j + width - 1) Mod width)
If block(pos) <> 0 Then temp(i * width + j) = temp(i * width + j) + 1

pos = ((i + 1) Mod height) * width + j
If block(pos) <> 0 Then temp(i * width + j) = temp(i * width + j) + 1

pos = ((i + 1) Mod height) * width + ((j + 1) Mod width)
If block(pos) <> 0 Then temp(i * width + j) = temp(i * width + j) + 1
Next j
Next i

For i = 0 To height - 1
For j = 0 To width - 1
If block(i * width + j) = 0 Then
If temp(i * width + j) = 3 Then
block(i * width + j) = 1
End If
ElseIf block(i * width + j) = 1 Then
If temp(i * width + j) < 2 Or 3 < temp(i * width + j) Then
block(i * width + j) = 0
End If
End If
Next j
Next i

'------------------------
'描画
For i = 0 To height - 1
For j = 0 To width - 1
If block(i * width + j) = 1 Then
Sheet1.Cells(i + 1, j + 1) = "a"
Else
'なぜか知らないけど、空文字列""だと動作が遅くなるみたい
Sheet1.Cells(i + 1, j + 1) = " "
End If
Next j
Next i
End Sub

Excelでタイマー処理

　ExcelでWindows APIを使うのはあまり好きではないのですが、Windows APIを使うからこそできることもあります。
　てなわけで、暇つぶしにWindos APIのタイマーを使ってみたサンプルです。
　waitTime関数はただ時間を待つだけです。loopTest関数はひたすら無限ループします。

　まぁ、次回以降のおもちゃを作るための準備なんですが。。。

　例によって、動作保証はしませんが、ソースコードはご自由にお使いください。

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
'--------------------------------------------------

Public Sub timerTest()
waitTime (3000)
MsgBox "waited 3 sec"
End Sub

Public Sub clear()
Sheet1.Cells.Delete
End Sub

Public Function waitTime(timeToWait As Integer)
Dim timeNext As Long
timeNext = timeGetTime() + timeToWait

'----- ループ -----
Do While timeGetTime() < timeNext
'Sheet1.Cells(1, 1).Select
DoEvents
Loop
'------------------
End Function

Public Function playSound(SoundName As String)
Dim wFlags As Long

wFlags = SND_ASYNC Or SND_NODEFAULT
playSound = sndPlaySound(SoundName, wFlags)
End Function

Public Sub loopTest()
Dim timeNext As Long
Dim loopFlag As Boolean

timeNext = timeGetTime
loopFlag = True

'----- メインループ -----
Do While loopFlag = True
If timeNext < timeGetTime Then

'----- ESC Keyで終了 -----
If GetAsyncKeyState(VK_ESC) <> 0 Then
loopFlag = False
End If

'-------------------------
timeNext = timeNext + 100
End If

'-------------------------
Sheet1.Cells(1, 1).Select
DoEvents
Loop
'------------------------
End Sub

2020年5月10日日曜日

連続性ってなんだろう

　学校を卒業して何年も経ちますが、今でも数学を勉強したりします。高木先生の「解析概論」は解析学の名著ですね。何度も読み返しています。まぁ、理由は「分からないから」なんですが。。。

　解析概論では、実数の連続性の説明から始まり、関数の連続性についての説明が続きます。実数の連続性は、Dedekindの切断とか、有界な単調数列が収束するとかで説明されます。関数の連続性は、epsilon-delta論法で説明されるアレです。
　簡単にepsilon-delta論法を復習すると、関数 f(x) が x = a で連続であるとは、
「任意の epsilon > 0 に対し、ある delta > 0 が存在し、|x - a| < delta なら、|f(x) - f(a)| < epsilon となる。」
って感じです。
　なかなかに分かりにくいですね。グラフで描いてやるともう少し分かりやすいと思います。

　試しに、f(x) = xとしてやりましょう。すると、
「任意の epsilon > 0 に対して、ある delta > 0が存在し、|x - a| < delta なら、|x - a| < epsilon となる。」
となります。明らかに、delta = epsilon とすればいいので、
「任意の epsilon > 0 に対して、|x - a| < epsilon となる。」
となります。
　これが関数 f(x) = x が、x = a で連続ということです。

・・・

　お気づきになったでしょうか？
　今の例では、f(x) は、ただの実数を意味する関数ですが、f(x) の関数としての連続性には、実数の連続性の議論は必要ありません。この論法では、x と f(x) は有理数のみで定義されていてもいいんです。
　(ここで必要なのは、実数が"連続"であることではなく、"稠密"であることです。)

　どちらかというと私は物理系なんで、物理屋さんの立場で考えてみます。
　epsilon-delta論法は物理屋さんの立場で考えると、誤差がepsilonってことです。つまり、実験の誤差や精度よりも小さい値はゼロと同じということです。
　また、物理実験で扱うのは有理数です。無理数を表すには無限の桁が必要なので使えません。もちろん、物理の理論には無理数も出てきますが、実用上は有理数のみの世界でも十分です。
　というわけで、解析学の理論が有理数のみの世界で成立してくれている方が、物理学にはしっくりきます。(私見ですが。)

　「ンなこと言っても、有理数だけだと、root 2 すら無いんでダメでしょう。」
　ごもっともです。
　有理数の世界にあるのは、せいぜい root 2 に近い有理数です。任意の epsilon に対し、|root 2 - x| < epsilon となる有理数 x が存在します。

　・・・

　解析学の世界では、任意の epsilon より小さい数はゼロと同等です。じゃ、root 2 に近い有理数があるからいいじゃん、となります。

　うーん。

　いろいろ考えてみたのですが、実数の連続性の説明に出てくる、Dedekindの切断とか、有界な単調数列の収束とかは、微分・積分の説明には不要な気がします。
　root 2 みたいな無理数の存在を説明するとか、実数が完備である、つまり数列の収束先が実数になるといったことを考えるなら、実数の連続性の議論が必要です。有理数の数列の収束先は有理数の世界では収まらないからです。
　ですが、微積分の理論を考えるだけなら、関数の連続性だけあればいいので、有理数だけでもいいんじゃないでしょうか？収束先は有理数の世界からはみ出ちゃいますが、epsilon-delta論法を使うなら、収束先の無理数にたどり着かなくてもOKなのではないでしょうか？。

　実数の連続性がないと困るのはRolleの定理とかでしょうか。証明の中で最大値の存在を利用しているので、実数の連続性が必要になります。有理数だけの世界だと最大値が存在しない (無理数になっちゃう) という場合があります。
　まぁ、いくらでも最大値に近い有理数が存在するから、なんとかなるっぽいですが。。。

　Wikipediaを見ても、epsilon-delta論法は”実数”に適用しているんですが。。。どうなんでしょうね。

　まぁ、こんなことを悩んでいる変人は私くらいですかね。。。

2020年4月26日日曜日

あの子が見ている

　コロナウイルスの感染拡大が続いています。お亡くなりになった方々のご冥福をお祈りいたします。

　コロナウイルス関連のニュースを見ていると、少し軽率なコメントを見る機会が多いように感じます。インターネット上では簡単に情報発信できるせいか、とにかく思ったことを条件反射的に書いているようなコメントです。(注)

　そういったコメントでは、「この意見が正しい」と主張するばかりで、その意見が正しい理由まで述べられていなかったりします。

　例えるなら、東京に住んでいる人が東京の都合だけ主張して、地方に住んでいる人の立場を考えていないような内容のコメントです。
　自分の立場を主張するのは間違いとは言いませんが。。。

　(逆に「私は東京に住んでいるものですが、・・・」といった前置きのあるコメントには、冷静さを感じます。)

　限られた文字数という制約や、過激な内容を好むというメディアの性質もあってか、思慮に欠けた軽率なコメントが余計に目立つ気がします。

　私が、インターネットばかり見過ぎなのでしょうか?

　思うに、子供は大人を見てその行動を真似るものです。
　そんな子供が思慮に欠いたコメントを見続けたら、どう思うでしょうか。
「大人は何も考えていない。とりあえず、自分に都合の良いことを主張することが大事。」と受け取るかもしれません。賢い子供は見抜くでしょう。

　「とにかく自分の意見を強く主張することが大事」という考え方もあるので、それを全否定する気はないのですが。。。
　見られているという意識を忘れないことも大事だと思います。

----------
(注)
2020/7/24 追記
　後から読んでみて、これ何のことだっけと思ってしまいました。国の給付金の話ですね。当時は、「いくらにしろ」とか、「条件をどうしろ」とか、「こういう政策が正解なんだよ」とか、「早くしろよバカ」とか、といった感じの話をたくさん見ました。
　後から読んでも分からない内容を条件反射的に書いてしまっている自分に反省。

登録: 投稿 (Atom)