DOS/V Power Report 2001 January/VPR0101A.BIN/PROGRAM/Module1.bas

BASIC Source File | 2000-10-24 | 8.4 KB | 357 lines

Attribute VB_Name = "Module1"
Option Explicit

'ゲームエリアの定義
Private Const FIELD_PX = 8       'ゲームエリアの位置
Private Const FIELD_PY = 8       '  (X,Y)
Private Const FIELD_SX = 480     'ゲームエリアの大きさ
Private Const FIELD_SY = 304     '  (X,Y)

'パドルのデータ
Type TYPEPADL
    px  As Integer              'パドルの座標
    py  As Integer              '  (X,Y)
    sx  As Integer              'パドルの大きさ
    sy  As Integer              '  (X,Y)
End Type
Private paddle As TYPEPADL      'パドルのデータ

'干渉コード
Private Const NO_INTERSECT = 0  '干渉していない
Private Const OVER_BOTTOM = 1   '下が干渉
Private Const OVER_TOP = 2      '上が干渉
Private Const OVER_LEFT = 4     '左が干渉
Private Const OVER_RIGHT = 8    '右が干渉
Private Const OVER_INSIDE = 15  '包含

'ボールのデータ
Type TYPEBALL
    px  As Integer              'ボールの座標
    py  As Integer              '  (X,Y)
    sx  As Integer              'ボールの大きさ
    sy  As Integer              '  (X,Y)
    vx  As Integer              '移動ベクター
    vy  As Integer              '  (X,Y)
End Type
Private ball As TYPEBALL         'ボールのデータ

Public boPlaying As Boolean     'プレイ中を示すフラグ

'Win32 API宣言
Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long

Public Sub Main()
    SetupForm1          'Form1をセットアップする
End Sub

'Form1をセットアップする
Private Sub SetupForm1()
    Load Form1          'フォームをロード

    SetupScreens        'スクリーンを初期化
    SetupCombo1         '速度選択コンボを初期化

    GameInitialize      'ゲームを初期化する

    UpdateGameArea      'ゲームエリアを最新状態に更新

    Form1.Show          'フォームを表示
End Sub

'スクリーンを初期化する
Private Sub SetupScreens()
    'メインスクリーンを初期化する
    With Form1.mainscr
        .Left = FIELD_PX
        .Top = FIELD_PY
        .Width = FIELD_SX
        .Height = FIELD_SY
    End With

    'オフスクリーンを初期化する
    With Form1.offscr
        .Left = FIELD_PX
        .Top = FIELD_PY
        .Width = FIELD_SX
        .Height = FIELD_SY
        .BackColor = &HFFFFFF       '背景は白
    End With
End Sub

'ゲームエリアを最新状態に更新する
Private Sub UpdateGameArea()
    DrawPaddle True     'パドルを描画
    DrawBall True       'ボールを描画

    DrawGameArea        'ゲームエリアを描画
End Sub

'ゲームエリアを描画する
Private Sub DrawGameArea()
    Dim ret As Integer

    'オフスクリーンをメインスクリーンへ転送する
    ret = BitBlt(Form1.mainscr.hDC, 0, 0, FIELD_SX, FIELD_SY, Form1.offscr.hDC, 0, 0, vbSrcCopy)
    Form1.mainscr.Refresh
End Sub

'パドルを描画する
Private Sub DrawPaddle(disp As Boolean)
    Dim ret As Integer
    Dim pos As Integer

    '表示か消去かでパターンを切り替える
    pos = 0
    If Not disp Then
        pos = paddle.sy
    End If

    'パドルをオフスクリーンへ転送する
    ret = BitBlt(Form1.offscr.hDC, paddle.px, paddle.py, paddle.sx, paddle.sy, Form1.paddle.hDC, 0, pos, vbSrcCopy)
End Sub

'ボールを描画する
Private Sub DrawBall(disp As Boolean)
    Dim ret As Integer
    Dim pos As Integer

    '表示か消去かでパターンを切り替える
    pos = 0
    If Not disp Then
        pos = ball.sy
    End If

    'ボールをオフスクリーンへ転送する
    ret = BitBlt(Form1.offscr.hDC, ball.px, ball.py, ball.sx, ball.sy, Form1.ball.hDC, 0, pos, vbSrcCopy)
End Sub

'パドルを移動する
Private Sub MovePaddle(mx As Integer)
    Dim xmin As Integer
    Dim xmax As Integer

    'パドルの移動可能範囲を求める
    xmin = 0
    xmax = FIELD_SX - paddle.sx

    'パドルの移動を制限する
    If mx < xmin Then
        mx = xmin
    End If
    If mx > xmax Then
        mx = xmax
    End If

    '古いパドルを消去する
    DrawPaddle False

    If Not boPlaying Then
        '古いボールを消去する
        DrawBall False
    End If

    '新しいパドル位置を計算する
    paddle.px = mx

    If Not boPlaying Then
        '新しいボール位置を計算する
        ball.px = paddle.px + (paddle.sx - ball.sx) / 2
    End If

    '表示を更新する
    UpdateGameArea
