3dmaze.frm

用vb实现的3d迷宫游戏的代码

VERSION 5.00
Begin VB.Form frm3DMaze 
   BackColor       =   &H00FFFFFF&
   Caption         =   "3DMaze"
   ClientHeight    =   4470
   ClientLeft      =   1560
   ClientTop       =   1980
   ClientWidth     =   6000
   Icon            =   "3dmaze.frx":0000
   KeyPreview      =   -1  'True
   LinkTopic       =   "Form1"
   PaletteMode     =   1  'UseZOrder
   ScaleHeight     =   4470
   ScaleWidth      =   6000
   Begin VB.TextBox Text1 
      BackColor       =   &H00FFFFFF&
      BorderStyle     =   0  'None
      Height          =   288
      Left            =   0
      Locked          =   -1  'True
      TabIndex        =   1
      Top             =   4200
      Width           =   6012
   End
   Begin VB.VScrollBar VScroll1 
      Height          =   4212
      LargeChange     =   5
      Left            =   5760
      Max             =   60
      Min             =   30
      TabIndex        =   0
      Top             =   0
      Value           =   45
      Width           =   252
   End
   Begin VB.Timer Timer1 
      Enabled         =   0   'False
      Interval        =   55
      Left            =   0
      Top             =   0
   End
   Begin VB.Menu mnuAction 
      Caption         =   "&Action"
      Begin VB.Menu mnuActionItem 
         Caption         =   "&New"
         Index           =   0
      End
      Begin VB.Menu mnuActionItem 
         Caption         =   "&Solve"
         Enabled         =   0   'False
         Index           =   1
      End
      Begin VB.Menu mnuActionItem 
         Caption         =   "&Clear"
         Enabled         =   0   'False
         Index           =   2
      End
      Begin VB.Menu mnuActionItem 
         Caption         =   "-"
         Index           =   3
      End
      Begin VB.Menu mnuActionItem 
         Caption         =   "E&xit"
         Index           =   4
      End
   End
   Begin VB.Menu mnuStyle 
      Caption         =   "&Style"
      Begin VB.Menu mnuStyleItem 
         Caption         =   "&Hexagonal rooms"
         Index           =   0
      End
      Begin VB.Menu mnuStyleItem 
         Caption         =   "&Square rooms"
         Index           =   1
      End
   End
   Begin VB.Menu mnuHelp 
      Caption         =   "&Help"
      Begin VB.Menu mnuHelpItem 
         Caption         =   "&About..."
         Index           =   0
      End
   End
End
Attribute VB_Name = "frm3DMaze"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

Option Explicit

Private Type CornerRec
  X As Long
  Y As Long
End Type

Private Type VertexRec
  X As Double
  Y As Double
End Type

Private Type StackRec
  Index1 As Byte
  Index2 As Integer
End Type

Private Type PALETTEENTRY
  peRed As Byte
  peGreen As Byte
  peBlue As Byte
  peFlags As Byte
End Type

Private Type LOGPALETTE
  palVersion As Integer
  palNumEntries As Integer
  palPalEntry(16) As PALETTEENTRY
End Type

Private Declare Function CreatePalette Lib "GDI32" (LogicalPalette As LOGPALETTE) As Long
Private Declare Function CreatePen Lib "GDI32" (ByVal PenStyle As Long, ByVal Width As Long, ByVal Color As Long) As Long
Private Declare Function CreatePolygonRgn Lib "GDI32" (lpPoints As Any, ByVal nCount As Long, ByVal nPolyFillMode As Long) As Long
Private Declare Function CreateSolidBrush Lib "GDI32" (ByVal rgbColor As Long) As Long
Private Declare Function DeleteObject Lib "GDI32" (ByVal hndobj As Long) As Long
Private Declare Function FillRgn Lib "GDI32" (ByVal hDC As Long, ByVal hRegion As Long, ByVal hBrush As Long) As Long
Private Declare Function GetDeviceCaps Lib "GDI32" (ByVal hDC As Long, ByVal Index As Long) As Long
Private Declare Function LineTo Lib "GDI32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function MoveToEx Lib "GDI32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, ByVal NullPtr As Long) As Long
Private Declare Function RealizePalette Lib "GDI32" (ByVal hDC As Long) As Long
Private Declare Function SelectPalette Lib "GDI32" (ByVal hDC As Long, ByVal PaletteHandle As Long, ByVal Background As Long) As Long
Private Declare Function SelectObject Lib "GDI32" (ByVal hDC As Long, ByVal ObjectHandle As Long) As Long

