ctetassist.cls

一个俄罗斯方块游戏

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "CTetAssist"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Implements ITetrisAssist

Private Declare Sub CopyMemory Lib "KERNEL32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Sub ZeroMemory Lib "KERNEL32" Alias "RtlZeroMemory" (dest As Any, ByVal numBytes As Long)

Private m_Angles(6) As Long

Private nOldHoleCols As Long
Private nOldHoleRows As Long
Private nOldHoleCount As Long
Private nOldDepths() As Long
Private nOldMinDepth As Long
Private nOldMaxDepth As Long
Private nOldTotalDepth As Long

Private Sub Class_Initialize()
   ITetrisAssist_Reset
   
   m_Angles(0) = 2
   m_Angles(1) = 1
   m_Angles(2) = 4
   m_Angles(3) = 2
   m_Angles(4) = 2
   m_Angles(5) = 4
   m_Angles(6) = 4
End Sub

Private Sub ITetrisAssist_GetActions(nPanel() As Byte, ByVal nTetris As Long, ByVal nAngle As Long, ByVal nLeft As Long, ByVal nTop As Long, ByVal oActions As Collection)
   pCalDepth nPanel, nOldDepths
   pCalHole nPanel, nOldDepths, nOldHoleRows, nOldHoleCols, nOldHoleCount
   pCalMinMax nOldDepths, nOldMinDepth, nOldMaxDepth, nOldTotalDepth
   
   Dim nDA As Long
   Dim nTryLeft As Long, nTryTop As Long, nTryAngle As Long
   Dim nLeftofMax As Long, nAngleofMax As Long
   Dim nWeight As Long, nMaxWeight As Long
   
   nTryAngle = nAngle
   nMaxWeight = &H80000000
   For nDA = 1 To m_Angles(nTetris)
      nTryLeft = nLeft
      Do While CanPlaceTetris(nTetris, nTryAngle, nTryLeft, nTop, nPanel)
         nTryTop = pDropDown(nPanel, nTetris, nTryAngle, nTryLeft, nTop)
         nWeight = pCalWeight(nPanel, nTetris, nTryAngle, nTryLeft, nTryTop)
         If nWeight > nMaxWeight Then
            nMaxWeight = nWeight
            nLeftofMax = nTryLeft
            nAngleofMax = nTryAngle
         End If
         nTryLeft = nTryLeft - 1
      Loop
         
      nTryLeft = nLeft + 1
      Do While CanPlaceTetris(nTetris, nTryAngle, nTryLeft, nTop, nPanel)
         nTryTop = pDropDown(nPanel, nTetris, nTryAngle, nTryLeft, nTop)
         nWeight = pCalWeight(nPanel, nTetris, nTryAngle, nTryLeft, nTryTop)
         If nWeight >= nMaxWeight Then
            nMaxWeight = nWeight
            nLeftofMax = nTryLeft
            nAngleofMax = nTryAngle
         End If
         nTryLeft = nTryLeft + 1
      Loop
         
      nTryAngle = (nTryAngle + 1) Mod 4
   Next
   
   Dim I As Long
   For I = 1 To nAngleofMax - nAngle
      oActions.Add btt_ta_TurnLeft
   Next
   
   Dim nMove As Long
   If nLeft > nLeftofMax Then
      nMove = btt_ta_MoveLeft
   Else
      nMove = btt_ta_MoveRight
   End If
   
   For I = 1 To Abs(nLeftofMax - nLeft)
      oActions.Add nMove
   Next
   
   oActions.Add btt_ta_DropDown
End Sub


Private Sub ITetrisAssist_Reset()
End Sub


Private Function pDropDown(nPanel() As Byte, ByVal nTetris As Long, ByVal nAngle As Long, ByVal nLeft As Long, ByVal nTop As Long) As Long
   Dim I As Long
   I = 1
   Do While CanPlaceTetris(nTetris, nAngle, nLeft, nTop + I, nPanel)
      I = I + 1
   Loop
   
   pDropDown = nTop + I - 1
End Function


