game.frm

treasure游戏源程序

    Loop
    bConnected(nRoom2, nDimension1, nDirection1) = True
    nCoordinateNext(0) = nCoordinate(0)
    nCoordinateNext(1) = nCoordinate(1)
    nCoordinateNext(2) = nCoordinate(2)
    nCoordinateNext(3) = nCoordinate(3)
    nCoordinateNext(nDimension1) = nCoordinate(nDimension1) + 2 * nDirection1 - 1
    If (Not bEuclidean) Then
      If nCoordinateNext(nDimension1) < 0 Then
        nDimension2 = 0
        Do While nDimension2 < nDimensions
          nCoordinateNext(nDimension2) = nWidth(nDimension2) - nCoordinateNext(nDimension2) - 1
          nDimension2 = nDimension2 + 1
        Loop
        nCoordinateNext(nDimension1) = nWidth(nDimension1) - 1
      Else
        If nCoordinateNext(nDimension1) >= nWidth(nDimension1) Then
          nDimension2 = 0
          Do While nDimension2 < nDimensions
            nCoordinateNext(nDimension2) = nWidth(nDimension2) - nCoordinateNext(nDimension2) - 1
            nDimension2 = nDimension2 + 1
          Loop
          nCoordinateNext(nDimension1) = 0
        End If
      End If
    End If
    If nCell(nCoordinateNext(0), nCoordinateNext(1), nCoordinateNext(2), nCoordinateNext(3)) < 0 Then
      nRoom1 = nRoom1 + 1
      nCell(nCoordinateNext(0), nCoordinateNext(1), nCoordinateNext(2), nCoordinateNext(3)) = nRoom1
    End If
    nRoom2 = nCell(nCoordinateNext(0), nCoordinateNext(1), nCoordinateNext(2), nCoordinateNext(3))
    bConnected(nRoom2, nDimension1, 1 - nDirection1) = True
    nCoordinate(0) = nCoordinateNext(0)
    nCoordinate(1) = nCoordinateNext(1)
    nCoordinate(2) = nCoordinateNext(2)
    nCoordinate(3) = nCoordinateNext(3)
  Loop
  nTreasure1 = 0
  Do While nTreasure1 < nTreasures
    nTreasureRoom(nTreasure1) = 1 + Int(CDbl(nRooms - 1) * Rnd)
    nGuardRoom(nTreasure1) = nTreasureRoom(nTreasure1)
    bWeaponRoomFound = False
    Do While Not bWeaponRoomFound
      nWeaponRoom(nTreasure1) = 1 + Int(CDbl(nRooms - 1) * Rnd)
      If nWeaponRoom(nTreasure1) <> nTreasureRoom(nTreasure1) Then
        bWeaponRoomFound = True
      End If
    Loop
    nTreasure1 = nTreasure1 + 1
  Loop
  bInitialized = True
  GameUpdate
  MousePointer = 0
End Sub


Private Sub Form_Unload(Cancel As Integer)
  Dim Response As Long
  If bInitialized Then
    If nScore < 20 Then
      Response = MsgBox("Your score ranks you as a beginner.", vbOKOnly, "You scored " & CStr(nScore) & " out of 100 points.")
    Else
      If nScore < 40 Then
        Response = MsgBox("Your score ranks you as a novice adventurer.", vbOKOnly, "You scored " & CStr(nScore) & " out of 100 points.")
      Else
        If nScore < 60 Then
          Response = MsgBox("Your score ranks you as a seasoned explorer.", vbOKOnly, "You scored " & CStr(nScore) & " out of 100 points.")
        Else
          If nScore < 80 Then
            Response = MsgBox("Your score ranks you as a grissly old prospector.", vbOKOnly, "You scored " & CStr(nScore) & " out of 100 points.")
          Else
            Response = MsgBox("Your score ranks you as an expert treasure hunter;  there is no higher rating.", vbOKOnly, "You scored " & CStr(nScore) & " out of 100 points.")
          End If
        End If
      End If
    End If
  End If