End Sub

'ボールを移動する
Private Sub MoveBall()
    Dim refrect As Boolean
    Dim action As Integer

    '古いボールを消去する
    DrawBall False

    refrect = True
    While (refrect)
        refrect = False

        '新しいボール位置を計算する
        ball.px = ball.px + ball.vx
        ball.py = ball.py + ball.vy

        'ボールの壁干渉判定
        action = TestBallWithWall
        If (action > 0) Then
            DoBallWithAny (action)
            refrect = True
        End If

        'ボールのパドル干渉判定
        action = TestBallWithPaddle
        If (action > 0) Then
            DoBallWithAny (action)
            refrect = True
        End If
    Wend

    '表示を更新する
    UpdateGameArea
End Sub

'速度選択コンボを初期化する
Private Sub SetupCombo1()
    With Form1.Combo1
        .AddItem ("LOW")
        .AddItem ("MID")
        .AddItem ("HIGH")
        .ListIndex = 0   '速度を、LOWに設定
    End With
End Sub

'ゲームを初期化する
Private Sub GameInitialize()
    boPlaying = False   'プレイ中ではない

    StageInitialize     'ステージを初期化する
End Sub

'ステージを初期化する
Private Sub StageInitialize()
    SetupNextBall       '次のボールを用意する
End Sub

'次のボールを用意する
Private Sub SetupNextBall()
    'パドルを初期化
    With paddle
        .sx = 40
        .sy = 8
        .px = 200
        .py = 256
    End With

    'ボールを初期化
    With ball
        .sx = 8
        .sy = 8
        .px = paddle.px + (paddle.sx - ball.sx) / 2
        .py = paddle.py - ball.sy
        .vx = 0
        .vy = -5
    End With
End Sub

'ボールの壁干渉判定
Private Function TestBallWithWall()
    Dim action As Integer
    Dim X As Integer
    Dim Y As Integer

    action = NO_INTERSECT

    '下チェック
    Y = ball.py + ball.sy
    If (Y >= FIELD_SY) Then
        action = action Or OVER_BOTTOM
    End If

    '上チェック
    Y = ball.py
    If (Y <= 0) Then
        action = action Or OVER_TOP
    End If

    '右チェック
    X = ball.px + ball.sx
    If (X >= FIELD_SX) Then
        action = action Or OVER_RIGHT
    End If

    '左チェック
    X = ball.px
    If (X <= 0) Then
        action = action Or OVER_LEFT
    End If

    TestBallWithWall = action
End Function

'ボールのパドル干渉判定
Private Function TestBallWithPaddle()
    Dim action As Integer

    action = NO_INTERSECT

    'ボールがパドルの範囲内かチェック
    If (ball.px >= paddle.px) And (ball.px <= paddle.px + paddle.sx) Then
        If (ball.vy > 0) Then
            'パドルの上面で反射チェック
            If (ball.py + ball.sy >= paddle.py) And (ball.py < paddle.py) Then
                action = action Or OVER_BOTTOM
            End If
        Else
            'パドルの下面で反射チェック
            If (ball.py <= paddle.py) And (ball.py + ball.sy > paddle.py) Then
                action = action Or OVER_TOP
            End If
        End If
    End If

    TestBallWithPaddle = action
End Function

'ボールの反射処理
Private Sub DoBallWithAny(action As Integer)
    'ボールが上下ラインにかかったとき
    If (action And OVER_TOP) Or (action And OVER_BOTTOM) Then
        ' ボールの上下ベクターを反転
        ball.vy = -ball.vy
    End If

    'ボールが左右ラインにかかったとき
    If (action And OVER_LEFT) Or (action And OVER_RIGHT) Then
        ' ボールの左右ベクターを反転
        ball.vx = -ball.vx
    End If
End Sub

'-----------------------------------------------------------------------
' インタフェース
'-----------------------------------------------------------------------

'インターバル処理
Public Sub TimerProc()
    'ボールを移動する
    MoveBall
End Sub

'ステージ開始処理
Public Sub StartStageProc()

End Sub

'ステージクリア処理
Public Sub ClearStageProc()

End Sub

'ゲームオーバー処理
Public Sub GameOverProc()

End Sub

'ステージクリアかを調べる処理
Public Function IsClearStage()
    IsClearStage = False
End Function

'ゲームオーバーかを調べる処理
Public Function IsGameOver()
    IsGameOver = False
End Function

'マウス移動処理
Public Sub MouseMoveProc(mx As Integer)
    'パドルを移動
    MovePaddle mx
End Sub