Private Function pCalWeight(nOrgPanel() As Byte, ByVal nTetris As Long, ByVal nAngle As Long, ByVal nLeft As Long, ByVal nTop As Long) As Long
   Dim nPanel() As Byte
   nPanel = nOrgPanel
            
   Dim nPanelRowLB As Long, nPanelRowUB As Long '* the lower and upper bound of the Panel() array
   Dim nPanelColLB As Long, nPanelColUB As Long '* the lower and upper bound of the Panel() array
   Dim nRow As Long, nCol As Long
   nPanelRowLB = LBound(nPanel, 2)
   nPanelRowUB = UBound(nPanel, 2)
   nPanelColLB = LBound(nPanel, 1)
   nPanelColUB = UBound(nPanel, 1)
   
   PlaceTetris nTetris, nAngle, nLeft, nTop, nPanel
   
   Dim nClearedRows As Long, bHaveSpace As Boolean
   For nRow = nPanelRowLB To nPanelRowUB
      bHaveSpace = False
      For nCol = nPanelColLB To nPanelColUB
         If nPanel(nCol, nRow) = 0 Then
            bHaveSpace = True
            Exit For
         End If
      Next
      
      If Not bHaveSpace Then
         CopyMemory nPanel(nPanelColLB, nPanelRowLB + 1), nPanel(nPanelColLB, nPanelRowLB), (nRow - nPanelRowLB) * (nPanelColUB - nPanelColLB + 1)
         ZeroMemory nPanel(nPanelColLB, nPanelRowLB), (nPanelColUB - nPanelColLB + 1)
         nClearedRows = nClearedRows + 1
      End If
   Next
   
   Dim nDepths() As Long
   Dim nMaxDepth As Long, nMinDepth As Long, nTotalDepth As Long
   pCalDepth nPanel, nDepths
   pCalMinMax nDepths, nMinDepth, nMaxDepth, nTotalDepth
   
   Dim nDDepths() As Long, nMinDDepth As Long, nMaxDDepth As Long, nTotalDDepth As Long
   pCalDDepths nDepths, nDDepths
   pCalMinMax nDDepths, nMinDDepth, nMaxDDepth, nTotalDDepth
   
   Dim nHoleCount As Long, nHoleCols As Long, nHoleRows As Long
   pCalHole nPanel, nDepths, nHoleRows, nHoleCols, nHoleCount
   
   Dim nRet As Double
'   nRet = nMinDepth
'   nRet = nRet + nClearedRows * 6 / (nMinDepth + 1)
'   nRet = nRet - (nHoleCount - nOldHoleCount) * 10 / ((nMaxDDepth + 1) / 6) ^ 2
'   nRet = nRet - (nMaxDepth - nMinDepth) * (20 - nMinDepth) / 10
'   nRet = nRet - (nMaxDDepth / 4) ^ 2
'   nRet = nRet * 3 + nTop
   Dim nDDCount(7) As Long
   For nCol = nPanelColLB To nPanelColUB - 1
      Dim nDDepth As Long
      nDDepth = nDDepths(nCol)
      If nDDepths(nCol) >= 7 Then
         nDDCount(7) = nDDCount(7) + 1
      Else
         nDDCount(nDDepth) = nDDCount(nDDepth) + 1
      End If
   Next
   
   nRet = (nMinDepth - nOldMinDepth) * 12 / (nMinDepth + 1) * 2000 _
            - (nHoleCols - nOldHoleCols) ^ 2 * 500 _
            - (nHoleRows - nOldHoleRows) ^ 2 * 500 _
            - (nHoleCount - nOldHoleCount) * 8000 _
            - nTop * 200
   If nClearedRows > 1 Then
      nRet = nRet + nClearedRows ^ 2 * 4000
   End If
   
   nRet = nRet + nDDCount(0) * 100 + _
            nDDCount(1) * 500 + _
            nDDCount(2) ^ 2 * -100 + _
            nDDCount(3) ^ 2 * -500 + _
            nDDCount(4) ^ 2 * -1000 + _
            nDDCount(5) ^ 2 * -2000 + _
            nDDCount(6) ^ 2 * -5000 + _
            nDDCount(7) ^ 2 * -10000

   pCalWeight = nRet
End Function