End Sub


Private Sub pbAbout_Click()
  Dim Response As Long
  Response = MsgBox("Adventures in 4 Dimensions" + Chr(13) + Chr(13) + "Copyright " + Chr(169) + " 1997 James L. Dean ([e-mail])" + Chr(13) + Chr(13) + "This application may be distributed or used without payment to James L. Dean." + Chr(13) + Chr(13) + "As per Microsoft's license for Visual Basic 4.0, the end-user may not distribute the components having names starting with other than " _
+ Chr(34) + "treasure" + Chr(34) + "," + Chr(34) + "init" + Chr(34) + "," + Chr(34) + "game" + Chr(34) + "," + Chr(34) + "descript" + Chr(34) + ", or " + Chr(34) + "file_id" + Chr(34) + ".", vbOKOnly, "About Adventures in 4 Dimensions Release 4.4")
End Sub

Private Sub pbBackward_Click()
  nMoves = nMoves + 1
  nTCoordinate = nTCoordinate + 1
  GameUpdate
End Sub

Private Sub pbCarry_Click()
  Dim Response As Long
  nTreasure1 = 0
  Do While nTreasure1 < nTreasures
    If nWeaponRoom(nTreasure1) = nRoom1 Then
      nWeaponRoom(nTreasure1) = -1
    End If
    nTreasure1 = nTreasure1 + 1
  Loop
  nTreasure1 = 0
  Do While nTreasure1 < nTreasures
    If nTreasureRoom(nTreasure1) = nRoom1 Then
      If nWeaponRoom(nTreasure1) < 0 Then
        nTreasureRoom(nTreasure1) = -1
        nTreasuresRecovered = nTreasuresRecovered + 1
        If nGuardRoom(nTreasure1) = nRoom1 Then
          nGuardRoom(nTreasure1) = -1
          nWeaponRoom(nTreasure1) = -2
          Response = MsgBox("You're " & strWeapon(nTreasure1) & " overcomes the " & strGuard(nTreasure1) & ".", vbOKOnly, "Way to go!")
        End If
      Else
        Response = MsgBox("You carry nothing to overcome the " & strGuard(nTreasure1) & ".", vbOKOnly, "Whoops!")
      End If
    End If
    If nWeaponRoom(nTreasure1) = nRoom1 Then
      nWeaponRoom(nTreasure1) = -1
    End If
    nTreasure1 = nTreasure1 + 1
  Loop
  GameUpdate
End Sub

Private Sub pbDown_Click()
  nMoves = nMoves + 1
  nZCoordinate = nZCoordinate + 1
  GameUpdate
End Sub

Private Sub pbDrop_Click()
  nTreasure1 = 0
  Do While nTreasure1 < nTreasures
    If nTreasureRoom(nTreasure1) = -1 Then
      nTreasureRoom(nTreasure1) = 0
    End If
    nTreasure1 = nTreasure1 + 1
  Loop
  GameUpdate
End Sub

Private Sub pbEast_Click()
  nMoves = nMoves + 1
  nYCoordinate = nYCoordinate - 1
  GameUpdate
End Sub

Private Sub pbForward_Click()
  nMoves = nMoves + 1
  nTCoordinate = nTCoordinate - 1
  GameUpdate
End Sub

Private Sub pbNorth_Click()
  nMoves = nMoves + 1
  nXCoordinate = nXCoordinate - 1
  GameUpdate
End Sub


Private Sub pbSouth_Click()
  nMoves = nMoves + 1
  nXCoordinate = nXCoordinate + 1
  GameUpdate
End Sub


Private Sub pbUp_Click()
  nMoves = nMoves + 1
  nZCoordinate = nZCoordinate - 1
  GameUpdate
End Sub

