ab.com コミュニティ

ActiveBasicを通したコミュニケーション
現在時刻 - 2018年10月23日(火) 00:18

All times are UTC+09:00




新しいトピックを投稿する  トピックへ返信する  [ 3 件の記事 ] 
作成者 メッセージ
 記事の件名: [AB4]テトリス on Console
投稿記事Posted: 2005年6月14日(火) 01:39 
オフライン
Site Admin

登録日時: 2005年5月30日(月) 15:08
記事: 535
ヒマつぶしに作ってみました。これから、肉付けしていきます(^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


通報する
ページトップ
 記事の件名: 上の続き
投稿記事Posted: 2005年6月14日(火) 01:41 
オフライン
Site Admin

登録日時: 2005年5月30日(月) 15:08
記事: 535
コード:
Sub CheckLines()
	'-----------------------------------
	' 横一列が揃っているかどうかを判定
	'-----------------------------------
	Dim i As Long, j As Long, k As Long
	Dim sw As Long
	Dim lines=0 As Long

	Do
		For i=0 To 20-1
			sw=1

			For j=1 To 11-1
				If stage[i,j]=PIECE_OFF Then sw=0
			Next
			If sw=1 Then Exit For
		Next
		If sw=0 Then Exit Do

		lines=lines+1

		'列を消去
		For j=1 To 11-1
			stage[i,j]=PIECE_OFF
		Next

		'上の行を消えた分だけスライド
		For k=i To 1 Step -1
			For j=1 To 11-1
				stage[k,j] = stage[k-1,j]
			Next
		Next
	Loop

	Select Case lines
		Case 1
			Score=Score+100
		Case 2
			Score=Score+300
		Case 3
			Score=Score+600
		Case 4
			Score=Score+1000
	End Select
End Sub


Dim KeyPushHold_Code As Long
Dim KeyPushHold_Time As Long
Dim bPushSpace As Long
Sub KeyControl(bDelay As Long)

	'右キー
	If GetKeyState(VK_RIGHT) And &H8000 Then
		If Not KeyPushHold_Code=VK_RIGHT Then
			KeyPushHold_Code=VK_RIGHT
			KeyPushHold_Time=0
		Else
			KeyPushHold_Time=KeyPushHold_Time+1
			If KeyPushHold_Time<KEYHOLD_WAIT/WAIT_TIME Then
				Goto *SpaceKey
			End If
		End If

		If CheckOverlap(NowX+1,NowY) Then
			MoveBlock(NowX+1,NowY)

			If bDelay Then DelayTime=0
		End If

		Goto *SpaceKey
	Else
		If KeyPushHold_Code=VK_RIGHT Then
			KeyPushHold_Code=0
		End If
	End If

	'左キー
	If GetKeyState(VK_LEFT) And &H8000 Then
		If Not KeyPushHold_Code=VK_LEFT Then
			KeyPushHold_Code=VK_LEFT
			KeyPushHold_Time=0
		Else
			KeyPushHold_Time=KeyPushHold_Time+1
			If KeyPushHold_Time<KEYHOLD_WAIT/WAIT_TIME Then
				Goto *SpaceKey
			End If
		End If

		If CheckOverlap(NowX-1,NowY) Then
			MoveBlock(NowX-1,NowY)

			If bDelay Then DelayTime=0
		End If

		Goto *SpaceKey
	Else
		If KeyPushHold_Code=VK_LEFT Then
			KeyPushHold_Code=0
		End If
	End If

	'下キー
	If GetKeyState(VK_DOWN) And &H8000 Then
		TimeInterval=TimeInterval+3

		Score=Score+1
	End If

	*SpaceKey

	'スペースキー
	If GetKeyState(VK_SPACE) And &H8000 Then
		If bPushSpace Then Exit Sub

		TurnBlock()
		bPushSpace=1
	Else
		bPushSpace=0
	End If
End Sub


Sub main()
	Dim i As Long

	'初期化
	initialize()

	DelayTime=0

	While(1)
		'---------------
		' メインループ
		'---------------

		'キー入力
		KeyControl(1)

		DelayTime=DelayTime+1

		If TimeInterval>100/WAIT_TIME Then
			TimeInterval=0
		Else
			Sleep(WAIT_TIME)
			TimeInterval=TimeInterval+1
			Continue
		End If

		*ReCheck

		If CheckOverlap(NowX,NowY+1) Then
			'ブロックを下方向へ動かす
			MoveBlock(NowX,NowY+1)
		Else
			'下方向に移動できないとき

			'猶予タイムを考慮
			If DelayTime<DELAY_TIME/WAIT_TIME Then
				While DelayTime<DELAY_TIME/WAIT_TIME
					KeyControl(0)
					Sleep(WAIT_TIME)
					DelayTime=DelayTime+1
				Wend

				Goto *ReCheck
			End If

			LockBlock()     'ブロックを固定
			CreateBlock()   '次のブロックを投入
			ShowScreen()    '画面を表示
			If bGameOver Then Exit While
		End If
	Wend

	Print "GameOver"
	Input "Please enter key?",i
End Sub

main()


通報する
ページトップ
投稿記事Posted: 2005年6月19日(日) 21:12 
ライン消しの時、アニメーションと点数が出るようにしてコード量も少なくしてみました。

変更点は Sub CheckLines() の中のみです。
他の部分は山本氏のコードをそのまま使ってください。
コード:
Sub CheckLines()
    '-----------------------------------
    ' 横一列が揃っているかどうかを判定
    '-----------------------------------
    Dim i As Long, j As Long, k As Long
    Dim sw As Long
    Dim lines=0 As Long

    For i=20-1 To 1 Step -1
        sw=1
        For j=1 To 11-1
            If stage[i,j]=PIECE_OFF Then sw=0
        Next
   	    If sw=1 Then
		    '列を消去
			Locate 2, i-lines
		    For j=1 To 11-1
		    	stage[i,j]=PIECE_OFF
				Print "□";
				Sleep(30)
			Next
			lines=lines+1
			Locate 10, i-lines+1
			Print lines*100
			Score=Score+lines*100
       		'上の行を消えた分だけスライド
       		For k=i To 1 Step -1
           		For j=1 To 11-1
       		        stage[k,j] = stage[k-1,j]
   		        Next
	        Next
			'スライドさせたので同じ段を再チェック
			i=i+1
		EndIf
	Next
	If lines >= 1 Then Sleep(500)
End Sub


通報する
ページトップ
   
期間内表示:  ソート  
新しいトピックを投稿する  トピックへ返信する  [ 3 件の記事 ] 

All times are UTC+09:00


オンラインデータ

このフォーラムを閲覧中のユーザー: なし & ゲスト[1人]


トピック投稿:  可
返信投稿:  可
記事編集: 不可
記事削除: 不可
ファイル添付: 不可

検索:
ページ移動:  
cron
Powered by phpBB® Forum Software © phpBB Limited
Japanese translation principally by KONISHI Yohsuke