Private Sub pCalHole(nPanel() As Byte, nDepths() As Long, ByRef nHoleRows As Long, ByRef nHoleCols As Long, ByRef nHoleCount As Long)
   Dim nPanelRowLB As Long, nPanelRowUB As Long '* the lower and upper bound of the Panel() array
   Dim nPanelColLB As Long, nPanelColUB As Long '* the lower and upper bound of the Panel() array
   Dim nRow As Long, nCol As Long

   nPanelRowLB = LBound(nPanel, 2)
   nPanelRowUB = UBound(nPanel, 2)
   nPanelColLB = LBound(nPanel, 1)
   nPanelColUB = UBound(nPanel, 1)

   Dim bHoleCol() As Boolean, bHoleRow() As Boolean
   ReDim bHoleCol(nPanelColLB To nPanelColUB)
   ReDim bHoleRow(nPanelRowLB To nPanelRowUB)
   
   nHoleCount = 0
   For nCol = nPanelColLB To nPanelColUB
      nRow = nDepths(nCol) + 1
      Do While nRow <= nPanelRowUB
         If nPanel(nCol, nRow) = 0 Then
            nHoleCount = nHoleCount + 1
            bHoleCol(nCol) = True
            bHoleRow(nRow) = True
            Do
               If nPanel(nCol, nRow) > 0 Then Exit Do
               bHoleRow(nRow) = True
               nRow = nRow + 1
            Loop While nRow <= nPanelRowUB
         End If
         nRow = nRow + 1
      Loop
   Next
   
   nHoleCols = 0
   For nCol = nPanelColLB To nPanelColUB
      If bHoleCol(nCol) Then
         nHoleCols = nHoleCols + 1
      End If
   Next
   
   nHoleRows = 0
   For nRow = nPanelRowLB To nPanelRowUB
      If bHoleRow(nRow) Then
         nHoleRows = nHoleRows + 1
      End If
   Next
End Sub


Private Sub pCalDepth(nPanel() As Byte, nDepths() As Long)
   Dim nPanelRowLB As Long, nPanelRowUB As Long '* the lower and upper bound of the Panel() array
   Dim nPanelColLB As Long, nPanelColUB As Long '* the lower and upper bound of the Panel() array
   Dim nRow As Long, nCol As Long
   nPanelRowLB = LBound(nPanel, 2)
   nPanelRowUB = UBound(nPanel, 2)
   nPanelColLB = LBound(nPanel, 1)
   nPanelColUB = UBound(nPanel, 1)
   
   ReDim nDepths(nPanelColLB To nPanelColUB)
   For nCol = nPanelColLB To nPanelColUB
      For nRow = nPanelRowLB To nPanelRowUB
         If nPanel(nCol, nRow) > 0 Then
            Exit For
         End If
      Next
      nDepths(nCol) = nRow
   Next
End Sub


Private Sub pCalDDepths(nDepths() As Long, nDDepths() As Long)
   Dim nLB As Long, nUB As Long
   nLB = LBound(nDepths)
   nUB = UBound(nDepths)
   
   ReDim nDDepths(nLB To nUB)
   
   Dim I As Long
   For I = nLB To nUB - 1
      nDDepths(I) = Abs(nDepths(I) - nDepths(I + 1))
   Next
   nDDepths(nUB) = nDepths(nUB - 1)

'   Dim nPreDDepth As Long, nDDepth As Long
'   nPreDDepth = nDDepths(nLB)
'   For I = nLB + 1 To nUB - 1
'      nDDepth = nDDepths(I)
'      If nPreDDepth < nDDepth Then
'         nDDepths(I) = nPreDDepth
'      End If
'      nPreDDepth = nDDepth
'   Next
End Sub


Private Sub pCalMinMax(nN() As Long, ByRef nMin As Long, ByRef nMax As Long, nTotal As Long)
   Dim nLB As Long, nUB As Long
   nLB = LBound(nN)
   nUB = UBound(nN)
   
   nMax = nN(nLB)
   nMin = nN(nLB)
   nTotal = 0
   
   Dim I As Long
   For I = nLB To nUB
      Dim N As Long
      N = nN(I)
      nTotal = nTotal + N
      If N > nMax Then
         nMax = N
      
      ElseIf N < nMin Then
         nMin = N
      End If
   Next
End Sub