Private Sub pbWayOut_Click()
  Dim Response As Long
  bPathFound = False
  If ((bTreasureCarried) And (nRoom1 <> 0)) Then
    nCoordinate(0) = nXCoordinate
    nCoordinate(1) = nYCoordinate
    nCoordinate(2) = nZCoordinate
    nCoordinate(3) = nTCoordinate
    nWayOutHead = 0
    nRoom2 = 0
    Do While nRoom2 < nRooms
      bRoomUsed(nRoom2) = False
      nRoom2 = nRoom2 + 1
    Loop
    bRoomUsed(nRoom1) = True
    nDirectionsUsed(nWayOutHead) = 0
    nDirectionsPossible = 2 * nDimensions
    nDimension1 = 0
    Do While nDimension1 < nDimensions
      nDirection1 = 0
      Do While nDirection1 < 2
        bDirectionUsed(nWayOutHead, nDimension1, nDirection1) = False
        nDirection1 = nDirection1 + 1
      Loop
      nDimension1 = nDimension1 + 1
    Loop
    strWayOut = ""
    nRoom2 = nRoom1
    nTrial = 0
    MousePointer = 11
    Do While (nTrial < 500) And (nRoom2 <> 0) And (nWayOutHead < 255)
      nTrial = nTrial + 1
      bDirectionFound = False
      Do While (Not bDirectionFound) And (nDirectionsUsed(nWayOutHead) < nDirectionsPossible)
        nDirection1 = Int(2# * Rnd)
        nDimension1 = Int(CDbl(nDimensions) * Rnd)
        If (Not bDirectionUsed(nWayOutHead, nDimension1, nDirection1)) Then
          bDirectionUsed(nWayOutHead, nDimension1, nDirection1) = True
          nDirectionsUsed(nWayOutHead) = nDirectionsUsed(nWayOutHead) + 1
          If bConnected(nRoom2, nDimension1, nDirection1) Then
            nCoordinateNext(0) = nCoordinate(0)
            nCoordinateNext(1) = nCoordinate(1)
            nCoordinateNext(2) = nCoordinate(2)
            nCoordinateNext(3) = nCoordinate(3)
            nCoordinateNext(nDimension1) = nCoordinate(nDimension1) + 2 * nDirection1 - 1
            If (Not bEuclidean) Then
              If nCoordinateNext(nDimension1) < 0 Then
                nDimension2 = 0
                Do While nDimension2 < nDimensions
                  nCoordinateNext(nDimension2) = nWidth(nDimension2) - nCoordinateNext(nDimension2) - 1
                  nDimension2 = nDimension2 + 1
                Loop
                nCoordinateNext(nDimension1) = nWidth(nDimension1) - 1
              Else
                If nCoordinateNext(nDimension1) >= nWidth(nDimension1) Then
                  nDimension2 = 0
                  Do While nDimension2 < nDimensions
                    nCoordinateNext(nDimension2) = nWidth(nDimension2) - nCoordinateNext(nDimension2) - 1
                    nDimension2 = nDimension2 + 1
                  Loop
                  nCoordinateNext(nDimension1) = 0
                End If
              End If
            End If
            If (Not bRoomUsed(nCell(nCoordinateNext(0), nCoordinateNext(1), nCoordinateNext(2), nCoordinateNext(3)))) Then
              bDirectionFound = True
            End If
          End If
        End If
      Loop
      If bDirectionFound Then
        nRoom2 = nCell(nCoordinateNext(0), nCoordinateNext(1), nCoordinateNext(2), nCoordinateNext(3))
        nWayOutHead = nWayOutHead + 1
        bRoomUsed(nRoom2) = True
        nDirectionsUsed(nWayOutHead) = 0
        nDimension2 = 0
        Do While nDimension2 < nDimensions
          nDirection2 = 0
          Do While nDirection2 < 2
            bDirectionUsed(nWayOutHead, nDimension2, nDirection2) = False
            nDirection2 = nDirection2 + 1
          Loop
          nDimension2 = nDimension2 + 1
        Loop
        nWayOutDimension(nWayOutHead) = nDimension1
        nWayOutDirection(nWayOutHead) = 1 - nDirection1
        Select Case nDimension1
          Case 0
            If nDirection1 = 0 Then
              strWayOut = strWayOut & "N"
            Else
              strWayOut = strWayOut & "S"
            End If
          Case 1
            If nDirection1 = 0 Then
              strWayOut = strWayOut & "E"
            Else
              strWayOut = strWayOut & "W"
            End If
          Case 2
            If nDirection1 = 0 Then
              strWayOut = strWayOut & "U"
            Else
              strWayOut = strWayOut & "D"
            End If
          Case Else
            If nDirection1 = 0 Then
              strWayOut = strWayOut & "F"
            Else
              strWayOut = strWayOut & "B"
            End If
        End Select
      Else
        nDirection1 = nWayOutDirection(nWayOutHead)
        nDimension1 = nWayOutDimension(nWayOutHead)
        nCoordinateNext(0) = nCoordinate(0)
        nCoordinateNext(1) = nCoordinate(1)
        nCoordinateNext(2) = nCoordinate(2)
        nCoordinateNext(3) = nCoordinate(3)
        nCoordinateNext(nDimension1) = nCoordinateNext(nDimension1) + 2 * nDirection1 - 1
        If (Not bEuclidean) Then
          If nCoordinateNext(nDimension1) < 0 Then
            nDimension2 = 0
            Do While nDimension2 < nDimensions
              nCoordinateNext(nDimension2) = nWidth(nDimension2) - nCoordinateNext(nDimension2) - 1
              nDimension2 = nDimension2 + 1
            Loop
            nCoordinateNext(nDimension1) = nWidth(nDimension1) - 1
          Else
            If nCoordinateNext(nDimension1) >= nWidth(nDimension1) Then
              nDimension2 = 0
              Do While nDimension2 < nDimensions
                nCoordinateNext(nDimension2) = nWidth(nDimension2) - nCoordinateNext(nDimension2) - 1
                nDimension2 = nDimension2 + 1
              Loop
              nCoordinateNext(nDimension1) = 0
            End If
          End If
        End If
        nRoom2 = nCell(nCoordinateNext(0), nCoordinateNext(1), nCoordinateNext(2), nCoordinateNext(3))
        nWayOutHead = nWayOutHead - 1
        If Len(strWayOut) > 1 Then
          strWayOut = Left(strWayOut, Len(strWayOut) - 1)
        Else
          strWayOut = ""
        End If
      End If
      nCoordinate(0) = nCoordinateNext(0)
      nCoordinate(1) = nCoordinateNext(1)
      nCoordinate(2) = nCoordinateNext(2)
      nCoordinate(3) = nCoordinateNext(3)
    Loop
    MousePointer = 0
    If nRoom2 = 0 Then
      bPathFound = True
    End If
  End If
  If bPathFound Then
    nTreasure1 = 0
    nRoom2 = 0
    Do While (nTreasure1 < nTreasures) And (nRoom2 >= 0)
      nRoom2 = nTreasureRoom(nTreasure1)
      If nRoom2 >= 0 Then
        nTreasure1 = nTreasure1 + 1
      End If
    Loop
    nRoom2 = nRoom1
    Do While nRoom1 = nRoom2
      nRoom2 = 1 + Int(CDbl(nRooms - 1) * Rnd)
    Loop
    nTreasureRoom(nTreasure1) = nRoom2
    Response = MsgBox("As he leaves,  he shouts the letters, '" & strWayOut & "'.", vbOKOnly, "The pirate takes one of your treasures.")
    GameUpdate
  Else
    Response = MsgBox("Try again later.", vbOKOnly, "Nothing happens.")
  End If
End Sub

Private Sub pbWest_Click()
  nMoves = nMoves + 1
  nYCoordinate = nYCoordinate + 1
  GameUpdate
End Sub