Const PLANES = 14
Const BITSPIXEL = 12
Const PC_NOCOLLAPSE = 4
Const COLORS = 24
Const PS_SOLID = 0

Const NumColors = 16
Const TopColor = 12: ' all but last 3 colors are gray
Const RectangleSENWColor = 10
Const TriangleSSENNWColor = 9
Const TriangleSENWColor = 8
Const RectangleWEColor = 7
Const FloorColor = 6
Const TriangleSWNEColor = 5
Const RectangleSWNEColor = 4
Const TriangleSSWNNEColor = 3
Const BackoutColor = 13
Const AdvanceColor = 14
Const SolutionColor = 15

Const RelativeWidthOfWall = 0.25: ' relative to side of hexagon or square
Const RelativeHeightOfWall = 2#: ' relative to side of hexagon or square
Const MinWallLengthInInches = 0.25

Const SecondsForMazeSelection = 0.25

Dim AlreadyPainting As Boolean
Dim BaseRectangle(5, 3) As VertexRec
Dim BaseTriangle(3, 2) As VertexRec
Dim ComputerPage() As Byte
Dim CosTilt As Double
Dim CurrentColor As Integer
Dim HexDeltaX(5, 719) As Integer
Dim HexDeltaY(5, 719) As Integer
Dim MaxX As Integer
Dim MaxY As Integer
Dim Minimized As Boolean
Dim NumColumns As Integer
Dim NumRealized As Long
Dim NumRoomsInMaze As Integer
Dim NumRows As Integer
Dim OldPaletteHandle As Long
Dim Paint As Boolean
Dim PaletteHandle As Long
Dim PixelsPerX As Double
Dim PixelsPerZ As Double
Dim Rectangle(5, 3) As VertexRec
Dim RedGreenBlue(16) As Long
Dim RelDistOfUserFromScreen As Double
Dim Resize As Boolean
Dim Seed As String
Dim SinTilt As Double
Dim SolutionDisplayed As Boolean
Dim SqrDeltaX(3, 23) As Integer
Dim SqrDeltaY(3, 23) As Integer
Dim Sqrt3 As Double
Dim Stack() As StackRec
Dim State As Byte
Dim SubstitutionHigh(99) As Byte
Dim SubstitutionLow(99) As Byte
Dim Tilt As Double
Dim UsePalette As Boolean
Dim UserHasSolved As Boolean
Dim UserPage() As Byte
Dim UserX As Integer
Dim UserXRelative As Double
Dim UserY As Integer
Dim UserYRelative As Double
Dim X As Integer
Dim XMax As Double
Dim XOffset As Double
Dim Y As Integer
Dim YMax As Double
Dim YMod4 As Byte
Dim YOffset As Double

Private Sub DrawQuadrilateral(Box() As CornerRec, ColorNum As Integer)
  Dim Brush As Long
  Dim rc As Long
  Dim Region As Long
  If UsePalette Then
    Brush = CreateSolidBrush(16777216 + ColorNum)
    If Brush Then
      Region = CreatePolygonRgn(Box(0), 4, 1)
      If Region Then
        rc = FillRgn(frm3DMaze.hDC, Region, Brush)
        rc = DeleteObject(Region)
      End If
      rc = DeleteObject(Brush)
    End If
  Else
    Brush = CreateSolidBrush(RedGreenBlue(ColorNum))
    If Brush Then
      Region = CreatePolygonRgn(Box(0), 4, 1)
      If Region Then
        rc = FillRgn(frm3DMaze.hDC, Region, Brush)
        rc = DeleteObject(Region)
      End If
      rc = DeleteObject(Brush)
    End If
  End If
