voxel.frm

Deleta Force 引擎的雏形

VERSION 5.00
Begin VB.Form Form1 
   Caption         =   "Voxel"
   ClientHeight    =   3675
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   4815
   KeyPreview      =   -1  'True
   LinkTopic       =   "Form1"
   ScaleHeight     =   3675
   ScaleWidth      =   4815
   StartUpPosition =   3  'Windows Default
   Begin VB.PictureBox Pictxt 
      AutoRedraw      =   -1  'True
      AutoSize        =   -1  'True
      Height          =   1440
      Left            =   1920
      ScaleHeight     =   92
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   84
      TabIndex        =   2
      Top             =   210
      Visible         =   0   'False
      Width           =   1320
   End
   Begin VB.PictureBox Pichgt 
      AutoRedraw      =   -1  'True
      AutoSize        =   -1  'True
      Height          =   1695
      Left            =   1770
      ScaleHeight     =   109
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   112
      TabIndex        =   1
      Top             =   120
      Visible         =   0   'False
      Width           =   1740
   End
   Begin VB.PictureBox Pic 
      AutoSize        =   -1  'True
      Height          =   1560
      Left            =   0
      ScaleHeight     =   100
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   96
      TabIndex        =   0
      Top             =   0
      Width           =   1500
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Dim tmpScaleY
Dim tmpScaleX


Private Type SAFEARRAYBOUND
    cElements As Long
    lLbound As Long
End Type

Private Type SAFEARRAY1D
    cDims As Integer
    fFeatures As Integer
    cbElements As Long
    cLocks As Long
    pvData As Long
    Bounds(0 To 0) As SAFEARRAYBOUND
End Type

Private Type SAFEARRAY2D
    cDims As Integer
    fFeatures As Integer
    cbElements As Long
    cLocks As Long
    pvData As Long
    Bounds(0 To 1) As SAFEARRAYBOUND
End Type

Private Declare Function VarPtrArray Lib "msvbvm50.dll" Alias "VarPtr" (Ptr() As Any) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)
Private Type BITMAP
    bmType As Long
    bmWidth As Long
    bmHeight As Long
    bmWidthBytes As Long
    bmPlanes As Integer
    bmBitsPixel As Integer
    bmBits As Long
End Type


Private 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
Private Const SRCCOPY = &HCC0020 ' (DWORD) dest = source
Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long

Private Const SCREEN_WIDTH = 319
Private Const SCREEN_HEIGHT = 239
Private Const MAX_STEPS = 300


Dim x_ray As Double, y_ray As Double, z_ray As Double
Dim vp_x As Double, vp_y As Double, vp_z As Double
Dim vp_ang_x As Double, xr As Double, yr As Double
Dim curr_row As Integer, curr_step As Integer, curr_voxel_scale As Double
Dim dslope As Double, raycast_ang As Integer
Dim column_height As Double, color As Byte

Dim mx As Integer, my As Integer
Dim exitflag As Boolean
Dim dx As Double, dy As Double, dz As Double


Sub DrawFrame()
'***********************************
' Setup the bitmaps so we can
' get to their memory
'***********************************

' these are used to address the pixel using matrices
Dim pict() As Byte
Dim pict2() As Byte
Dim pict3() As Byte


Dim sa As SAFEARRAY2D, bmp As BITMAP
Dim sa2 As SAFEARRAY2D, bmp2 As BITMAP
Dim sa3 As SAFEARRAY2D, bmp3 As BITMAP
Dim r As Integer, c As Integer
' get bitmap info

GetObjectAPI Pic.Picture, Len(bmp), bmp 'picture
GetObjectAPI Pictxt.Picture, Len(bmp2), bmp2 'texture
GetObjectAPI Pichgt.Picture, Len(bmp3), bmp3 'height map

' exit if not a supported bitmap
If bmp.bmBitsPixel <> 8 Then
    MsgBox " 8-bit bitmaps only", vbCritical
    Exit Sub
End If
   
' have the local matrix point to bitmap pixels
With sa
    .cbElements = 1
    .cDims = 2
    .Bounds(0).lLbound = 0
    .Bounds(0).cElements = bmp.bmHeight
    .Bounds(1).lLbound = 0
    .Bounds(1).cElements = bmp.bmWidthBytes
    .pvData = bmp.bmBits
End With
CopyMemory ByVal VarPtrArray(pict), VarPtr(sa), 4
    
' have the local matrix point to bitmap pixels
With sa2
    .cbElements = 1
    .cDims = 2
    .Bounds(0).lLbound = 0
    .Bounds(0).cElements = bmp2.bmHeight
    .Bounds(1).lLbound = 0
    .Bounds(1).cElements = bmp2.bmWidthBytes
    .pvData = bmp2.bmBits
