ヒマつぶしに作ってみました。これから、肉付けしていきます(^w^
※コピペするときは、2つの記事を連結してください。1つでは収まりませんでしたので(汗
コード: #console
'-----------------------------
' テトリス Ver0.01
' presented D.Y.
'-----------------------------
Const WAIT_TIME = 50
Const STAGE_X = 12
Const STAGE_Y = 21
Const PIECE_WALL = -1
Const PIECE_OFF = 0
Const PIECE_ON = 1
Const DELAY_TIME = 1000
Dim DelayTime As Long
Dim TimeInterval As Long
Const KEYHOLD_WAIT = 300
Dim field[ELM(STAGE_Y),ELM(STAGE_X)] As Long
Dim stage[ELM(STAGE_Y),ELM(STAGE_X)] As Long
Dim block[ELM(4),ELM(4)] As Long
Dim BlockList[ELM(7),ELM(4),ELM(4)]=[
[ [0,1,0,0],
[0,1,0,0],
[0,1,0,0],
[0,1,0,0] ],
[ [0,0,0,0],
[0,1,1,0],
[0,1,0,0],
[0,1,0,0] ],
[ [0,0,1,0],
[0,1,1,0],
[0,1,0,0],
[0,0,0,0] ],
[ [0,1,0,0],
[0,1,1,0],
[0,0,1,0],
[0,0,0,0] ],
[ [0,0,0,0],
[0,1,0,0],
[1,1,1,0],
[0,0,0,0] ],
[ [0,0,0,0],
[0,1,1,0],
[0,1,1,0],
[0,0,0,0] ],
[ [0,0,0,0],
[0,1,1,0],
[0,0,1,0],
[0,0,1,0] ]
] As Long
Dim NowX As Long, NowY As Long
Dim Score=0 As Long
Dim bGameOver As Long
Sub initialize()
'---------
' 初期化
'---------
Dim i As Long, j As Long
'擬似乱数を初期化
Randomize
'壁をセット
For i=0 To STAGE_Y-1
For j=0 To STAGE_X-1
If j=0 or j=STAGE_X-1 or i=STAGE_Y-1 Then
field[i,j]=PIECE_WALL
stage[i,j]=PIECE_WALL
End If
Next
Next
'最初のブロックを投入
CreateBlock()
End Sub
Sub ShowScreen()
'-------------------
' ゲーム画面を表示
'-------------------
Dim i As Long, j As Long
Locate 0,0
For i=0 To STAGE_Y-1
For j=0 To STAGE_X-1
If field[i,j]=PIECE_WALL Then
Print "□";
ElseIf field[i,j]=PIECE_ON Then
Print "■";
Else
Print " ";
End If
Next
Print
Next
Print "Score:";Score
End Sub
Sub CreateBlock()
'-----------------------
' 新しいブロックを投入
'-----------------------
Dim i As Long, j As Long
Dim num As Long
'乱数を利用してブロックを確定
num=Int(Rnd()*7)
memcpy(block,VarPtr(BlockList[num,0,0]),4*4*SizeOf(Long))
'ブロックの初期座標
NowX=4:NowY=0
For i=0 To 4-1
For j=0 To 4-1
If block[i,j] Then
field[i,j+NowX]=PIECE_ON
If stage[i,j+NowX]=PIECE_ON Then
'初期位置に既にブロックが存在するときは、ゲームオーバーにする
bGameOver=1
Exit Sub
End If
End If
Next
Next
End Sub
Function CheckOverlap(BaseX As Long, BaseY As Long) As Long
'----------------------------------------------------------------
' ブロックの次の位置に固定ブロックまたは壁があるかどうかを調べる
'----------------------------------------------------------------
Dim i As Long, j As Long
For i=0 To 4-1
For j=0 To 4-1
If block[i,j] Then
If stage[BaseY+i,BaseX+j] Then
CheckOverlap=0
Exit Sub
End If
End If
Next
Next
CheckOverlap=1
End Function
Sub MoveBlock(BaseX, BaseY)
'------------------------------
' ブロックを次の位置に移動する
'------------------------------
Dim i As Long, j As Long
'以前のブロックを消去
For i=0 To 4-1
For j=0 To 4-1
If block[i,j] Then
field[NowY+i,NowX+j]=PIECE_OFF
End If
Next
Next
'ブロック座標を更新
NowX=BaseX
NowY=BaseY
'新しい座標にブロックを入れる
For i=0 To 4-1
For j=0 To 4-1
If block[i,j] Then
field[NowY+i,NowX+j]=PIECE_ON
End If
Next
Next
'画面を表示
ShowScreen()
End Sub
Sub LockBlock()
'-----------------------
' ブロックを固定させる
'-----------------------
Dim i As Long, j As Long
memcpy(stage,field,STAGE_Y*STAGE_X*SizeOf(Long))
CheckLines()
memcpy(field,stage,STAGE_Y*STAGE_X*SizeOf(Long))
End Sub
Sub TurnBlock() As Long
'-----------------------
' ブロックを回転させる
'-----------------------
Dim i As Long, j As Long
Dim temp[ELM(4),ELM(4)] As Long
'blockの内容を一時保存
memcpy(temp,block,4*4*SizeOf(Long))
'回転
For i=0 To 4-1
For j=0 To 4-1
block[i,j]=temp[3-j,i]
Next
Next
Dim BaseX As Long
BaseX=NowX
If CheckOverlap(NowX,NowY)=0 Then
'回転できないときは横へ移動させて、試してみる
If CheckOverlap(NowX+1,NowY) Then
BaseX=BaseX+1
ElseIf CheckOverlap(NowX-1,NowY) Then
BaseX=BaseX-1
Else
'すべて無理なときは中断
memcpy(block,temp,4*4*SizeOf(Long))
Exit Sub
End If
End If
'以前のブロックを消去
For i=0 To 4-1
For j=0 To 4-1
If temp[i,j] Then
field[NowY+i,NowX+j]=PIECE_OFF
End If
Next
Next
'横移動を考慮
NowX=BaseX
'新しい座標にブロックを入れる
For i=0 To 4-1
For j=0 To 4-1
If block[i,j] Then
field[NowY+i,NowX+j]=PIECE_ON
End If
Next
Next
'画面を更新
ShowScreen()
End Sub
ヒマつぶしに作ってみました。これから、肉付けしていきます(^w^ ※コピペするときは、2つの記事を連結してください。1つでは収まりませんでしたので(汗
[code]#console
'----------------------------- ' テトリス Ver0.01 ' presented D.Y. '-----------------------------
Const WAIT_TIME = 50
Const STAGE_X = 12 Const STAGE_Y = 21
Const PIECE_WALL = -1 Const PIECE_OFF = 0 Const PIECE_ON = 1
Const DELAY_TIME = 1000 Dim DelayTime As Long Dim TimeInterval As Long
Const KEYHOLD_WAIT = 300
Dim field[ELM(STAGE_Y),ELM(STAGE_X)] As Long Dim stage[ELM(STAGE_Y),ELM(STAGE_X)] As Long
Dim block[ELM(4),ELM(4)] As Long Dim BlockList[ELM(7),ELM(4),ELM(4)]=[ [ [0,1,0,0], [0,1,0,0], [0,1,0,0], [0,1,0,0] ], [ [0,0,0,0], [0,1,1,0], [0,1,0,0], [0,1,0,0] ], [ [0,0,1,0], [0,1,1,0], [0,1,0,0], [0,0,0,0] ], [ [0,1,0,0], [0,1,1,0], [0,0,1,0], [0,0,0,0] ], [ [0,0,0,0], [0,1,0,0], [1,1,1,0], [0,0,0,0] ], [ [0,0,0,0], [0,1,1,0], [0,1,1,0], [0,0,0,0] ], [ [0,0,0,0], [0,1,1,0], [0,0,1,0], [0,0,1,0] ] ] As Long
Dim NowX As Long, NowY As Long
Dim Score=0 As Long Dim bGameOver As Long
Sub initialize() '--------- ' 初期化 '--------- Dim i As Long, j As Long
'擬似乱数を初期化 Randomize
'壁をセット For i=0 To STAGE_Y-1 For j=0 To STAGE_X-1 If j=0 or j=STAGE_X-1 or i=STAGE_Y-1 Then field[i,j]=PIECE_WALL stage[i,j]=PIECE_WALL End If Next Next
'最初のブロックを投入 CreateBlock() End Sub
Sub ShowScreen() '------------------- ' ゲーム画面を表示 '------------------- Dim i As Long, j As Long
Locate 0,0
For i=0 To STAGE_Y-1 For j=0 To STAGE_X-1 If field[i,j]=PIECE_WALL Then Print "□"; ElseIf field[i,j]=PIECE_ON Then Print "■"; Else Print " "; End If Next
Print Next
Print "Score:";Score End Sub
Sub CreateBlock() '----------------------- ' 新しいブロックを投入 '----------------------- Dim i As Long, j As Long Dim num As Long
'乱数を利用してブロックを確定 num=Int(Rnd()*7) memcpy(block,VarPtr(BlockList[num,0,0]),4*4*SizeOf(Long))
'ブロックの初期座標 NowX=4:NowY=0
For i=0 To 4-1 For j=0 To 4-1 If block[i,j] Then field[i,j+NowX]=PIECE_ON
If stage[i,j+NowX]=PIECE_ON Then '初期位置に既にブロックが存在するときは、ゲームオーバーにする bGameOver=1 Exit Sub End If End If Next Next End Sub
Function CheckOverlap(BaseX As Long, BaseY As Long) As Long '---------------------------------------------------------------- ' ブロックの次の位置に固定ブロックまたは壁があるかどうかを調べる '---------------------------------------------------------------- Dim i As Long, j As Long
For i=0 To 4-1 For j=0 To 4-1 If block[i,j] Then If stage[BaseY+i,BaseX+j] Then CheckOverlap=0 Exit Sub End If End If Next Next
CheckOverlap=1 End Function
Sub MoveBlock(BaseX, BaseY) '------------------------------ ' ブロックを次の位置に移動する '------------------------------ Dim i As Long, j As Long
'以前のブロックを消去 For i=0 To 4-1 For j=0 To 4-1 If block[i,j] Then field[NowY+i,NowX+j]=PIECE_OFF End If Next Next
'ブロック座標を更新 NowX=BaseX NowY=BaseY
'新しい座標にブロックを入れる For i=0 To 4-1 For j=0 To 4-1 If block[i,j] Then field[NowY+i,NowX+j]=PIECE_ON End If Next Next
'画面を表示 ShowScreen() End Sub
Sub LockBlock() '----------------------- ' ブロックを固定させる '----------------------- Dim i As Long, j As Long
memcpy(stage,field,STAGE_Y*STAGE_X*SizeOf(Long))
CheckLines()
memcpy(field,stage,STAGE_Y*STAGE_X*SizeOf(Long)) End Sub
Sub TurnBlock() As Long '----------------------- ' ブロックを回転させる '----------------------- Dim i As Long, j As Long Dim temp[ELM(4),ELM(4)] As Long
'blockの内容を一時保存 memcpy(temp,block,4*4*SizeOf(Long))
'回転 For i=0 To 4-1 For j=0 To 4-1 block[i,j]=temp[3-j,i] Next Next
Dim BaseX As Long BaseX=NowX
If CheckOverlap(NowX,NowY)=0 Then '回転できないときは横へ移動させて、試してみる If CheckOverlap(NowX+1,NowY) Then BaseX=BaseX+1 ElseIf CheckOverlap(NowX-1,NowY) Then BaseX=BaseX-1 Else 'すべて無理なときは中断 memcpy(block,temp,4*4*SizeOf(Long)) Exit Sub End If End If
'以前のブロックを消去 For i=0 To 4-1 For j=0 To 4-1 If temp[i,j] Then field[NowY+i,NowX+j]=PIECE_OFF End If Next Next
'横移動を考慮 NowX=BaseX
'新しい座標にブロックを入れる For i=0 To 4-1 For j=0 To 4-1 If block[i,j] Then field[NowY+i,NowX+j]=PIECE_ON End If Next Next
'画面を更新 ShowScreen() End Sub[/code]
|