End Sub

Private Sub GetCorner(X#, Y#, Z#, PixelsPerX#, PixelsPerZ#, CosTilt#, SinTilt#, RelDistOfUserFromScreen#, XMax#, XOffset#, YMax#, Corner As CornerRec)
  Dim XAdjusted As Double
  Dim YPrime As Double
  Dim ZAdjusted As Double
  Dim ZPrime As Double

  YPrime = (YMax# - Y#) * CosTilt# - Z# * SinTilt#
  ZPrime = (YMax# - Y#) * SinTilt# + Z# * CosTilt#
  ZAdjusted = (YMax# / 2#) + RelDistOfUserFromScreen# * (ZPrime - (YMax# / 2#)) / (YPrime + RelDistOfUserFromScreen#)
  XAdjusted = (XMax# / 2#) + RelDistOfUserFromScreen# * (X# - (XMax# / 2#)) / (YPrime + RelDistOfUserFromScreen#)
  XAdjusted = XAdjusted + XOffset#
  Corner.X = Int(PixelsPerX# * XAdjusted)
  Corner.Y = (ScaleHeight - Text1.Height) - Int(PixelsPerZ# * ZAdjusted)
End Sub

Private Sub DisplayQuadrilateral(XMax#, XOffset#, YMax#, X0#, Y0#, Z0#, X1#, Y1#, Z1#, X2#, Y2#, Z2#, X3#, Y3#, Z3#, PixelsPerX#, PixelsPerZ#, CosTilt#, SinTilt#, RelDistOfUserFromScreen#, Shade%)
  Dim Quadrilateral(3) As CornerRec
  Dim TemQuad As CornerRec
  Call GetCorner(X0#, Y0#, Z0#, PixelsPerX#, PixelsPerZ#, CosTilt#, SinTilt#, RelDistOfUserFromScreen#, XMax#, XOffset#, YMax#, TemQuad)
  Quadrilateral(0).X = TemQuad.X
  Quadrilateral(0).Y = TemQuad.Y
  Call GetCorner(X1#, Y1#, Z1#, PixelsPerX#, PixelsPerZ#, CosTilt#, SinTilt#, RelDistOfUserFromScreen#, XMax#, XOffset#, YMax#, TemQuad)
  Quadrilateral(1).X = TemQuad.X
  Quadrilateral(1).Y = TemQuad.Y
  Call GetCorner(X2#, Y2#, Z2#, PixelsPerX#, PixelsPerZ#, CosTilt#, SinTilt#, RelDistOfUserFromScreen#, XMax#, XOffset#, YMax#, TemQuad)
  Quadrilateral(2).X = TemQuad.X
  Quadrilateral(2).Y = TemQuad.Y
  Call GetCorner(X3#, Y3#, Z3#, PixelsPerX#, PixelsPerZ#, CosTilt#, SinTilt#, RelDistOfUserFromScreen#, XMax#, XOffset#, YMax#, TemQuad)
  Quadrilateral(3).X = TemQuad.X
  Quadrilateral(3).Y = TemQuad.Y
  Call DrawQuadrilateral(Quadrilateral(), Shade%)
End Sub

Private Sub DrawTriangle(Box() As CornerRec, ColorNum As Integer)
  Dim Brush As Long
  Dim rc As Long
  Dim Region As Long
  If UsePalette Then
    Brush = CreateSolidBrush(16777216 + ColorNum)
    If Brush Then
      Region = CreatePolygonRgn(Box(0), 3, 1)
      If Region Then
        rc = FillRgn(frm3DMaze.hDC, Region, Brush)
        rc = DeleteObject(Region)
      End If
      rc = DeleteObject(Brush)
    End If
  Else
    Brush = CreateSolidBrush(RedGreenBlue(ColorNum))
    If Brush Then
      Region = CreatePolygonRgn(Box(0), 3, 1)
      If Region Then
        rc = FillRgn(frm3DMaze.hDC, Region, Brush)
        rc = DeleteObject(Region)
      End If
      rc = DeleteObject(Brush)
    End If
  End If
End Sub

Private Sub DisplayTriangle(XMax#, XOffset#, YMax#, X0#, Y0#, Z0#, X1#, Y1#, Z1#, X2#, Y2#, Z2#, PixelsPerX#, PixelsPerZ#, CosTilt#, SinTilt#, RelDistOfUserFromScreen#, Shade%)
  Dim Triangle(2) As CornerRec
  Dim TemTriangle As CornerRec
  Call GetCorner(X0#, Y0#, Z0#, PixelsPerX#, PixelsPerZ#, CosTilt#, SinTilt#, RelDistOfUserFromScreen#, XMax#, XOffset#, YMax#, TemTriangle)
  Triangle(0).X = TemTriangle.X
  Triangle(0).Y = TemTriangle.Y
  Call GetCorner(X1#, Y1#, Z1#, PixelsPerX#, PixelsPerZ#, CosTilt#, SinTilt#, RelDistOfUserFromScreen#, XMax#, XOffset#, YMax#, TemTriangle)
  Triangle(1).X = TemTriangle.X
  Triangle(1).Y = TemTriangle.Y
  Call GetCorner(X2#, Y2#, Z2#, PixelsPerX#, PixelsPerZ#, CosTilt#, SinTilt#, RelDistOfUserFromScreen#, XMax#, XOffset#, YMax#, TemTriangle)
  Triangle(2).X = TemTriangle.X
  Triangle(2).Y = TemTriangle.Y
  Call DrawTriangle(Triangle(), Shade%)
End Sub

Private Sub OutputTriangle(XMax#, XOffset#, YMax#, Triangle() As VertexRec, PixelsPerX#, PixelsPerZ#, CosTilt#, SinTilt#, RelDistOfUserFromScreen#, FirstPass%, FaceColor%)
  Dim X0 As Double
  Dim X1 As Double
  Dim X2 As Double
  Dim X3 As Double
  Dim Y0 As Double
  Dim Y1 As Double
  Dim Y2 As Double
  Dim Y3 As Double
  If FirstPass% Then
    If ((Triangle(1).X < XMax# / 2#) And (Triangle(1).X > Triangle(0).X)) Then
      X0 = Triangle(2).X
      Y0 = Triangle(2).Y
      X1 = Triangle(1).X
      Y1 = Triangle(1).Y
      X2 = Triangle(1).X
      Y2 = Triangle(1).Y
      X3 = Triangle(2).X
      Y3 = Triangle(2).Y
      Call DisplayQuadrilateral(XMax#, XOffset#, YMax#, X0, Y0, RelativeHeightOfWall, X1, Y1, RelativeHeightOfWall, X2, Y2, 0#, X3, Y3, 0#, PixelsPerX#, PixelsPerZ#, CosTilt#, SinTilt#, RelDistOfUserFromScreen#, TriangleSSWNNEColor)
    End If
    If ((Triangle(1).X > XMax# / 2#) And (Triangle(1).X < Triangle(2).X)) Then
      X0 = Triangle(1).X
      Y0 = Triangle(1).Y
      X1 = Triangle(0).X
      Y1 = Triangle(0).Y
      X2 = Triangle(0).X
      Y2 = Triangle(0).Y
      X3 = Triangle(1).X
      Y3 = Triangle(1).Y
      Call DisplayQuadrilateral(XMax#, XOffset#, YMax#, X0, Y0, RelativeHeightOfWall, X1, Y1, RelativeHeightOfWall, X2, Y2, 0#, X3, Y3, 0#, PixelsPerX#, PixelsPerZ#, CosTilt#, SinTilt#, RelDistOfUserFromScreen#, TriangleSSENNWColor)