End With
CopyMemory ByVal VarPtrArray(pict2), VarPtr(sa2), 4

' have the local matrix point to bitmap pixels
With sa3
    .cbElements = 1
    .cDims = 2
    .Bounds(0).lLbound = 0
    .Bounds(0).cElements = bmp3.bmHeight
    .Bounds(1).lLbound = 0
    .Bounds(1).cElements = bmp3.bmWidthBytes
    .pvData = bmp3.bmBits
End With
CopyMemory ByVal VarPtrArray(pict3), VarPtr(sa3), 4

'***********************************
' Here is where we draw a frame
'***********************************
For c = 0 To 319
    For r = 0 To 239
        pict(c, r) = 0
    Next
Next

'**********************************************************
'Thanks to Andre' LaMothe for the C source code this Voxel
'demonstration is based on.  David Brebner 24/1/98
'**********************************************************

For c = 0 To SCREEN_WIDTH 'cast a ray for each column of the screen
    ' seed starting point for cast
    x_ray = vp_x
    y_ray = vp_y
    z_ray = vp_z

    ' compute deltas to project ray at, note the spherical cancelation factor
    dx = Cos((raycast_ang + c) / 360)
    dy = Sin((raycast_ang + c) / 360)
    
    ' dz is a bit complex, remember dz is the slope of the ray we are casting
    ' therefore, we need to take into consideration the down angle, or
    ' x axis angle, the more we are looking down the larger the intial dz
    ' must be
    dz = dslope * -100
    
    ' reset current voxel scale
    curr_voxel_scale = 0

    ' reset row
    curr_row = 0
    
    
    For curr_step = 0 To MAX_STEPS ' enter into casting loop
        xr = x_ray And 511 'trim
        yr = y_ray And 511 'trim
        ' get current height in height map
        ' and the added multiplication factor used to scale the mountains
        column_height = pict3(xr, yr) * 2
        
        'test if column height is greater than current voxel height for current step
        'from intial projection point
        If column_height > z_ray Then
            ' we know that we have intersected a voxel column, therefore we must
            ' render it until we have drawn enough pixels on the display such that
            ' thier projection would be correct for the height of this voxel column
            ' or until we have reached the top of the screen

            ' get the color for the voxel
            color = pict2(xr, yr)

            ' draw vertical column voxel
            Do
                ' draw a pixel
                pict(c, curr_row) = color

                ' now we need to push the ray upward on z axis, so increment the slope
                dz = dz + dslope

                ' now translate the current z position of the ray by the current voxel
                ' scale per unit
                z_ray = z_ray + curr_voxel_scale
                
                ' test if we are done with column
                curr_row = curr_row + 1
                If (curr_row >= 239) Then
                    ' force exit of outer steping loop
                    curr_step = MAX_STEPS
                    Exit Do
                End If
                
            Loop Until z_ray > column_height
        End If
        ' update the position of the ray
        x_ray = x_ray + dx
        y_ray = y_ray + dy
        z_ray = z_ray + dz

        ' update the current voxel scale, remember each step out means the scale increases
        ' by the delta scale
        curr_voxel_scale = curr_voxel_scale + dslope * 0.5

    Next
    

Next
 
'***********************************
' Clean up the bitmaps
'***********************************
' clear the temporary array descriptor
' without destroying the local temporary array
CopyMemory ByVal VarPtrArray(pict), 0&, 4
CopyMemory ByVal VarPtrArray(pict2), 0&, 4
CopyMemory ByVal VarPtrArray(pict3), 0&, 4

End Sub

Private Sub Form_Load()
Pic.Picture = LoadPicture(App.Path & "\title.gif")
Pictxt.Picture = LoadPicture(App.Path & "\texture.gif")
Pichgt.Picture = LoadPicture(App.Path & "\height.gif")

'set up the default starting positions
vp_z = 500: vp_x = 200: vp_y = 200
dslope = 0.05
raycast_ang = 100



tmpScaleX = 0
tmpScaleY = 0


End Sub

Private Sub Form_Unload(Cancel As Integer)
exitflag = True
End Sub

Private Sub Pic_KeyDown(KeyCode As Integer, Shift As Integer)
Me.Caption = KeyCode
Select Case KeyCode
    Case 38
        tmpScaleX = -10
        tmpScaleY = 0
    Case 39
        tmpScaleX = 0
        tmpScaleY = -10
    Case 40
        tmpScaleX = 10
        tmpScaleY = 0
    Case 37
        tmpScaleX = 0
        tmpScaleY = 10
End Select

vp_y = vp_y - tmpScaleY
vp_x = vp_x - tmpScaleX
    
    DrawFrame
    Pic.Refresh

End Sub