caustics.frm

这是vb的源码 感谢这个网站给大家这个空间

VERSION 5.00
Begin VB.Form frmMain 
   Caption         =   "A simple 'underwater caustics' like effect"
   ClientHeight    =   4500
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   5100
   Icon            =   "Caustics.frx":0000
   KeyPreview      =   -1  'True
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   300
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   340
   StartUpPosition =   2  'CenterScreen
   Begin VB.Timer Timer1 
      Interval        =   1
      Left            =   105
      Top             =   105
   End
   Begin VB.PictureBox pctPicToLoad 
      Appearance      =   0  'Flat
      AutoRedraw      =   -1  'True
      AutoSize        =   -1  'True
      BackColor       =   &H00E0E0E0&
      BorderStyle     =   0  'None
      ForeColor       =   &H80000008&
      Height          =   1515
      Left            =   60
      ScaleHeight     =   101
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   101
      TabIndex        =   0
      Top             =   60
      Width           =   1515
      Visible         =   0   'False
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'Copyright(c) 1998, Mika Rantonen / cOWfROg
'EMAIL: [e-mail]

'This project uses one texture map and coordinate manipulation
'to create 'underwater caustics' like animation. I got the idea
'from a Mark Kilgard's sample (http://reality.sgi.com/mjk/tips/),
'but this is not a conversion, it's a completely different project.
'I used Ryan Myers' texture loading code 'cause I didn't have time to
'create my own, thanks. It's also worth knowing that this is
'my first OpenGL project and that every detail ain't too clear for
'me either, but it works.

'The project has one lightsource (the yellow sphere), a textured
'floor and a plain sphere above it



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(0 To 255) As PALETTEENTRY
End Type
Private Type PIXELFORMATDESCRIPTOR
    nSize As Integer
    nVersion As Integer
    dwFlags As Long
    iPixelType As Byte
    cColorBits As Byte
    cRedBits As Byte
    cRedShift As Byte
    cGreenBits As Byte
    cGreenShift As Byte
    cBlueBits As Byte
    cBlueShift As Byte
    cAlphaBits As Byte
    cAlphaShift As Byte
    cAccumBits As Byte
    cAccumRedBits As Byte
    cAccumGreenBits As Byte
    cAccumBlueBits As Byte
    cAccumAlpgaBits As Byte
    cDepthBits As Byte
    cStencilBits As Byte
    cAuxBuffers As Byte
    iLayerType As Byte
    bReserved As Byte
    dwLayerMask As Long
    dwVisibleMask As Long
    dwDamageMask As Long
End Type

Const PFD_TYPE_RGBA = 0
Const PFD_TYPE_COLORINDEX = 1
Const PFD_MAIN_PLANE = 0
Const PFD_DOUBLEBUFFER = 1
Const PFD_DRAW_TO_WINDOW = &H4
Const PFD_SUPPORT_OPENGL = &H20
Const PFD_NEED_PALETTE = &H80

Private Declare Function ChoosePixelFormat Lib "gdi32" (ByVal hDC As Long, pfd As PIXELFORMATDESCRIPTOR) As Long
Private Declare Function CreatePalette Lib "gdi32" (pPal As LOGPALETTE) As Long
Private Declare Sub DeleteObject Lib "gdi32" (hObject As Long)
Private Declare Sub DescribePixelFormat Lib "gdi32" (ByVal hDC As Long, ByVal PixelFormat As Long, ByVal nBytes As Long, pfd As PIXELFORMATDESCRIPTOR)
Private Declare Function GetDC Lib "gdi32" (ByVal hWnd As Long) As Long
Private Declare Function GetPixelFormat Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Sub GetSystemPaletteEntries Lib "gdi32" (ByVal hDC As Long, ByVal start As Long, ByVal entries As Long, ByVal ptrEntries As Long)
Private Declare Sub RealizePalette Lib "gdi32" (ByVal hPalette As Long)
Private Declare Sub SelectPalette Lib "gdi32" (ByVal hDC As Long, ByVal hPalette As Long, ByVal bln As Long)
Private Declare Function SetPixelFormat Lib "gdi32" (ByVal hDC As Long, ByVal i As Long, pfd As PIXELFORMATDESCRIPTOR) As Boolean
Private Declare Sub SwapBuffers Lib "gdi32" (ByVal hDC As Long)
Private Declare Function wglCreateContext Lib "OpenGL32" (ByVal hDC As Long) As Long
Private Declare Sub wglDeleteContext Lib "OpenGL32" (ByVal hContext As Long)
Private Declare Sub wglMakeCurrent Lib "OpenGL32" (ByVal l1 As Long, ByVal l2 As Long)

Dim displayListInited As GLboolean

Dim HaveTexObj As GLboolean
Dim CausticScale As GLfloat
Dim LightPosition(4) As GLfloat
Dim LightDiffuseColor(3) As GLfloat
Dim defaultDiffuceMaterial(3) As GLfloat

'Variables to hold light and scene orientation
Dim lightAngle As Long, lightHeight As Long
Dim angle As GLfloat, angle2 As GLfloat 'In degrees

Dim FloorVertices(2, 3) As GLfloat

Dim hPalette As Long
Dim hGLRC As Long
Dim bitmapImage() As GLubyte
Dim bitmapHeight As GLfloat
Dim bitmapWidth As GLfloat
Dim bitmapFilename As String
Sub SetupPixelFormat(ByVal hDC As Long)
    Dim pfd As PIXELFORMATDESCRIPTOR
    Dim PixelFormat As Integer
    pfd.nSize = Len(pfd)
    pfd.nVersion = 1
    pfd.dwFlags = PFD_SUPPORT_OPENGL Or PFD_DRAW_TO_WINDOW Or PFD_DOUBLEBUFFER Or PFD_TYPE_RGBA
    pfd.iPixelType = PFD_TYPE_RGBA
    pfd.cColorBits = 16
    pfd.cDepthBits = 16
    pfd.iLayerType = PFD_MAIN_PLANE
    PixelFormat = ChoosePixelFormat(hDC, pfd)
    If PixelFormat = 0 Then
     MsgBox "Could not retrieve pixel format!"
     End
    End If
    SetPixelFormat hDC, PixelFormat, pfd
End Sub
Sub SetupPalette(ByVal lhDC As Long)
    Dim PixelFormat As Long
    Dim pfd As PIXELFORMATDESCRIPTOR
    Dim pPal As LOGPALETTE
    Dim PaletteSize As Long
    PixelFormat = GetPixelFormat(lhDC)
    DescribePixelFormat lhDC, PixelFormat, Len(pfd), pfd
    If (pfd.dwFlags And PFD_NEED_PALETTE) <> 0 Then
        PaletteSize = 2 ^ pfd.cColorBits
    Else
        Exit Sub
    End If
    
    pPal.palVersion = &H300
    pPal.palNumEntries = PaletteSize
    Dim redMask As Long
    Dim GreenMask As Long
    Dim BlueMask As Long
    Dim i As Long
    redMask = 2 ^ pfd.cRedBits - 1
    GreenMask = 2 ^ pfd.cGreenBits - 1
    BlueMask = 2 ^ pfd.cBlueBits - 1
    For i = 0 To PaletteSize - 1
        With pPal.palPalEntry(i)
            .peRed = i
            .peGreen = i
            .peBlue = i
            .peFlags = 0
        End With
    Next
    GetSystemPaletteEntries hDC, 0, 256, VarPtr(pPal.palPalEntry(0))
    hPalette = CreatePalette(pPal)
    If hPalette <> 0 Then
        SelectPalette lhDC, hPalette, False
        RealizePalette lhDC
    End If
End Sub

Private Function GetBlue(thedamncolor As Long) As Integer
    
    ' GetBlue: Retrieves the blue value (range 0-255) from the
    ' supplied long color.
    
    Dim all As String, blue As String
    all = Hex$(thedamncolor)
    Select Case Len(all)
        Case 6
            blue = Mid(all, 1, 2)
        Case 5
            blue = Mid(all, 1, 1)
        Case Else
            blue = "00"
    End Select
    GetBlue = CInt(Val("&H" & blue))
End Function

Private Function GetRed(thedamncolor As Long) As Integer

    ' GetRed: Retrieves the red value (range 0-255) from the
    ' supplied long color.

    Dim all As String, red As String
    all = Hex$(thedamncolor)
    Select Case Len(all)
                Case 2
                    red = all
                Case 1
                    red = all
                Case Else
                    red = Mid(all, Len(all) - 1, 2)
    End Select
    GetRed = CInt(Val("&H" & red))
End Function
Private Function GetGreen(thedamncolor As Long) As Integer

    ' GetGreen: Retrieves the green value (range 0-255) from the
    ' supplied long color.

    Dim all As String, green As String
    all = Hex$(thedamncolor)
    Select Case Len(all)
                Case 1
                    green = "00"
                Case 2
                    green = "00"
                Case 3
                    green = Mid(all, 1, 1)
                Case Else
                    green = Mid(all, Len(all) - 3, 2)
    End Select
    GetGreen = CInt(Val("&H" & green))
End Function
Private Sub CreateMapImage()

    ' CreateMapImage: Reads each pixel from the selected bitmap and
    ' plugs it into the texture array.

    bitmapHeight = pctPicToLoad.ScaleHeight             ' Set the array
    bitmapWidth = pctPicToLoad.ScaleWidth               ' size.
    ReDim bitmapImage(2, bitmapHeight - 1, bitmapWidth - 1)
    
    Dim x As Double, y As Double
    Dim c As Long
    
    pctPicToLoad.ScaleMode = 3                  ' Pixel mode... mucho
    frmMain.ScaleMode = 3                       ' important to set both!
    
    For x = 0 To bitmapWidth - 1
        For y = 0 To bitmapHeight - 1
            c = pctPicToLoad.Point(x, y)        ' Returns in long format.
            bitmapImage(0, x, bitmapHeight - y - 1) = GetRed(c)
            bitmapImage(1, x, bitmapHeight - y - 1) = GetGreen(c)
            bitmapImage(2, x, bitmapHeight - y - 1) = GetBlue(c)
        Next
    Next
    
End Sub
Sub DrawScene(Pass As String)
'Caustic coordinates...
Dim sPlane(3) As GLfloat
Dim tPlane(3) As GLfloat
 sPlane(0) = 0.05 * CausticScale
 sPlane(1) = 0.03 * CausticScale
 sPlane(2) = 0.02 * CausticScale
 sPlane(3) = 0
 tPlane(0) = 0
 tPlane(1) = 0.03 * CausticScale
 tPlane(2) = 0.05 * CausticScale
 tPlane(3) = 0.02 * CausticScale

If Pass = "CAUSTIC" Then
 glColor3f 1, 1, 1
 glDisable GL_LIGHTING
 
'Generate the caustics
 glTexGeni GL_S, GL_TEXTURE_GEN_MODE, GL_OBJECT_LINEAR
 glTexGeni GL_T, GL_TEXTURE_GEN_MODE, GL_OBJECT_LINEAR
 glTexGenfv GL_S, GL_OBJECT_PLANE, sPlane(0)
 glTexGenfv GL_T, GL_OBJECT_PLANE, tPlane(0)
 glEnable GL_TEXTURE_GEN_S
 glEnable GL_TEXTURE_GEN_T

End If

'Draw stuff
 DrawFloor Pass
 DrawObject Pass
 
If Pass = "CAUSTIC" Then
    glEnable GL_LIGHTING
    glDisable GL_TEXTURE_GEN_S
    glDisable GL_TEXTURE_GEN_T
End If

End Sub
Sub DrawFloor(Pass As String)
 
If Pass = "NORMAL" Then
'Init texture
 glPixelStorei GL_UNPACK_ALIGNMENT, 1
 glTexImage2D GL_TEXTURE_2D, 0, 3, bitmapWidth, bitmapHeight, 0, GL_RGB, GL_UNSIGNED_BYTE, bitmapImage(0, 0, 0)
    glTexParameterf GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_REPEAT
    glTexParameterf GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_REPEAT
     'You can use GL_NEAREST instead of GL_LINEAR if you want to
     'make the rendering faster, the quality ain't the same though
    glTexParameterf GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_NEAREST
    glTexParameterf GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_NEAREST
     'You can use GL_DECAL instead of GL_MODULATE to see the effect
    glTexEnvf GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_MODULATE
 
Else
 glCallList 1
End If

'Draw the floor
glBegin GL_QUADS
 glNormal3f 0, 1, 0
 glTexCoord2f 0, 0
 glVertex3fv FloorVertices(0, 0)
 glTexCoord2f 0, 2
 glVertex3fv FloorVertices(0, 1)
 glTexCoord2f 2, 2
 glVertex3fv FloorVertices(0, 2)
 glTexCoord2f 2, 0
 glVertex3fv FloorVertices(0, 3)
glEnd

End Sub
Sub DrawObject(Pass As String)
 
If Pass = "NORMAL" Then glDisable GL_TEXTURE_2D
 
'Translate and draw a sphere
glPushMatrix
 glTranslatef 0, 12, 0
 glutSolidSphere 6, 20, 20
glPopMatrix

If Pass = "NORMAL" Then glEnable GL_TEXTURE_2D

End Sub
Sub Display()
'Clear previous stuff
glClear GL_COLOR_BUFFER_BIT Or GL_DEPTH_BUFFER_BIT

'Reposition the light
 LightPosition(0) = 12 * Cos(lightAngle)
 LightPosition(1) = lightHeight
 LightPosition(2) = 12 * Sin(lightAngle)
 LightPosition(3) = 1

glPushMatrix
  'Rotate the scene
  glRotatef angle2, 1, 0, 0
  glRotatef angle, 0, 1, 0
  
  'Position the light again
  glLightfv GL_LIGHT0, GL_POSITION, LightPosition(0)
  drawLightLocation
  
  '1. render (normal)
  DrawScene "NORMAL"
  
   glDepthMask GL_FALSE
   glDepthFunc GL_EQUAL
   'Multiply the source color with the previous color
   'from 1. render...
    glBlendFunc GL_ZERO, GL_SRC_COLOR
    glEnable GL_BLEND
   
   '2. render (now with caustic pattern)
   DrawScene "CAUSTIC"
   
   glDepthMask GL_TRUE
   glDepthFunc GL_LESS
   glDisable GL_BLEND
  
glPopMatrix

SwapBuffers hDC

End Sub
Sub drawLightLocation()
'Draw a sphere to lightsource

glPushMatrix
 glDisable GL_LIGHTING
 glDisable GL_TEXTURE_2D
 glColor3f 1, 1, 0

   glTranslatef LightPosition(0), LightPosition(1), LightPosition(2)
   glutSolidSphere 1, 5, 5
 
 glEnable GL_TEXTURE_2D
 glEnable GL_LIGHTING
glPopMatrix
    
   
End Sub
Private Sub Form_Load()
'Floor
 FloorVertices(0, 0) = -20
 FloorVertices(1, 0) = 0
 FloorVertices(2, 0) = -20
 FloorVertices(0, 1) = -20
 FloorVertices(1, 1) = 0
 FloorVertices(2, 1) = 20
 FloorVertices(0, 2) = 20
 FloorVertices(1, 2) = 0
 FloorVertices(2, 2) = 20
 FloorVertices(0, 3) = 20
 FloorVertices(1, 3) = 0
 FloorVertices(2, 3) = -20
'Light color
 LightDiffuseColor(0) = 1
 LightDiffuseColor(1) = 1.3
 LightDiffuseColor(2) = 1
 LightDiffuseColor(3) = 1
'Material
 defaultDiffuceMaterial(0) = 0.8
 defaultDiffuceMaterial(1) = 0.8
 defaultDiffuceMaterial(2) = 0.8
 defaultDiffuceMaterial(3) = 1
 
'Some variables
 CausticScale = 2
 lightAngle = 0
 lightHeight = 20
 angle = -150
 angle2 = 30
 
   'Load the picture and create a texture array
    pctPicToLoad.Picture = LoadPicture(App.Path + "\caustic.bmp")
    CreateMapImage
        
    Dim hGLRC As Long                   'Bind to the hdc
    SetupPixelFormat hDC
    hGLRC = wglCreateContext(hDC)
    wglMakeCurrent hDC, hGLRC
        
    
    'Correct texture perspective
    glHint GL_PERSPECTIVE_CORRECTION_HINT, GL_NICEST
            
    glMatrixMode GL_PROJECTION
    glLoadIdentity
    glViewport 0, 0, frmMain.ScaleWidth, frmMain.ScaleHeight
    gluPerspective 40, 1, 20, 100
        
    glMatrixMode GL_MODELVIEW
    gluLookAt 0, 8, 60, 0, 8, 0, 0, 1, 0
    
   'Light...
    glEnable GL_LIGHT0
    glLightfv GL_LIGHT0, GL_DIFFUSE, LightDiffuseColor(0)
    glEnable GL_LIGHTING
    glEnable GL_DEPTH_TEST
    glEnable GL_CULL_FACE
                            
     
End Sub
Private Sub Form_Resize()
'Resize the render view
 glViewport 0, 0, frmMain.ScaleWidth, frmMain.ScaleHeight
 Display
 
End Sub
Private Sub Form_Unload(Cancel As Integer)
    If hGLRC <> 0 Then
        wglMakeCurrent 0, 0
        wglDeleteContext hGLRC
    End If
    If hPalette <> 0 Then
        DeleteObject hPalette
    End If
End Sub

Private Sub Timer1_Timer()
Static i As Byte

'The following code changes CausticScale from 2 to 5,
'so you can see the effect of glTexGen
If i = 0 Then
 If CausticScale < 5 Then
  CausticScale = CausticScale + 1
 Else
  i = 1
  CausticScale = CausticScale - 1
 End If
Else
 If CausticScale > 2 Then
  CausticScale = CausticScale - 1
 Else
  i = 0
  CausticScale = CausticScale + 1
 End If
End If

Display

End Sub