home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 5_2007-2008.ISO / data / Zips / Post-Proce2076087182007.psc / mdlMain.bas < prev    next >
BASIC Source File  |  2007-07-19  |  12KB  |  423 lines
  1. Attribute VB_Name = "mdlMain"
  2.  
  3. Option Explicit
  4.  
  5.  
  6. Public Const Pi As Single = 3.14159265358979
  7.  
  8. Public confDevice As D3DPRESENT_PARAMETERS
  9.  
  10. Private objDX As DirectX8
  11. Private objD3D As Direct3D8
  12.  
  13. Public objD3DDev As Direct3DDevice8
  14. Public objD3Dhlp As D3DX8
  15.  
  16. Private txHelp As Direct3DTexture8
  17. Private txOrig As Direct3DTexture8
  18. Private txPass0 As Direct3DTexture8
  19. Private txPass1 As Direct3DTexture8
  20.  
  21. Private mhWalls As clsMesh
  22. Private txWalls As Direct3DTexture8
  23.  
  24. Private mhStatue As clsMesh
  25. Private txStatue As Direct3DTexture8
  26.  
  27. Public camAlpha As Single
  28. Public camBeta As Single
  29. Public camDistance As Single
  30. Public camShift As Single
  31.  
  32. Public psBrightPass As Long
  33. Public psGaussianBlur As Long
  34. Public psTextureBlend As Long
  35.  
  36. Private rtOriginalImage As clsRenderTarget
  37. Public rtBrightPass As clsRenderTarget
  38. Public rtGaussianBlur As clsRenderTarget
  39.  
  40. Private ppBrightPass As clsPostProcessing
  41. Public ppGaussBlur As clsPostProcessing
  42. Private ppFinalBlend As clsPostProcessing
  43.  
  44. Private ppPipelineView As clsPostProcessing
  45.  
  46. Public effSampling As Long
  47. Public effFilter As Long
  48. Public effGauss As Long
  49. Public effBright As Long
  50. Public effBloom As Long
  51.  
  52. Public shwHelp As Long
  53. Public shwWalls As Long
  54. Public shwPipeline As Long
  55.  
  56. Public Sub Initialize()
  57.  
  58.   On Error Resume Next
  59.  
  60.   Set objDX = New DirectX8
  61.   Set objD3D = objDX.Direct3DCreate
  62.   Set objD3Dhlp = New D3DX8
  63.   
  64.   Static confDisplay As D3DDISPLAYMODE
  65.   objD3D.GetAdapterDisplayMode D3DADAPTER_DEFAULT, confDisplay
  66.   
  67.   With confDevice
  68.     .AutoDepthStencilFormat = D3DFMT_D24S8
  69.     .BackBufferCount = 1
  70.     .BackBufferFormat = confDisplay.Format
  71.     .BackBufferHeight = wndRender.ScaleHeight
  72.     .BackBufferWidth = wndRender.ScaleWidth
  73.     .EnableAutoDepthStencil = 1
  74.     .flags = 0
  75.     .FullScreen_PresentationInterval = 0
  76.     .FullScreen_RefreshRateInHz = 0
  77.     .hDeviceWindow = wndRender.hWnd
  78.     .MultiSampleType = D3DMULTISAMPLE_NONE
  79.     .SwapEffect = D3DSWAPEFFECT_DISCARD
  80.     .Windowed = 1
  81.   End With
  82.  
  83.   Set objD3DDev = objD3D.CreateDevice(D3DADAPTER_DEFAULT, D3DDEVTYPE_HAL, confDevice.hDeviceWindow, D3DCREATE_HARDWARE_VERTEXPROCESSING, confDevice)
  84.   If Not Err.Number = 0 Then
  85.     Err.Clear
  86.     MsgBox "Failed to create Direct3DDevice8. Application will now quit.", vbCritical Or vbOKOnly, "Error"
  87.     Shutdown
  88.   End If
  89.  
  90.   
  91.   camDistance = 150
  92.   camAlpha = 35 * Pi / 180
  93.   camBeta = 15 * Pi / 180
  94.   camShift = 50
  95.   
  96.   
  97.   effSampling = 6
  98.   effFilter = 1
  99.   effGauss = 1
  100.   effBright = 1
  101.   effBloom = 1
  102.   
  103.   shwHelp = 1
  104.   shwWalls = 1
  105.   shwPipeline = 1
  106.   
  107.   
  108.   psBrightPass = shCompile(App.Path & "\psh_BrightPass_ps.1.4.txt")
  109.   psGaussianBlur = shCompile(App.Path & "\psh_GaussianBlur_ps.1.4.txt")
  110.   psTextureBlend = shCompile(App.Path & "\psh_TextureBlend_ps.1.1.txt")
  111.  
  112.  
  113.   Set txHelp = txLoad(App.Path & "\texHelp.png")
  114.   Set txOrig = txLoad(App.Path & "\texOriginal.png")
  115.   Set txPass0 = txLoad(App.Path & "\texPass0.png")
  116.   Set txPass1 = txLoad(App.Path & "\texPass1.png")
  117.   Set txWalls = txLoad(App.Path & "\texWalls.png")
  118.   Set txStatue = txLoad(App.Path & "\texStatue.png")
  119.  
  120.  
  121.   Set mhWalls = New clsMesh
  122.   If Not mhWalls.objLoad(App.Path & "\objWalls.obj") Then
  123.     mhWalls.memClear
  124.     MsgBox "Failed to load mesh file: '" & App.Path & "\objWalls.obj" & "'.", vbCritical Or vbOKOnly, "Error"
  125.   End If
  126.  
  127.   Set mhStatue = New clsMesh
  128.   If Not mhStatue.objLoad(App.Path & "\objStatue.obj") Then
  129.     mhStatue.memClear
  130.     MsgBox "Failed to load mesh file: '" & App.Path & "\objStatue.obj" & "'.", vbCritical Or vbOKOnly, "Error"
  131.   End If
  132.  
  133.  
  134.   Set rtOriginalImage = New clsRenderTarget
  135.   rtOriginalImage.rtAquire
  136.   rtOriginalImage.rtCreate confDevice.BackBufferWidth, confDevice.BackBufferHeight
  137.   
  138.   Set rtBrightPass = New clsRenderTarget
  139.   rtBrightPass.rtAquire
  140.   rtBrightPass.rtCreate Int(confDevice.BackBufferWidth / effSampling), Int(confDevice.BackBufferHeight / effSampling)
  141.  
  142.   Set rtGaussianBlur = New clsRenderTarget
  143.   rtGaussianBlur.rtAquire
  144.   rtGaussianBlur.rtCreate Int(confDevice.BackBufferWidth / effSampling), Int(confDevice.BackBufferHeight / effSampling)
  145.  
  146.   Set ppBrightPass = New clsPostProcessing
  147.   ppBrightPass.objCreate
  148.   
  149.   Set ppGaussBlur = New clsPostProcessing
  150.   ppGaussBlur.objCreate5Tap Int(confDevice.BackBufferWidth / effSampling), Int(confDevice.BackBufferHeight / effSampling)
  151.  
  152.   Set ppFinalBlend = New clsPostProcessing
  153.   ppFinalBlend.objCreate
  154.  
  155.   Set ppPipelineView = New clsPostProcessing
  156.  
  157. End Sub
  158.  
  159.  
  160. Public Sub Render()
  161.  
  162.   On Error Resume Next
  163.  
  164.   With objD3DDev
  165.     
  166.     
  167.     'pass0: render scene into full-size rt texture
  168.     If effBloom = 1 Then rtOriginalImage.rtEnable True
  169.     
  170.     .Clear 0, ByVal 0, D3DCLEAR_TARGET Or D3DCLEAR_ZBUFFER, &HFF3F3F3F, 1, 0
  171.     .BeginScene
  172.     
  173.     
  174.     Static camX As Single
  175.     Static camY As Single
  176.     Static camZ As Single
  177.     camX = Sin(camAlpha) * Cos(camBeta) * camDistance
  178.     camY = Sin(camBeta) * camDistance
  179.     camZ = Cos(camAlpha) * Cos(camBeta) * camDistance
  180.     
  181.     
  182.     Static matView As D3DMATRIX
  183.     D3DXMatrixLookAtLH matView, mkVec3f(camX, camY + camShift, camZ), mkVec3f(0, 0 + camShift, 0), mkVec3f(0, 1, 0)
  184.     .SetTransform D3DTS_VIEW, matView
  185.     
  186.     Static matProjection As D3DMATRIX
  187.     D3DXMatrixPerspectiveFovLH matProjection, 1, confDevice.BackBufferHeight / confDevice.BackBufferWidth, 1, 100000
  188.     .SetTransform D3DTS_PROJECTION, matProjection
  189.     
  190.     
  191.     Static iMap As Long
  192.     For iMap = 0 To 4 Step 1
  193.       .SetTextureStageState iMap, D3DTSS_TEXCOORDINDEX, iMap
  194.       If effFilter = 1 Then
  195.         .SetTextureStageState iMap, D3DTSS_MAXANISOTROPY, 16
  196.         .SetTextureStageState iMap, D3DTSS_MAGFILTER, D3DTEXF_ANISOTROPIC
  197.         .SetTextureStageState iMap, D3DTSS_MINFILTER, D3DTEXF_ANISOTROPIC
  198.         .SetTextureStageState iMap, D3DTSS_MIPFILTER, D3DTEXF_ANISOTROPIC
  199.       Else
  200.         .SetTextureStageState iMap, D3DTSS_MAGFILTER, D3DTEXF_POINT
  201.         .SetTextureStageState iMap, D3DTSS_MINFILTER, D3DTEXF_POINT
  202.         .SetTextureStageState iMap, D3DTSS_MIPFILTER, D3DTEXF_POINT
  203.       End If
  204.       .SetTextureStageState iMap, D3DTSS_ADDRESSU, D3DTADDRESS_CLAMP
  205.       .SetTextureStageState iMap, D3DTSS_ADDRESSV, D3DTADDRESS_CLAMP
  206.     Next iMap
  207.     
  208.     
  209.     .SetRenderState D3DRS_LIGHTING, 0
  210.     .SetRenderState D3DRS_CULLMODE, D3DCULL_CCW
  211.   
  212.     
  213.     .SetPixelShader 0
  214.   
  215.   
  216.     If shwWalls = 1 Then
  217.       .SetTexture 0, txWalls
  218.       If Not mhWalls.objRender Then
  219.         MsgBox "Error rendering 'Walls' mesh. Application will now quit.", vbCritical Or vbOKOnly, "Error"
  220.         Shutdown
  221.       End If
  222.     End If
  223.   
  224.     .SetTexture 0, txStatue
  225.     If Not mhStatue.objRender Then
  226.       MsgBox "Error rendering 'Statue' mesh. Application will now quit.", vbCritical Or vbOKOnly, "Error"
  227.       Shutdown
  228.     End If
  229.   
  230.   
  231.     .EndScene
  232.     
  233.     If effBloom = 1 Then
  234.       
  235.       rtOriginalImage.rtEnable False
  236.     
  237.     
  238.       'pass1: render original image into lower resolution rt texture with bright pass shader
  239.       If effBright = 1 Then
  240.         rtBrightPass.rtEnable True
  241.         .BeginScene
  242.         .SetPixelShader psBrightPass
  243.         .SetTexture 0, rtOriginalImage.objTexture
  244.         If Not ppBrightPass.objRender Then
  245.           MsgBox "Error rendering 'Bright Pass' post-processing effect. Application will now quit.", vbCritical Or vbOKOnly, "Error"
  246.           Shutdown
  247.         End If
  248.         .EndScene
  249.         rtBrightPass.rtEnable False
  250.       End If
  251.     
  252.     
  253.       If effGauss = 1 Then
  254.         
  255.         'pass2: perform a gaussian blur on bright passed (or original - when b.pass disabled) rt texture
  256.         'using 5 texture with UV coord shifting (.objCreate5Tap)
  257.         rtGaussianBlur.rtEnable True
  258.         .BeginScene
  259.         .SetPixelShader psGaussianBlur
  260.         For iMap = 0 To 4 Step 1
  261.           If effBright = 1 Then
  262.             .SetTexture iMap, rtBrightPass.objTexture
  263.           Else
  264.             .SetTexture iMap, rtOriginalImage.objTexture
  265.           End If
  266.         Next iMap
  267.         If Not ppGaussBlur.objRender Then
  268.           MsgBox "Error rendering 'Gaussian Blur' post-processing effect. Application will now quit.", vbCritical Or vbOKOnly, "Error"
  269.           Shutdown
  270.         End If
  271.         .EndScene
  272.         rtGaussianBlur.rtEnable False
  273.         
  274.       End If
  275.     
  276.     
  277.       'pass3: blend original image with stretched back to full size gaussian output texture
  278.       .BeginScene
  279.       .SetPixelShader psTextureBlend
  280.       If effGauss = 1 Then
  281.         .SetTexture 0, rtGaussianBlur.objTexture
  282.       Else
  283.         If effBright = 1 Then
  284.           .SetTexture 0, rtBrightPass.objTexture
  285.         Else
  286.           .SetTexture 0, rtOriginalImage.objTexture
  287.         End If
  288.       End If
  289.       .SetTexture 1, rtOriginalImage.objTexture
  290.       If Not ppFinalBlend.objRender Then
  291.         MsgBox "Error rendering 'Final Blend' post-processing effect. Application will now quit.", vbCritical Or vbOKOnly, "Error"
  292.         Shutdown
  293.       End If
  294.       
  295.       
  296.       If shwPipeline = 1 Then
  297.         
  298.         ppPipelineView.memClear
  299.         ppPipelineView.objCreateUser -0.95, 0.95 - 0.35 * 0, -0.65, 0.65 - 0.35 * 0
  300.         .SetPixelShader psTextureBlend
  301.         .SetTexture 1, txOrig
  302.         .SetTexture 0, rtOriginalImage.objTexture
  303.         ppPipelineView.objRender
  304.         
  305.         If effBright = 1 Then
  306.           ppPipelineView.memClear
  307.           ppPipelineView.objCreateUser -0.95, 0.95 - 0.35 * 1, -0.65, 0.65 - 0.35 * 1
  308.           .SetPixelShader psTextureBlend
  309.           .SetTexture 1, txPass0
  310.           .SetTexture 0, rtBrightPass.objTexture
  311.           ppPipelineView.objRender
  312.         End If
  313.       
  314.         If effGauss = 1 Then
  315.           ppPipelineView.memClear
  316.           If effBright = 1 Then
  317.             ppPipelineView.objCreateUser -0.95, 0.95 - 0.35 * 2, -0.65, 0.65 - 0.35 * 2
  318.           Else
  319.             ppPipelineView.objCreateUser -0.95, 0.95 - 0.35 * 1, -0.65, 0.65 - 0.35 * 1
  320.           End If
  321.           .SetPixelShader psTextureBlend
  322.           .SetTexture 1, txPass1
  323.           .SetTexture 0, rtGaussianBlur.objTexture
  324.           ppPipelineView.objRender
  325.         End If
  326.       
  327.       End If
  328.       
  329.       
  330.       .EndScene
  331.     
  332.     
  333.     End If
  334.     
  335.     .SetTexture 1, Nothing
  336.       
  337.     If shwHelp = 1 Then
  338.       ppPipelineView.memClear
  339.       ppPipelineView.objCreateUser 0.3, -0.5, 1, -1
  340.       .SetPixelShader 0
  341.       .SetTexture 0, txHelp
  342.       .SetRenderState D3DRS_ALPHABLENDENABLE, 1
  343.       .SetRenderState D3DRS_SRCBLEND, 1
  344.       .SetRenderState D3DRS_DESTBLEND, 3
  345.       ppPipelineView.objRender
  346.       .SetRenderState D3DRS_ALPHABLENDENABLE, 0
  347.     End If
  348.     
  349.     .SetTexture 0, Nothing
  350.     
  351.     
  352.     If Not .TestCooperativeLevel = 0 Then
  353.       MsgBox "Cooperative level lost. Application will now quit.", vbCritical Or vbOKOnly, "Error"
  354.       Shutdown
  355.     Else
  356.       .Present ByVal 0, ByVal 0, 0, ByVal 0
  357.     End If
  358.   End With
  359.  
  360.  
  361.   If Not Err.Number = 0 Then
  362.     Err.Clear
  363.     MsgBox "Unexpected error occured in rendering pipeline. Application will now quit.", vbCritical Or vbOKOnly, "Error"
  364.     Shutdown
  365.   End If
  366.  
  367.  
  368. End Sub
  369.  
  370.  
  371. Public Sub Shutdown()
  372.  
  373.   On Error Resume Next
  374.  
  375.   Set txPass0 = Nothing
  376.   Set txPass1 = Nothing
  377.   Set txOrig = Nothing
  378.   Set txHelp = Nothing
  379.  
  380.   ppPipelineView.memClear
  381.   Set ppPipelineView = Nothing
  382.   
  383.   ppBrightPass.memClear
  384.   Set ppBrightPass = Nothing
  385.   
  386.   ppGaussBlur.memClear
  387.   Set ppGaussBlur = Nothing
  388.   
  389.   ppFinalBlend.memClear
  390.   Set ppFinalBlend = Nothing
  391.  
  392.   rtOriginalImage.rtDestroy True
  393.   rtBrightPass.rtDestroy True
  394.   rtGaussianBlur.rtDestroy True
  395.   
  396.   Set rtOriginalImage = Nothing
  397.   Set rtBrightPass = Nothing
  398.   Set rtGaussianBlur = Nothing
  399.  
  400.   Set txWalls = Nothing
  401.  
  402.   mhWalls.memClear
  403.   Set mhWalls = Nothing
  404.  
  405.   Set txStatue = Nothing
  406.  
  407.   mhStatue.memClear
  408.   Set mhStatue = Nothing
  409.   
  410.   objD3DDev.DeletePixelShader psBrightPass
  411.   objD3DDev.DeletePixelShader psGaussianBlur
  412.   objD3DDev.DeletePixelShader psTextureBlend
  413.  
  414.   Set objD3DDev = Nothing
  415.   Set objD3D = Nothing
  416.   Set objDX = Nothing
  417.   
  418.   If Not Err.Number = 0 Then Err.Clear
  419.   End
  420.  
  421. End Sub
  422.  
  423.