diff --git a/appDodge/Main.hs b/appDodge/Main.hs index 0d8f79d43..d77d5ab2f 100644 --- a/appDodge/Main.hs +++ b/appDodge/Main.hs @@ -20,7 +20,7 @@ import Dodge.Render import Dodge.SoundLogic.LoadSound import Dodge.TestString import Dodge.Update -import qualified IntMapHelp as IM +--import qualified IntMapHelp as IM import Loop import Music --import Picture @@ -30,7 +30,7 @@ import Preload.Render import SDL (($=)) import qualified SDL -import qualified SDL.Mixer as Mix +--import qualified SDL.Mixer as Mix import Sound import System.Directory @@ -59,7 +59,7 @@ winConfig x y winpos = { SDL.windowGraphicsContext = SDL.OpenGLContext $ SDL.defaultOpenGL - { SDL.glProfile = SDL.Core SDL.Normal 4 3 + { SDL.glProfile = SDL.Core SDL.Normal 4 5 , SDL.glColorPrecision = SDL.V4 8 8 8 8 } , SDL.windowPosition = theWinPos @@ -128,13 +128,18 @@ doSideEffects u = do doPreload :: IO PreloadData doPreload = do + putStrLn "Start Render preload" rData <- preloadRender + putStrLn "Start sound preload" lChunks <- loadSounds - lMusic <- loadMusic - Mix.playMusic Mix.Forever (lMusic IM.! 0) + putStrLn "Skip music preload!" +-- lMusic <- loadMusic +-- Mix.playMusic Mix.Forever (lMusic IM.! 0) + putStrLn "Return PreloadData" return PreloadData { _renderData = rData , _soundData = SoundData{_loadedChunks = lChunks} - , _musicData = MusicData{_loadedMusic = lMusic} + --, _musicData = MusicData{_loadedMusic = lMusic} + , _musicData = MusicData{_loadedMusic = undefined} } diff --git a/data/normalMaps/diffuseArray.png b/data/normalMaps/diffuseArray.png index 367469a0b..428060a29 100644 Binary files a/data/normalMaps/diffuseArray.png and b/data/normalMaps/diffuseArray.png differ diff --git a/data/normalMaps/normalArray.png b/data/normalMaps/normalArray.png index e4f7c40f9..85ebb0c90 100644 Binary files a/data/normalMaps/normalArray.png and b/data/normalMaps/normalArray.png differ diff --git a/package.yaml b/package.yaml index 265894045..0c1c30453 100644 --- a/package.yaml +++ b/package.yaml @@ -21,31 +21,31 @@ description: Description text, TODO link to README.md dependencies: - base >= 4.7 && < 5 +- aeson +- aeson-pretty - containers -- unordered-containers +- deepseq +- dlist +- directory +- extra +- foldl - graphviz -- template-haskell -- sdl2 -- sdl2-mixer - OpenGLRaw - text - bytestring - lens - mtl - fgl -- random - JuicyPixels -- vector -- dlist -- deepseq +- random +- sdl2 +- sdl2-mixer +- template-haskell - transformers -- foldl +- unordered-containers +- vector - linear -- aeson -- aeson-pretty #- store -- directory -- extra - primitive - monad-parallel - parallel @@ -71,7 +71,7 @@ executables: #- -eventlog - -rtsopts - -with-rtsopts=+RTS - - -with-rtsopts=-N2 + - -with-rtsopts=-N #- -with-rtsopts=-l - -flate-dmd-anal - -fno-liberate-case diff --git a/shader/compute/multiplyArray.comp b/shader/compute/multiplyArray.comp new file mode 100644 index 000000000..ae4d413c1 --- /dev/null +++ b/shader/compute/multiplyArray.comp @@ -0,0 +1,7 @@ +#version 450 core +layout(local_size_x= 1, local_size_y=1) in; +uniform sampler2DArray screenTexture; +layout(rgba8, binding = 5) uniform restrict writeonly image2D img_output; +void main() +{ +} diff --git a/shader/compute/shadow.comp b/shader/compute/shadow.comp new file mode 100644 index 000000000..404d913f2 --- /dev/null +++ b/shader/compute/shadow.comp @@ -0,0 +1,40 @@ +#version 450 core +layout(local_size_x= 16, local_size_y=1) in; +layout(rgba8, binding = 5) uniform restrict writeonly image2D img_output; +layout (std140, binding = 1) uniform LightsBlock +{ + vec4 posBool[20]; + vec4 colRad[20]; +} ; +layout (binding = 0) uniform sampler2D posTexture; +layout (binding = 1) uniform sampler2D normals; +void main () +{ + shared vec3[20] larray; + uint i = gl_LocalInvocationID.x; + vec3 lightamount = vec3(0,0,0); + ivec2 pixel_coords = ivec2(gl_GlobalInvocationID.xy); + vec2 tex_coords = vec2((4*pixel_coords.x+4)/800.0, (4*pixel_coords.y+4)/835.0); + vec3 pos = texture(posTexture,tex_coords).xyz; + vec3 lightPos = posBool[i].xyz; + vec4 lumRad = colRad[i]; + vec3 distVec = lightPos - pos; + float dist = dot (distVec,distVec); + if (dist > lumRad.a) { } + else + { + float x = 1 - dist / lumRad.a; + vec3 norm = texture(normals,tex_coords).xyz; + float y1 = dot(normalize(norm), normalize(distVec)); + float y = float(y1 > 0 ? 1 : 0); + lightamount = y*x*lumRad.rgb; + + } + larray[i] = lightamount; + if (i == 0) + //{ vec3 inverselight = 1 - lightamount; + { vec3 inverselight = vec3(0,0,0); +// for (uint j=1 ; j < 20; ++j) {inverselight = inverselight * (1 - larray[j]);} + imageStore(img_output, pixel_coords, vec4(inverselight,1)); + } +} diff --git a/shader/shadow/light.frag b/shader/shadow/light.frag index 7ea159f59..6b38fe6ed 100644 --- a/shader/shadow/light.frag +++ b/shader/shadow/light.frag @@ -32,5 +32,5 @@ float rad = lumRad.a; float y = y2; float x = 1 - dist / rad; vec3 c = y* (x * x * x) * lumRad.rgb; - fColor = vec4(c, 0); + fColor = vec4(c, 1); } diff --git a/src/Color.hs b/src/Color.hs index 444b8cd07..e5cf9ff67 100644 --- a/src/Color.hs +++ b/src/Color.hs @@ -1,35 +1,11 @@ ---{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE StrictData #-} +module Color ( + module Color, + module Color.Data, +) where -module Color where - -import Data.Aeson -import Data.Aeson.TH +import Color.Data import Geometry - -data PaletteColor - = RED - | GREEN - | BLUE - | YELLOW - | CYAN - | MAGENTA - | ROSE - | VIOLET - | AZURE - | AQUAMARINE - | CHARTREUSE - | ORANGE - | WHITE - | BLACK - deriving (Eq, Ord, Enum, Show, Read) --Generic, Flat) - -type RGBA = Point4 - -type Color = Point4 +import Control.Lens withAlpha :: Float -> RGBA -> RGBA {-# INLINE withAlpha #-} @@ -165,4 +141,5 @@ numColor _ = toV4 (1, 1, 1, 1) light4 :: Color -> Color light4 = light . light . light . light -deriveJSON defaultOptions ''PaletteColor +toColor256 :: Color -> Color256 +toColor256 = over each floor . (255 *) . normalizeColor diff --git a/src/Color/Data.hs b/src/Color/Data.hs new file mode 100644 index 000000000..9b9c2b7f3 --- /dev/null +++ b/src/Color/Data.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE StrictData #-} +--{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TemplateHaskell #-} + +module Color.Data where + +import Data.Aeson +import Data.Aeson.TH +import Data.Word +import Geometry + +data PaletteColor + = RED + | GREEN + | BLUE + | YELLOW + | CYAN + | MAGENTA + | ROSE + | VIOLET + | AZURE + | AQUAMARINE + | CHARTREUSE + | ORANGE + | WHITE + | BLACK + deriving (Eq, Ord, Enum, Show, Read) --Generic, Flat) + +type RGBA = Point4 + +type Color = Point4 + +type Color256 = V4 Word8 + +deriveJSON defaultOptions ''PaletteColor diff --git a/src/Data/Preload/Render.hs b/src/Data/Preload/Render.hs index 1cfa16312..73217aa4e 100644 --- a/src/Data/Preload/Render.hs +++ b/src/Data/Preload/Render.hs @@ -11,7 +11,8 @@ import Graphics.GL.Core45 import Shader.Data data RenderData = RenderData - { _lightingWallShadShader :: Shader + { _computeShadowShader :: GLuint + , _lightingWallShadShader :: Shader , _lightingLineShadowShader :: Shader , _lightingCapShader :: Shader , _lightingTextureShader :: Shader diff --git a/src/Dodge/Data/Config.hs b/src/Dodge/Data/Config.hs index e86d1e339..d0737b64b 100644 --- a/src/Dodge/Data/Config.hs +++ b/src/Dodge/Data/Config.hs @@ -100,6 +100,7 @@ data ShadowRendering | NoObjShads | NoShadows | NoLighting + | ComputeShader deriving (Show, Eq, Ord, Enum, Bounded) data RoomClipping = NoRoomClipBoundaries | AllRoomClipBoundaries | IntersectingRoomClipBoundaries diff --git a/src/Dodge/Floor.hs b/src/Dodge/Floor.hs index 31b8eaabe..5ea877534 100644 --- a/src/Dodge/Floor.hs +++ b/src/Dodge/Floor.hs @@ -15,6 +15,12 @@ import Dodge.Tree import LensHelp import RandomHelp +startWorldTreeTest :: Annotation +startWorldTreeTest = + OnwardList $ + [ IntAnno $ AnTree . startRoom + ] + initialAnoTree :: Annotation initialAnoTree = OnwardList $ @@ -103,4 +109,5 @@ initialAnoTree = -- | A test level tree. initialRoomTree :: State (StdGen, Int) (MetaTree Room String) -initialRoomTree = annoToRoomTree initialAnoTree +--initialRoomTree = annoToRoomTree initialAnoTree +initialRoomTree = annoToRoomTree startWorldTreeTest diff --git a/src/Dodge/Placement/Instance/Wall.hs b/src/Dodge/Placement/Instance/Wall.hs index 2c48a6660..f370eaf1d 100644 --- a/src/Dodge/Placement/Instance/Wall.hs +++ b/src/Dodge/Placement/Instance/Wall.hs @@ -91,7 +91,7 @@ baseBlockPane = --, _wlColor = greyN 0.5 , _wlColor = dark $ dark orange --, _wlOpacity = Opaque 10 - , _wlOpacity = Opaque 14 + , _wlOpacity = Opaque 17 , _wlUnshadowed = True , _wlFireThrough = True , _wlPenetrable = True diff --git a/src/Dodge/Render.hs b/src/Dodge/Render.hs index af7f8881b..c00303755 100644 --- a/src/Dodge/Render.hs +++ b/src/Dodge/Render.hs @@ -209,6 +209,9 @@ doDrawing' win pdata u = do pdata glColorMask GL_TRUE GL_TRUE GL_TRUE GL_TRUE --apply lightmap to base buffer + glDisable GL_CULL_FACE + glDepthFunc GL_ALWAYS + glDepthMask GL_FALSE glBindFramebuffer GL_FRAMEBUFFER (pdata ^. fboBase . _1 . unFBO) glBindTextureUnit 0 (pdata ^. fboLighting . _2 . unTO) glEnable GL_BLEND @@ -244,100 +247,100 @@ doDrawing' win pdata u = do replicateM_ 2 $ pingPongBetween (_fboHalf1 pdata) (_fboHalf2 pdata) (_bloomBlurShader pdata) glEnable GL_BLEND setViewport _graphics_world_resolution cfig - --draw clouds onto cloud buffer - glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboCloud pdata))) - glDepthFunc GL_LEQUAL - glDepthMask GL_FALSE - --blendFunc $= (SrcAlphaSaturate,One) - --blendColor $= Color4 0.5 0.5 0.5 0.5 - --blendFuncSeparate $= ((SrcAlphaSaturate,One) , (One,OneMinusSrcAlpha)) - --blendFuncSeparate $= ((SrcAlpha, OneMinusSrcAlpha), (One, OneMinusSrcAlpha)) - --glBlendFuncSeparate GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA GL_ONE GL_ONE_MINUS_SRC_ALPHA - glBlendFuncSeparate GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA GL_ONE_MINUS_DST_ALPHA GL_ONE - --glBlendFuncSeparate GL_SRC_ALPHA_SATURATE GL_ONE_MINUS_SRC_ALPHA GL_ONE GL_ONE_MINUS_SRC_ALPHA - --glBlendFunc GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA - withArray [GL_COLOR_ATTACHMENT0, GL_NONE] $ \ptr -> glDrawBuffers 2 ptr - withArray [0.5, 0.5, 0.5, 0] $ \ptr -> - glClearNamedFramebufferfv - (pdata ^. fboCloud . _1 . unFBO) - GL_COLOR - 0 - ptr - -- renderLayer MidLayer shadV layerCounts - glUseProgram (pdata ^. cloudShader . shaderUINT) - glBindVertexArray $ pdata ^. cloudShader . shaderVAO . vaoName - glDrawElements - (pdata ^. cloudShader . shaderPrimitive . unPrimitiveMode) - (fromIntegral nCloudIs) - GL_UNSIGNED_SHORT - nullPtr - drawShader (_windowShader pdata) nWins - when (_graphics_cloud_shadows cfig) $ do - ----render transparency depths - glDepthMask GL_TRUE - glDepthFunc GL_ALWAYS - glDisable GL_BLEND - withArray [GL_NONE, GL_COLOR_ATTACHMENT1, GL_COLOR_ATTACHMENT2] $ \ptr -> glDrawBuffers 3 ptr - withArray [0, 0, 0, 0] $ \ptr -> - glClearNamedFramebufferfv - (pdata ^. fboCloud . _1 . unFBO) - GL_COLOR - 1 - ptr - withArray [0, 0, 0, 0] $ \ptr -> - glClearNamedFramebufferfv - (pdata ^. fboCloud . _1 . unFBO) - GL_COLOR - 2 - ptr - glEnable GL_BLEND - -- we sum the positions weighted by alpha, and sum the alpha - glBlendFuncSeparatei 1 GL_SRC_ALPHA GL_ONE GL_ONE GL_ONE - -- and sum the normals weighted by alpha - glBlendFunci 2 GL_SRC_ALPHA GL_ONE - glUseProgram (pdata ^. cloudShader . shaderUINT) - glBindVertexArray $ pdata ^. cloudShader . shaderVAO . vaoName - glDepthMask GL_TRUE - glDrawElements - (pdata ^. cloudShader . shaderPrimitive . unPrimitiveMode) - (fromIntegral nCloudIs) - GL_UNSIGNED_SHORT - nullPtr - drawShader (_windowShader pdata) nWins - glBindFramebuffer GL_FRAMEBUFFER (pdata ^. fboPos . _1 . unFBO) - withArray [0, 0, 0, 0] $ \ptr -> - glClearNamedFramebufferfv - (pdata ^. fboPos . _1 . unFBO) - GL_COLOR - 0 - ptr - glBindTextureUnit 0 (pdata ^. fboCloud . _2 . _2 . unTO) - glDepthMask GL_FALSE - drawShader (pdata ^. alphaDivideShader) 4 - ----draw lightmap for cloud buffer - glDepthFunc GL_LESS - glEnable GL_BLEND - glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboLighting pdata))) - createLightMap - cfig - (fromIntegral trueNWalls) - nSilIndices - nIndices - (pdata ^. fboPos . _2) - (pdata ^. fboCloud . _2 . _3) - lightPoints - pdata - glInvalidateBufferData (pdata ^. vboShapes . vboName) - --apply lightmap to cloud buffer - glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboCloud pdata))) - glDepthMask GL_FALSE - withArray [GL_COLOR_ATTACHMENT0, GL_NONE] $ \ptr -> glDrawBuffers 2 ptr - glDepthFunc GL_ALWAYS - glBindTextureUnit 0 (_unTO . snd $ _fboLighting pdata) - glEnable GL_BLEND - glBlendFuncSeparate GL_ZERO GL_ONE_MINUS_SRC_COLOR GL_ZERO GL_ONE - drawShader (_fullscreenShader pdata) 4 - glBlendFunc GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA +-- --draw clouds onto cloud buffer +-- glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboCloud pdata))) +-- glDepthFunc GL_LEQUAL +-- glDepthMask GL_FALSE +-- --blendFunc $= (SrcAlphaSaturate,One) +-- --blendColor $= Color4 0.5 0.5 0.5 0.5 +-- --blendFuncSeparate $= ((SrcAlphaSaturate,One) , (One,OneMinusSrcAlpha)) +-- --blendFuncSeparate $= ((SrcAlpha, OneMinusSrcAlpha), (One, OneMinusSrcAlpha)) +-- --glBlendFuncSeparate GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA GL_ONE GL_ONE_MINUS_SRC_ALPHA +-- glBlendFuncSeparate GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA GL_ONE_MINUS_DST_ALPHA GL_ONE +-- --glBlendFuncSeparate GL_SRC_ALPHA_SATURATE GL_ONE_MINUS_SRC_ALPHA GL_ONE GL_ONE_MINUS_SRC_ALPHA +-- --glBlendFunc GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA +-- withArray [GL_COLOR_ATTACHMENT0, GL_NONE] $ \ptr -> glDrawBuffers 2 ptr +-- withArray [0.5, 0.5, 0.5, 0] $ \ptr -> +-- glClearNamedFramebufferfv +-- (pdata ^. fboCloud . _1 . unFBO) +-- GL_COLOR +-- 0 +-- ptr +-- -- renderLayer MidLayer shadV layerCounts +-- glUseProgram (pdata ^. cloudShader . shaderUINT) +-- glBindVertexArray $ pdata ^. cloudShader . shaderVAO . vaoName +-- glDrawElements +-- (pdata ^. cloudShader . shaderPrimitive . unPrimitiveMode) +-- (fromIntegral nCloudIs) +-- GL_UNSIGNED_SHORT +-- nullPtr +-- drawShader (_windowShader pdata) nWins +-- when (_graphics_cloud_shadows cfig) $ do +-- ----render transparency depths +-- glDepthMask GL_TRUE +-- glDepthFunc GL_ALWAYS +-- glDisable GL_BLEND +-- withArray [GL_NONE, GL_COLOR_ATTACHMENT1, GL_COLOR_ATTACHMENT2] $ \ptr -> glDrawBuffers 3 ptr +-- withArray [0, 0, 0, 0] $ \ptr -> +-- glClearNamedFramebufferfv +-- (pdata ^. fboCloud . _1 . unFBO) +-- GL_COLOR +-- 1 +-- ptr +-- withArray [0, 0, 0, 0] $ \ptr -> +-- glClearNamedFramebufferfv +-- (pdata ^. fboCloud . _1 . unFBO) +-- GL_COLOR +-- 2 +-- ptr +-- glEnable GL_BLEND +-- -- we sum the positions weighted by alpha, and sum the alpha +-- glBlendFuncSeparatei 1 GL_SRC_ALPHA GL_ONE GL_ONE GL_ONE +-- -- and sum the normals weighted by alpha +-- glBlendFunci 2 GL_SRC_ALPHA GL_ONE +-- glUseProgram (pdata ^. cloudShader . shaderUINT) +-- glBindVertexArray $ pdata ^. cloudShader . shaderVAO . vaoName +-- glDepthMask GL_TRUE +-- glDrawElements +-- (pdata ^. cloudShader . shaderPrimitive . unPrimitiveMode) +-- (fromIntegral nCloudIs) +-- GL_UNSIGNED_SHORT +-- nullPtr +-- drawShader (_windowShader pdata) nWins +-- glBindFramebuffer GL_FRAMEBUFFER (pdata ^. fboPos . _1 . unFBO) +-- withArray [0, 0, 0, 0] $ \ptr -> +-- glClearNamedFramebufferfv +-- (pdata ^. fboPos . _1 . unFBO) +-- GL_COLOR +-- 0 +-- ptr +-- glBindTextureUnit 0 (pdata ^. fboCloud . _2 . _2 . unTO) +-- glDepthMask GL_FALSE +-- drawShader (pdata ^. alphaDivideShader) 4 +-- ----draw lightmap for cloud buffer +-- glDepthFunc GL_LESS +-- glEnable GL_BLEND +-- glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboLighting pdata))) +-- createLightMap +-- cfig +-- (fromIntegral trueNWalls) +-- nSilIndices +-- nIndices +-- (pdata ^. fboPos . _2) +-- (pdata ^. fboCloud . _2 . _3) +-- lightPoints +-- pdata +-- glInvalidateBufferData (pdata ^. vboShapes . vboName) +-- --apply lightmap to cloud buffer +-- glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboCloud pdata))) +-- glDepthMask GL_FALSE +-- withArray [GL_COLOR_ATTACHMENT0, GL_NONE] $ \ptr -> glDrawBuffers 2 ptr +-- glDepthFunc GL_ALWAYS +-- glBindTextureUnit 0 (_unTO . snd $ _fboLighting pdata) +-- glEnable GL_BLEND +-- glBlendFuncSeparate GL_ZERO GL_ONE_MINUS_SRC_COLOR GL_ZERO GL_ONE +-- drawShader (_fullscreenShader pdata) 4 +-- glBlendFunc GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA -- bind base buffer for drawing bloom then clouds glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboBase pdata))) --Draw blurred bloom onto base buffer @@ -346,9 +349,9 @@ doDrawing' win pdata u = do glBindTextureUnit 0 (_unTO . snd $ _fboHalf1 pdata) drawShader (_fullscreenShader pdata) 4 glBlendFunc GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA - --draw shadowed clouds onto base buffer - glBindTextureUnit 0 (pdata ^. fboCloud . _2 . _1 . unTO) - drawShader (_fullscreenShader pdata) 4 +-- --draw shadowed clouds onto base buffer +-- glBindTextureUnit 0 (pdata ^. fboCloud . _2 . _1 . unTO) +-- drawShader (_fullscreenShader pdata) 4 --set viewport for radial distortion --setViewportSize (round winx) (round winy) setViewport (const FullRes) cfig diff --git a/src/Dodge/TestString.hs b/src/Dodge/TestString.hs index 6d06118a4..feaeded2e 100644 --- a/src/Dodge/TestString.hs +++ b/src/Dodge/TestString.hs @@ -19,6 +19,7 @@ import Dodge.Data.Universe testStringInit :: Universe -> [String] testStringInit u = [show $ u ^. uvWorld . input . smoothScrollAmount , show $ getSmoothScrollValue (u ^. uvWorld . input) + , show (u ^. uvConfig . windowX) ++ " " ++ show (u ^. uvConfig . windowY) ] -- [show $ length $ lightsToRender (u ^. uvConfig) (u ^. uvWorld . wCam) -- (u ^. uvWorld . cWorld . lWorld) diff --git a/src/Picture/Base.hs b/src/Picture/Base.hs index f49537430..44a6234a8 100644 --- a/src/Picture/Base.hs +++ b/src/Picture/Base.hs @@ -201,7 +201,8 @@ stackText = mconcat . zipWith (\y s -> translate 0 y $ centerText s) [0, 100 ..] text :: String -> Picture {-# INLINE text #-} -text = translate (-50) (-100) . drawText (10) +--text = translate (-50) (-100) . drawText (10) +text = translate (-50) (-100) . drawText (-10) drawText :: Float -> String -> [Verx] drawText gap = map f . stringToList gap diff --git a/src/Preload/Render.hs b/src/Preload/Render.hs index 9868a4df5..c3e456c7e 100644 --- a/src/Preload/Render.hs +++ b/src/Preload/Render.hs @@ -6,20 +6,20 @@ module Preload.Render ( ) where import Control.Concurrent -import Shader.AuxAddition -import Shape.Data -import GLHelp import Control.Lens import Control.Monad import Data.Preload.Render import qualified Data.Vector.Mutable as MV import Foreign import Framebuffer.Setup +import GLHelp +import Graphics.GL.Core45 import Shader +import Shader.AuxAddition import Shader.Compile import Shader.Data import Shader.Parameters -import Graphics.GL.Core45 +import Shape.Data {- BINDING LIST: 0 base @@ -30,24 +30,46 @@ import Graphics.GL.Core45 preloadRender :: IO RenderData preloadRender = do + putStrLn "Number cores available:" + getNumCapabilities >>= print + + forM_ [0, 1, 2] $ \i -> do + putStrLn $ "GL_MAX_COMPUTE_WORK_GROUP_COUNT " ++ show i + alloca $ \ptr -> do + glGetIntegeri_v GL_MAX_COMPUTE_WORK_GROUP_COUNT i ptr + x <- peek ptr + putStrLn $ show x + + forM_ [0, 1, 2] $ \i -> do + putStrLn $ "GL_MAX_COMPUTE_WORK_GROUP_SIZE " ++ show i + alloca $ \ptr -> do + glGetIntegeri_v GL_MAX_COMPUTE_WORK_GROUP_SIZE i ptr + x <- peek ptr + putStrLn $ show x + putStrLn $ "GL_MAX_COMPUTE_WORK_GROUP_INVOCATIONS" + alloca $ \ptr -> do + glGetIntegerv GL_MAX_COMPUTE_WORK_GROUP_INVOCATIONS ptr + x <- peek ptr + putStrLn $ show x + -- set up uniform buffer object + putStrLn "Setup UBO" theUBO <- mglCreate glCreateBuffers glNamedBufferData theUBO 64 nullPtr GL_STREAM_DRAW glBindBufferBase GL_UNIFORM_BUFFER 0 theUBO - getNumCapabilities >>= print - --- orthonormalUBO <- mglCreate glCreateBuffers --- withArray idMat $ \ptr -> --- glNamedBufferStorage orthonormalUBO 64 ptr 0 + -- orthonormalUBO <- mglCreate glCreateBuffers + -- withArray idMat $ \ptr -> + -- glNamedBufferStorage orthonormalUBO 64 ptr 0 lightsubo <- mglCreate glCreateBuffers glNamedBufferData lightsubo 640 nullPtr GL_STREAM_DRAW glBindBufferBase GL_UNIFORM_BUFFER 1 lightsubo -- setup shape geometry/cap VBO and two VAOs + putStrLn "Setup shape VBO, VAO, EBO" shVBO <- setupVBO nShapeVerxComp - shPosVAO <- setupVAOUsingVBO [4] shVBO + shPosVAO <- setupVAOUsingVBO [4] shVBO shEBO <- setupEBO shPosVAO -- note the shape shader vao is distinct from the position vao, but they -- share an EBO @@ -55,41 +77,52 @@ preloadRender = do glVertexArrayElementBuffer (shapeshader ^. shaderVAO . vaoName) (shEBO ^. eboName) --setup silhouette edge VAO - shedgevao <- setupVAOUsingVBO [4] shVBO + putStrLn "Setup silhouette VAO, EBO" + shedgevao <- setupVAOUsingVBO [4] shVBO shedgeebo <- setupEBO shedgevao + putStrLn "Setup wall/windows VBO, VAO, EBO, shader" let wallverxstrd = 8 wallvbo <- setupVBO wallverxstrd + winvbo <- setupVBO 8 + windowshader <- makeShaderUsingVBO "wall/blank" [vert, geom, frag] [4, 4] pmPoints winvbo + wallshader <- makeShaderUsingVBO "wall/basic" [vert, geom, frag] [4, 4] pmPoints wallvbo + putStrLn "Setup lighting shaders" lightingWallShadShad <- makeShaderUsingVBO "lighting/wallShadow" [vert, geom] [4] pmPoints wallvbo lightingCapShad <- makeShaderUsingVAO "lighting/cap" [vert, geom] pmTriangles shPosVAO lightingLineShadowShad <- - makeShaderUsingVAO "lighting/lineShadow" [vert, geom] pmLinesAdjacency shedgevao + makeShaderUsingVAO "lighting/lineShadow" [vert, geom] pmLinesAdjacency shedgevao shadowedgeshader <- makeShaderUsingVAO "shadow/edge" [vert, geom] pmLinesAdjacency shedgevao shadowcapshader <- makeShaderUsingVAO "shadow/cap" [vert, geom] pmTriangles shPosVAO shadowwallshader <- makeShaderUsingVBO "shadow/wallShadow" [vert, geom] [4] pmPoints wallvbo - shadowlightshader <- makeShaderSized "shadow/light" [vert, geom, frag] - [1] 1 - pmPoints - shadowcombineshader <- makeShaderSized "shadow/combine" [vert,geom,frag] [1] 1 pmPoints + shadowlightshader <- + makeShaderSized + "shadow/light" + [vert, geom, frag] + [1] + 1 + pmPoints + shadowcombineshader <- makeShaderSized "shadow/combine" [vert, geom, frag] [1] 1 pmPoints poke (shadVBOptr shadowlightshader) 1 - -- 2D draw shaders + putStrLn "Setup 2D shaders" bslist <- makeShaderVBO "dualTwoD/basic" [vert, frag] [3, 4] pmTriangles aslist <- makeShaderVBO "dualTwoD/arc" [vert, frag] [3, 4, 3] pmTriangles eslist <- makeShaderVBO "dualTwoD/ellipse" [vert, geom, frag] [3, 4] pmTriangles cslist <- makeShaderVBO "picture/charArray" [vert, frag] [3, 4, 4] pmTriangles --- initTexture2DArray 50 "data/texture/charMapVertBig.png" 2 32 64 95 GL_NEAREST_MIPMAP_LINEAR GL_LINEAR --- initTexture2DArray 50 "data/texture/charMapVert16Block.png" 2 16 32 95 GL_NEAREST GL_NEAREST - initTexture2DArray 50 "data/texture/charMapVert8Block.png" 2 8 16 95 GL_NEAREST GL_NEAREST + -- initTexture2DArray 50 "data/texture/charMapVertBig.png" 2 32 64 95 GL_NEAREST_MIPMAP_LINEAR GL_LINEAR + initTexture2DArray 50 "data/texture/charMapVert16Block.png" 2 16 32 95 GL_NEAREST GL_NEAREST + --initTexture2DArray 50 "data/texture/charMapVert8Block.png" 2 8 16 95 GL_NEAREST GL_NEAREST --initTexture2DArray 50 "data/texture/charMapVertBig.png" 2 32 64 95 GL_LINEAR_MIPMAP_LINEAR GL_LINEAR --initTexture2DArray 50 "data/texture/charMapVertBig.png" 2 32 64 95 GL_LINEAR_MIPMAP_NEAREST GL_LINEAR + putStrLn "Setup full screen shaders" screentexturevbo <- mglCreate glCreateBuffers withArray (concat cornerList) $ \ptr -> glNamedBufferStorage @@ -97,8 +130,8 @@ preloadRender = do (fromIntegral $ floatSize * length (concat cornerList)) ptr 0 - screentexturevao <- setupVAOvbo' [2,2] 4 screentexturevbo - alphadivideshader <- makeShaderUsingVAO "texture2D/alphaDivide" [vert,frag] pmTriangleStrip screentexturevao + screentexturevao <- setupVAOvbo' [2, 2] 4 screentexturevbo + alphadivideshader <- makeShaderUsingVAO "texture2D/alphaDivide" [vert, frag] pmTriangleStrip screentexturevao fsShad <- makeShaderUsingVAO "texture/simple" [vert, frag] pmTriangleStrip screentexturevao bloomBlurShad <- makeShaderUsingVAO "texture/bloomBlur" [vert, frag] pmTriangleStrip screentexturevao colorBlurShad <- makeShaderUsingVAO "texture/colorBlur" [vert, frag] pmTriangleStrip screentexturevao @@ -107,24 +140,24 @@ preloadRender = do makeShaderUsingVAO "lighting/texture" [vert, frag] pmTriangleStrip screentexturevao barrelShad <- makeShaderVBO "texture/barrel" [vert, geom, frag] [2, 2, 2, 1] pmPoints -- blank wallShader - winvbo <- setupVBO 8 - windowshader <- makeShaderUsingVBO "wall/blank" [vert, geom, frag] [4,4] pmPoints winvbo - wallshader <- makeShaderUsingVBO "wall/basic" [vert,geom,frag] [4,4] pmPoints wallvbo + putStrLn "Setup floor VBO, shader" let floorverxstrd = 8 floorvbo <- setupVBOStatic floorverxstrd - floorshader <- makeShaderUsingVBO "floor/arrayPos" [vert, frag] [4,4] pmTriangles floorvbo + floorshader <- makeShaderUsingVBO "floor/arrayPos" [vert, frag] [4, 4] pmTriangles floorvbo initTexture2DArraySquare 40 3 GL_LINEAR_MIPMAP_LINEAR GL_LINEAR "data/normalMaps/diffuseArray.png" initTexture2DArraySquare 41 3 GL_LINEAR_MIPMAP_LINEAR GL_LINEAR "data/normalMaps/normalArray.png" - let cloudverxsizes = [4,4,4,4] + putStrLn "Setup cloud VBO, shader" + let cloudverxsizes = [4, 4, 4, 4] cloudvbo <- setupVBO (sum cloudverxsizes) - (cloudshader, cloudebo) - <- makeShaderEBO "cloud/basic" [vert, frag] cloudverxsizes pmTriangles cloudvbo + (cloudshader, cloudebo) <- + makeShaderEBO "cloud/basic" [vert, frag] cloudverxsizes pmTriangles cloudvbo framebuf2 <- newTextureFramebuffer framebuf3 <- newTextureFramebuffer + putStrLn "Setup framebuffers" rboBaseBloomName <- mglCreate glCreateRenderbuffers - glNamedRenderbufferStorage + glNamedRenderbufferStorage rboBaseBloomName GL_DEPTH24_STENCIL8 800 @@ -156,10 +189,16 @@ preloadRender = do , aslist , eslist ] + + -- setup compute shader + computeshadowshader <- makeSourcedShader "compute/shadow" [GL_COMPUTE_SHADER] + initializeGLState + putStrLn "Return preload" return $ RenderData - { _pictureShaders = shadV + { _computeShadowShader = computeshadowshader + , _pictureShaders = shadV , _shapeShader = shapeshader -- & shaderVAO' .~ shPosColVAO , _shapeEBO = shEBO , _silhouetteEBO = shedgeebo @@ -193,8 +232,8 @@ preloadRender = do , _fboOverlay = fbooverlay , _rboBaseBloom = rboBaseBloomName , _matUBO = theUBO --- , _orthonormalMatUBO = orthonormalUBO - , _lightsUBO = lightsubo + , -- , _orthonormalMatUBO = orthonormalUBO + _lightsUBO = lightsubo , _vboWindows = winvbo , _vboShapes = shVBO , _floorVBO = floorvbo @@ -215,6 +254,7 @@ cornerList = , [1, 1, 1, 1] , [1, -1, 1, 0] ] + --cornerListForTriangles :: [[Float]] --cornerListForTriangles = -- [ [-1, 1, 0, 1] @@ -229,11 +269,11 @@ initializeGLState :: IO () initializeGLState = do glEnable GL_DEPTH_TEST - cleanUpRenderPreload :: RenderData -> IO () cleanUpRenderPreload _ = return () + --cleanUpRenderPreload pd = do - -- TODO fix this - --mapM_ freeShaderPointers $ _pictureShaders pd - --freeShaderPointers' $ _lightingWallShadShader pd - --freeShaderPointers' $ _fullscreenShader pd +-- TODO fix this +--mapM_ freeShaderPointers $ _pictureShaders pd +--freeShaderPointers' $ _lightingWallShadShader pd +--freeShaderPointers' $ _fullscreenShader pd diff --git a/src/Render.hs b/src/Render.hs index ce3a089ff..1b0cf99ae 100644 --- a/src/Render.hs +++ b/src/Render.hs @@ -44,6 +44,7 @@ createLightMap cfig = case shadrendertype of InstancingShads -> instanceLightMap cfig NoShadows -> const . const . const renderLightingNoShadows NoLighting -> const . const . const . const . const . const renderFlatLighting + ComputeShader -> renderComputeShadows _ -> renderShadows shadrendertype where shadrendertype = cfig ^. graphics_shadow_rendering @@ -103,6 +104,28 @@ renderLightingNoShadows positiontexture normaltexture lightPoints pdata = do glDisable GL_CULL_FACE glDisable GL_STENCIL_TEST +renderComputeShadows :: + GLsizei -> + Int -> + Int -> + TO -> + TO -> + [(Point3, Float, Point3)] -> + RenderData -> + IO () +renderComputeShadows _ _ _ toPos tanormals lightPoints rd = do + withArray (lightsToArray lightPoints) $ \ptr -> + glNamedBufferSubData (rd ^. lightsUBO) 0 620 ptr + glBindTextureUnit 0 (toPos ^. unTO) + glBindTextureUnit 1 (tanormals ^. unTO) + glBindImageTexture 5 (rd ^. fboLighting . _2 . unTO) 0 GL_FALSE 0 GL_WRITE_ONLY GL_RGBA8 + glUseProgram (rd ^. computeShadowShader) + glDispatchCompute 800 835 1 + -- the following should be later, just before the texture is accessed + --glMemoryBarrier GL_SHADER_IMAGE_ACCESS_BARRIER_BIT + glMemoryBarrier GL_TEXTURE_FETCH_BARRIER_BIT + return () + renderFlatLighting :: RenderData -> IO () renderFlatLighting pdata = do glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboLighting pdata))) @@ -145,12 +168,14 @@ renderShadows shadrendertype nWalls nSils nCaps positiontexture normaltexture li ptr -- for each of the lights: -- 1. stencil out the shadows from this light's point of view - -- 2. calculate lighting based on each fragment's position - -- to consider: adding normals/a "material" for each fragment + -- 2. calculate lighting based on each fragment's position and normal glBlendFunc GL_ZERO GL_ONE_MINUS_SRC_COLOR glEnable GL_STENCIL_TEST glStencilOpSeparate GL_FRONT GL_KEEP GL_KEEP GL_INCR_WRAP glStencilOpSeparate GL_BACK GL_KEEP GL_KEEP GL_DECR_WRAP + -- bind world position texture-- these will be used by the lighting shader + glBindTextureUnit 0 (positiontexture ^. unTO) + glBindTextureUnit 1 (normaltexture ^. unTO) flip VFSM.mapM_ (VFSM.fromList lightPoints) $ \(V3 x y z, rad, V3 r g b) -> do glDepthFunc GL_LESS -- setup stencil @@ -200,10 +225,7 @@ renderShadows shadrendertype nWalls nSils nCaps positiontexture normaltexture li _ -> return () --draw lightmap itself glDepthFunc GL_ALWAYS - -- bind world position texture glDisable GL_CULL_FACE - glBindTextureUnit 0 (positiontexture ^. unTO) - glBindTextureUnit 1 (normaltexture ^. unTO) glColorMask GL_TRUE GL_TRUE GL_TRUE GL_TRUE glStencilFunc GL_EQUAL 0 255 glUseProgram (ltextShad ^. shaderUINT) --Just (_shadProg ltextShad) diff --git a/src/Shader/Compile.hs b/src/Shader/Compile.hs index 6f0f4dd4e..b7eb55d60 100644 --- a/src/Shader/Compile.hs +++ b/src/Shader/Compile.hs @@ -12,6 +12,7 @@ module Shader.Compile ( setupVAOvbo', setupEBO, setupVertexAttribPointer, + makeSourcedShader, ) where import Control.Lens @@ -66,7 +67,8 @@ makeShaderEBO s shaderlist sizes pm vbo = do shad <- makeShaderUsingVBO s shaderlist sizes pm vbo ebo <- setupEBO (shad ^. shaderVAO) glVertexArrayElementBuffer (shad ^. shaderVAO . vaoName) (ebo ^. eboName) - return ( shad + return + ( shad , ebo ) @@ -81,7 +83,7 @@ makeShaderUsingVBO :: VBO -> IO Shader makeShaderUsingVBO s shaderlist sizes pm vbo = do - vao <- setupVAOUsingVBO sizes vbo + vao <- setupVAOUsingVBO sizes vbo makeShaderUsingVAO s shaderlist pm vao setupVBO :: Int -> IO VBO @@ -183,6 +185,7 @@ shaderTypeExt :: GLenum -> String shaderTypeExt GL_VERTEX_SHADER = ".vert" shaderTypeExt GL_GEOMETRY_SHADER = ".geom" shaderTypeExt GL_FRAGMENT_SHADER = ".frag" +shaderTypeExt GL_COMPUTE_SHADER = ".comp" shaderTypeExt _ = undefined -- I think that this requires that the correct shader program is bound? @@ -207,7 +210,7 @@ setupVAOUsingVBO sizes vbo = do vaoname <- mglCreate glCreateVertexArrays glBindVertexArray vaoname setupVertexAttribs vbo vaoname sizes strd - return VAO { _vaoName = vaoname } + return VAO{_vaoName = vaoname} setupEBO :: VAO -> IO EBO setupEBO vao = do diff --git a/src/Shader/Poke.hs b/src/Shader/Poke.hs index eff910f66..c5995921a 100644 --- a/src/Shader/Poke.hs +++ b/src/Shader/Poke.hs @@ -3,22 +3,23 @@ module Shader.Poke ( pokeLayVerxs, pokeArrayOff, pokeShape, + pokeShape', pokeWallsWindows, memoTopPrismEdgeIndices, - pokeFloors + pokeFloors, ) where -import Geometry.Vector -import Dodge.Data.Wall -import Geometry.Triangulate import Control.Monad.Primitive import qualified Data.Vector as V import qualified Data.Vector.Fusion.Stream.Monadic as VFSM import qualified Data.Vector.Mutable as MV import qualified Data.Vector.Unboxed as UV import qualified Data.Vector.Unboxed.Mutable as UMV +import Dodge.Data.Wall import Foreign import Geometry.Data +import Geometry.Triangulate +import Geometry.Vector import Graphics.GL.Core45 import Linear.V3 (cross) import Picture.Data @@ -34,6 +35,7 @@ pokeVerxs :: pokeVerxs vbos count = VFSM.mapM_ (pokeVerx vbos count) . VFSM.fromList pokeVerx :: MV.MVector (PrimState IO) (Shader, VBO) -> UMV.MVector (PrimState IO) Int -> Verx -> IO () +{-# INLINE pokeVerx #-} pokeVerx vbos offsets Verx{_vxPos = thePos, _vxCol = theCol, _vxExt = ext, _vxShadNum = shadnum} = do typeOff <- UMV.unsafeRead offsets sn basePtr <- _vboPtr . snd <$> MV.unsafeRead vbos sn @@ -53,9 +55,10 @@ pokeWallsWindows :: pokeWallsWindows wiptr truewlptr wis truewls = do wlcounts2 <- VFSM.foldlM' (pokeW wiptr) 0 (VFSM.fromList wis) wlcounts3 <- VFSM.foldlM' (pokeWall truewlptr) 0 (VFSM.fromList truewls) - return ( wlcounts2, wlcounts3) + return (wlcounts2, wlcounts3) -pokeFloors :: Ptr Float -> +pokeFloors :: + Ptr Float -> [(Point3, Point3)] -> IO Int pokeFloors flptr fls = VFSM.foldlM' (pokeF flptr) 0 (VFSM.fromList fls) @@ -72,8 +75,9 @@ pokeF ptr i' (V3 a b c, V3 d e f) = do return $ i' + 1 pokeWall :: Ptr Float -> Int -> Wall -> IO Int +{-# INLINE pokeWall #-} pokeWall ptr nw wl = do - UV.imapM_ f $ UV.fromList [x,y,x1,y1,t,a,1,1] + UV.imapM_ f $ UV.fromList [x, y, x1, y1, t, a, 1, 1] return $ nw + 1 where f i = pokeElemOff ptr (nw * 8 + i) @@ -94,6 +98,15 @@ pokeW ptr i' ((V2 a b, V2 c d), V4 e f g h) = do pokeElemOff ptr (i + 7) h return $ i' + 1 +pokeShape' :: + Ptr Float -> + Ptr GLushort -> + Ptr GLushort -> + (Int, Int, Int) -> + [Surface] -> + IO (Int, Int, Int) +pokeShape' = pokeShape $ const False + pokeShape :: (Surface -> Bool) -> Ptr Float -> @@ -102,8 +115,9 @@ pokeShape :: (Int, Int, Int) -> [Surface] -> IO (Int, Int, Int) -pokeShape shadowtest ptr iptr ieptr is = VFSM.foldlM' (pokeShapeObj shadowtest ptr iptr ieptr) is - . VFSM.fromList +pokeShape shadowtest ptr iptr ieptr is = + VFSM.foldlM' (pokeShapeObj shadowtest ptr iptr ieptr) is + . VFSM.fromList pokeShapeObj :: (Surface -> Bool) -> @@ -139,12 +153,17 @@ pokeRoundedFaces sfid col size ptr iptr ieptr (nv, nsi, nei) (tc : bc : svs) = d (pokeIndex nv iptr) nsi (memoTopPrismIndices V.! (size - 3)) - nei' <- if sfid then return nei - else UV.foldM' (pokeIndex nv ieptr) nei $ - memoTopPrismEdgeIndices V.! (size - 3) + nei' <- + if sfid + then return nei + else + UV.foldM' (pokeIndex nv ieptr) nei $ + memoTopPrismEdgeIndices V.! (size - 3) return (nv', nsi', nei') where - xdata | sfid = 0 + xdata + | sfid = 0 -- this records whether the shadow should be shown or not + -- honestly, I think things where faster without this | otherwise = 1 pokeRoundedFaces _ _ _ _ _ _ _ _ = undefined @@ -166,13 +185,16 @@ pokeCylinder sfid col size ptr iptr ieptr (nv, nsi, nei) (tc : bc : svs) = do (pokeIndex nv iptr) nsi (memoCylinderIndices V.! (size - 3)) - nei' <- if sfid - then return nei - else UV.foldM' (pokeIndex nv ieptr) nei $ - memoTopPrismEdgeIndices V.! (size - 3) + nei' <- + if sfid + then return nei + else + UV.foldM' (pokeIndex nv ieptr) nei $ + memoTopPrismEdgeIndices V.! (size - 3) return (nv', nsi', nei') where - xdata | sfid = 0 + xdata + | sfid = 0 | otherwise = 1 pokeCylinder _ _ _ _ _ _ _ _ = undefined @@ -180,11 +202,12 @@ pokeRoundedCurve :: Float -> Point4 -> Ptr Float -> Point3 -> Point3 -> [Point3] {-# INLINE pokeRoundedCurve #-} pokeRoundedCurve xdata col ptr tc bc = go True where - go True (x : xs) n = pokeJustV xdata tc col ptr n x >>= go False xs - go False (x : xs) n = pokeJustV xdata bc col ptr n x >>= go True xs + go True (x : xs) n = pokeJustV xdata tc col ptr n x >>= go False xs + go False (x : xs) n = pokeJustV xdata bc col ptr n x >>= go True xs go _ [] n = return n pokeCylinderCaps :: Float -> Point4 -> Ptr Float -> Point3 -> Point3 -> [Point3] -> Int -> IO Int +{-# INLINE pokeCylinderCaps #-} pokeCylinderCaps xdata col ptr tc bc = go True where go True (x : xs) n = pokeJustVInvNormal xdata tc col ptr n x >>= go False xs @@ -209,17 +232,22 @@ pokeBox sfid col size ptr iptr ieptr (nv, nsi, nei) svs = do (pokeIndex nv iptr) nsi (memoFlatIndices V.! (size -3)) - nei' <- if sfid then return nei - else UV.foldM' (pokeIndex nv ieptr) nei $ - memoBoxEdgeIndices V.! (size - 3) + nei' <- + if sfid + then return nei + else + UV.foldM' (pokeIndex nv ieptr) nei $ + memoBoxEdgeIndices V.! (size - 3) return (nv', nsi', nei') where svsv = UV.fromList svs - xdata | sfid = 0 + xdata + | sfid = 0 | otherwise = 1 -- should probably use a vector of Point3 pokeBoxSurface :: Float -> Point4 -> Ptr Float -> UV.Vector Point3 -> Int -> [Int] -> IO Int +{-# INLINE pokeBoxSurface #-} pokeBoxSurface xdata col ptr vs n is = UV.foldM' (pokeFlatV xdata norm col ptr) @@ -241,11 +269,11 @@ boxSurfaces size = where f x = map (`mod` (size * 2)) [x, x + 1, x + 3, x + 2] -boxSurfaces' :: Int -> [[Int]] -boxSurfaces' n = +boxSurfacesIndices :: Int -> [[Int]] +boxSurfacesIndices n = [0 .. n -1] : reverse [n .. n * 2 -1] : - [ map ((2 * n) +) [4 * i, 4 * i + 1, 4 * i + 2, 4 * i + 3] | i <- [0 .. n -1]] + [map ((2 * n) +) [4 * i, 4 * i + 1, 4 * i + 2, 4 * i + 3] | i <- [0 .. n -1]] pokeIndex :: -- | base index @@ -261,11 +289,11 @@ pokeIndex nv eiptr ni ioff = do pokeElemOff eiptr ni (fromIntegral $ nv + ioff) return $ ni + 1 - memoFlatIndices :: V.Vector (UV.Vector Int) +{-# INLINE memoFlatIndices #-} memoFlatIndices = V.generate 10 $ - UV.fromList . concatMap polyToTris . boxSurfaces' . (+ 3) + UV.fromList . concatMap polyToTris . boxSurfacesIndices . (+ 3) memoTopPrismIndices :: V.Vector (UV.Vector Int) {-# INLINE memoTopPrismIndices #-} @@ -289,10 +317,21 @@ topPrismEdgeIndices :: [Int] topPrismEdgeIndices n = concatMap f [0 .. n -1] where - f i = map g - [ 0 , 2 , 1 , 4 - , 0 , 1 , -2 , 3 - , 1 , 3 , -1 , 2 + f i = + map + g + [ 0 + , 2 + , 1 + , 4 + , 0 + , 1 + , -2 + , 3 + , 1 + , 3 + , -1 + , 2 ] where g j = (2 * i + j) `mod` (2 * n) @@ -308,10 +347,20 @@ boxEdgeIndices :: [Int] boxEdgeIndices n = concatMap f [0 .. n -1] where - f i = [ g 0 , g 1 ,n + g 0 , g 2 - , g 0 , n + g 0 , n + g (-1) , g 1 - , n + g 0 , n + g 1 , n + g (-1) , g 1 - ] + f i = + [ g 0 + , g 1 + , n + g 0 + , g 2 + , g 0 + , n + g 0 + , n + g (-1) + , g 1 + , n + g 0 + , n + g 1 + , n + g (-1) + , g 1 + ] where g j = (i + j) `mod` n @@ -323,14 +372,22 @@ cylinderIndices n = cylinderRoundIndices :: Int -> [Int] cylinderRoundIndices n = - [ 2 * n -2 , 2 * n -1 , 1 - , 2 * n -2 , 1 , 0 -- last side triangle (applies mod 2n) + [ 2 * n -2 + , 2 * n -1 + , 1 + , 2 * n -2 + , 1 + , 0 -- last side triangle (applies mod 2n) ] ++ concatMap g [0 .. n -2] -- other triangles on sides where g x = - [ 2 * x , 2 * x + 1 , 2 * x + 3 - , 2 * x , 2 * x + 3 , 2 * x + 2 + [ 2 * x + , 2 * x + 1 + , 2 * x + 3 + , 2 * x + , 2 * x + 3 + , 2 * x + 2 ] topPrismIndices :: Int -> [Int] @@ -338,21 +395,27 @@ topPrismIndices n = concatMap f [1 .. n -2] -- triangles on top face ++ concatMap f' [1 .. n -2] -- triangles on bottom face -- these should be checked - ++ [ 2 * n -2 , 2 * n -1 , 1 - , 2 * n -2 , 1 , 0 -- last side triangle (applies mod 2n) + ++ [ 2 * n -2 + , 2 * n -1 + , 1 + , 2 * n -2 + , 1 + , 0 -- last side triangle (applies mod 2n) ] ++ concatMap g [0 .. n -2] -- other triangles on sides where f x = [0, 2 * x, 2 * x + 2] f' x = [1, 2 * x + 3, 2 * x + 1] g x = - [ 2 * x , 2 * x + 1 , 2 * x + 3 - , 2 * x , 2 * x + 3 , 2 * x + 2 + [ 2 * x + , 2 * x + 1 + , 2 * x + 3 + , 2 * x + , 2 * x + 3 + , 2 * x + 2 ] -- consider changing the position to a vec4 --- and just doing two pokes rather than seven --- (especially if adding normal data) pokeJustV :: Float -> Point3 -> diff --git a/src/Shader/Poke/Cloud.hs b/src/Shader/Poke/Cloud.hs index 9c20c065d..0dd4a428f 100644 --- a/src/Shader/Poke/Cloud.hs +++ b/src/Shader/Poke/Cloud.hs @@ -15,6 +15,7 @@ pokeCloud vptr iptr (nv,ni) cl = do return (nv + 4, ni + 6) pokeCloudVerx :: Ptr Float -> Cloud -> Int -> Int -> (Float, Float) -> IO () +{-# INLINE pokeCloudVerx #-} pokeCloudVerx ptr cl nv i (dx, dy) = UV.imapM_ (pokeCloudFloat ptr (nv + i)) $ UV.fromList [x, y, cz, 1, r, g, b, a, cx, cy, cz, rad, dx, dy, 0, 0] @@ -26,7 +27,9 @@ pokeCloudVerx ptr cl nv i (dx, dy) = a = a' * min 1 (fromIntegral (_clTimer cl) / fadet) pokeCloudFloat :: Ptr Float -> Int -> Int -> Float -> IO () +{-# INLINE pokeCloudFloat #-} pokeCloudFloat ptr nv i = pokeElemOff ptr (nv * 16 + i) pokeCloudIndex :: Ptr GLushort -> Int -> Int -> Int -> Int -> IO () +{-# INLINE pokeCloudIndex #-} pokeCloudIndex ptr nv ni ioff voff = pokeElemOff ptr (ni + ioff) (fromIntegral $ nv + voff)