ab.com コミュニティ https://www.activebasic.com/forum/ |
|
[AB4]テトリス on Console https://www.activebasic.com/forum/viewtopic.php?t=112 |
ページ 1 / 1 |
作成者: | 山本 [ 2005年6月14日(火) 01:39 ] |
記事の件名: | [AB4]テトリス on Console |
ヒマつぶしに作ってみました。これから、肉付けしていきます(^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 |
作成者: | 山本 [ 2005年6月14日(火) 01:41 ] |
記事の件名: | 上の続き |
コード: 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() |
作成者: | ナナシ [ 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 |
ページ 1 / 1 | 全ての表示時間は UTC+09:00 です |
Powered by phpBB® Forum Software © phpBB Limited https://www.phpbb.com/ |