Try to add compute shaders

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
+    putStrLn "Skip music preload!"
-    Mix.playMusic Mix.Forever (lMusic IM.! 0)
+--    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}
             }

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
+- random
-- dlist
+- sdl2
-- deepseq
+- 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 

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()
+{
+}

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));
+        }
+}

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);
 }

src/Color.hs

@@ -1,35 +1,11 @@
---{-# LANGUAGE DeriveGeneric #-}
+module Color (
-{-# LANGUAGE TemplateHaskell #-}
+    module Color,
-{-# LANGUAGE DeriveAnyClass #-}
+    module Color.Data,
-{-# LANGUAGE DeriveGeneric #-}
+) where
-{-# LANGUAGE StrictData #-}
 
-module Color where
+import Color.Data
-
-import Data.Aeson
-import Data.Aeson.TH
 import Geometry
-
+import Control.Lens
-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
 
 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

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

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

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

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

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

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
+--    --draw clouds onto cloud buffer
-    glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboCloud pdata)))
+--    glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboCloud pdata)))
-    glDepthFunc GL_LEQUAL
+--    glDepthFunc GL_LEQUAL
-    glDepthMask GL_FALSE
+--    glDepthMask GL_FALSE
-    --blendFunc $= (SrcAlphaSaturate,One)
+--    --blendFunc $= (SrcAlphaSaturate,One)
-    --blendColor $= Color4 0.5 0.5 0.5 0.5
+--    --blendColor $= Color4 0.5 0.5 0.5 0.5
-    --blendFuncSeparate $= ((SrcAlphaSaturate,One) , (One,OneMinusSrcAlpha))
+--    --blendFuncSeparate $= ((SrcAlphaSaturate,One) , (One,OneMinusSrcAlpha))
-    --blendFuncSeparate $= ((SrcAlpha, OneMinusSrcAlpha), (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 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 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
+--    --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
+--    --glBlendFunc GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA
-    withArray [GL_COLOR_ATTACHMENT0, GL_NONE] $ \ptr -> glDrawBuffers 2 ptr
+--    withArray [GL_COLOR_ATTACHMENT0, GL_NONE] $ \ptr -> glDrawBuffers 2 ptr
-    withArray [0.5, 0.5, 0.5, 0] $ \ptr ->
+--    withArray [0.5, 0.5, 0.5, 0] $ \ptr ->
-        glClearNamedFramebufferfv
+--        glClearNamedFramebufferfv
-            (pdata ^. fboCloud . _1 . unFBO)
+--            (pdata ^. fboCloud . _1 . unFBO)
-            GL_COLOR
+--            GL_COLOR
-            0
+--            0
-            ptr
+--            ptr
-    --    renderLayer MidLayer shadV layerCounts
+--    --    renderLayer MidLayer shadV layerCounts
-    glUseProgram (pdata ^. cloudShader . shaderUINT)
+--    glUseProgram (pdata ^. cloudShader . shaderUINT)
-    glBindVertexArray $ pdata ^. cloudShader . shaderVAO . vaoName
+--    glBindVertexArray $ pdata ^. cloudShader . shaderVAO . vaoName
-    glDrawElements
+--    glDrawElements
-        (pdata ^. cloudShader . shaderPrimitive . unPrimitiveMode)
+--        (pdata ^. cloudShader . shaderPrimitive . unPrimitiveMode)
-        (fromIntegral nCloudIs)
+--        (fromIntegral nCloudIs)
-        GL_UNSIGNED_SHORT
+--        GL_UNSIGNED_SHORT
-        nullPtr
+--        nullPtr
-    drawShader (_windowShader pdata) nWins
+--    drawShader (_windowShader pdata) nWins
-    when (_graphics_cloud_shadows cfig) $ do
+--    when (_graphics_cloud_shadows cfig) $ do
-        ----render transparency depths
+--        ----render transparency depths
-        glDepthMask GL_TRUE
+--        glDepthMask GL_TRUE
-        glDepthFunc GL_ALWAYS
+--        glDepthFunc GL_ALWAYS
-        glDisable GL_BLEND
+--        glDisable GL_BLEND
-        withArray [GL_NONE, GL_COLOR_ATTACHMENT1, GL_COLOR_ATTACHMENT2] $ \ptr -> glDrawBuffers 3 ptr
+--        withArray [GL_NONE, GL_COLOR_ATTACHMENT1, GL_COLOR_ATTACHMENT2] $ \ptr -> glDrawBuffers 3 ptr
-        withArray [0, 0, 0, 0] $ \ptr ->
+--        withArray [0, 0, 0, 0] $ \ptr ->
-            glClearNamedFramebufferfv
+--            glClearNamedFramebufferfv
-                (pdata ^. fboCloud . _1 . unFBO)
+--                (pdata ^. fboCloud . _1 . unFBO)
-                GL_COLOR
+--                GL_COLOR
-                1
+--                1
-                ptr
+--                ptr
-        withArray [0, 0, 0, 0] $ \ptr ->
+--        withArray [0, 0, 0, 0] $ \ptr ->
-            glClearNamedFramebufferfv
+--            glClearNamedFramebufferfv
-                (pdata ^. fboCloud . _1 . unFBO)
+--                (pdata ^. fboCloud . _1 . unFBO)
-                GL_COLOR
+--                GL_COLOR
-                2
+--                2
-                ptr
+--                ptr
-        glEnable GL_BLEND
+--        glEnable GL_BLEND
-        -- we sum the positions weighted by alpha, and sum the alpha
+--        -- we sum the positions weighted by alpha, and sum the alpha
-        glBlendFuncSeparatei 1 GL_SRC_ALPHA GL_ONE GL_ONE GL_ONE
+--        glBlendFuncSeparatei 1 GL_SRC_ALPHA GL_ONE GL_ONE GL_ONE
-        -- and sum the normals weighted by alpha
+--        -- and sum the normals weighted by alpha
-        glBlendFunci 2 GL_SRC_ALPHA GL_ONE
+--        glBlendFunci 2 GL_SRC_ALPHA GL_ONE
-        glUseProgram (pdata ^. cloudShader . shaderUINT)
+--        glUseProgram (pdata ^. cloudShader . shaderUINT)
-        glBindVertexArray $ pdata ^. cloudShader . shaderVAO . vaoName
+--        glBindVertexArray $ pdata ^. cloudShader . shaderVAO . vaoName
-        glDepthMask GL_TRUE
+--        glDepthMask GL_TRUE
-        glDrawElements
+--        glDrawElements
-            (pdata ^. cloudShader . shaderPrimitive . unPrimitiveMode)
+--            (pdata ^. cloudShader . shaderPrimitive . unPrimitiveMode)
-            (fromIntegral nCloudIs)
+--            (fromIntegral nCloudIs)
-            GL_UNSIGNED_SHORT
+--            GL_UNSIGNED_SHORT
-            nullPtr
+--            nullPtr
-        drawShader (_windowShader pdata) nWins
+--        drawShader (_windowShader pdata) nWins
-        glBindFramebuffer GL_FRAMEBUFFER (pdata ^. fboPos . _1 . unFBO)
+--        glBindFramebuffer GL_FRAMEBUFFER (pdata ^. fboPos . _1 . unFBO)
-        withArray [0, 0, 0, 0] $ \ptr ->
+--        withArray [0, 0, 0, 0] $ \ptr ->
-            glClearNamedFramebufferfv
+--            glClearNamedFramebufferfv
-                (pdata ^. fboPos . _1 . unFBO)
+--                (pdata ^. fboPos . _1 . unFBO)
-                GL_COLOR
+--                GL_COLOR
-                0
+--                0
-                ptr
+--                ptr
-        glBindTextureUnit 0 (pdata ^. fboCloud . _2 . _2 . unTO)
+--        glBindTextureUnit 0 (pdata ^. fboCloud . _2 . _2 . unTO)
-        glDepthMask GL_FALSE
+--        glDepthMask GL_FALSE
-        drawShader (pdata ^. alphaDivideShader) 4
+--        drawShader (pdata ^. alphaDivideShader) 4
-        ----draw lightmap for cloud buffer
+--        ----draw lightmap for cloud buffer
-        glDepthFunc GL_LESS
+--        glDepthFunc GL_LESS
-        glEnable GL_BLEND
+--        glEnable GL_BLEND
-        glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboLighting pdata)))
+--        glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboLighting pdata)))
-        createLightMap
+--        createLightMap
-            cfig
+--            cfig
-            (fromIntegral trueNWalls)
+--            (fromIntegral trueNWalls)
-            nSilIndices
+--            nSilIndices
-            nIndices
+--            nIndices
-            (pdata ^. fboPos . _2)
+--            (pdata ^. fboPos . _2)
-            (pdata ^. fboCloud . _2 . _3)
+--            (pdata ^. fboCloud . _2 . _3)
-            lightPoints
+--            lightPoints
-            pdata
+--            pdata
-    glInvalidateBufferData (pdata ^. vboShapes . vboName)
+--    glInvalidateBufferData (pdata ^. vboShapes . vboName)
-    --apply lightmap to cloud buffer
+--    --apply lightmap to cloud buffer
-    glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboCloud pdata)))
+--    glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboCloud pdata)))
-    glDepthMask GL_FALSE
+--    glDepthMask GL_FALSE
-    withArray [GL_COLOR_ATTACHMENT0, GL_NONE] $ \ptr -> glDrawBuffers 2 ptr
+--    withArray [GL_COLOR_ATTACHMENT0, GL_NONE] $ \ptr -> glDrawBuffers 2 ptr
-    glDepthFunc GL_ALWAYS
+--    glDepthFunc GL_ALWAYS
-    glBindTextureUnit 0 (_unTO . snd $ _fboLighting pdata)
+--    glBindTextureUnit 0 (_unTO . snd $ _fboLighting pdata)
-    glEnable GL_BLEND
+--    glEnable GL_BLEND
-    glBlendFuncSeparate GL_ZERO GL_ONE_MINUS_SRC_COLOR GL_ZERO GL_ONE
+--    glBlendFuncSeparate GL_ZERO GL_ONE_MINUS_SRC_COLOR GL_ZERO GL_ONE
-    drawShader (_fullscreenShader pdata) 4
+--    drawShader (_fullscreenShader pdata) 4
-    glBlendFunc GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA
+--    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
+--    --draw shadowed clouds onto base buffer
-    glBindTextureUnit 0 (pdata ^. fboCloud . _2 . _1 . unTO)
+--    glBindTextureUnit 0 (pdata ^. fboCloud . _2 . _1 . unTO)
-    drawShader (_fullscreenShader pdata) 4
+--    drawShader (_fullscreenShader pdata) 4
     --set viewport for radial distortion
     --setViewportSize (round winx) (round winy)
     setViewport (const FullRes) cfig

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)

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

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 ->
---    orthonormalUBO <- mglCreate glCreateBuffers
+    --        glNamedBufferStorage orthonormalUBO 64 ptr 0
---    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] 
+    shadowlightshader <-
-        [1] 1
+        makeShaderSized
-        pmPoints
+            "shadow/light"
-    shadowcombineshader <- makeShaderSized "shadow/combine" [vert,geom,frag] [1] 1 pmPoints
+            [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/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/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/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
+    screentexturevao <- setupVAOvbo' [2, 2] 4 screentexturevbo
-    alphadivideshader <- makeShaderUsingVAO "texture2D/alphaDivide" [vert,frag] pmTriangleStrip screentexturevao
+    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
+    putStrLn "Setup floor VBO, shader"
-    windowshader <- makeShaderUsingVBO "wall/blank" [vert, geom, frag] [4,4] pmPoints winvbo
-    wallshader <- makeShaderUsingVBO "wall/basic" [vert,geom,frag] [4,4] pmPoints wallvbo
     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)
+    (cloudshader, cloudebo) <-
-        <- makeShaderEBO "cloud/basic" [vert, frag] cloudverxsizes pmTriangles cloudvbo
+        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
+            , --            , _orthonormalMatUBO = orthonormalUBO
-            , _lightsUBO = lightsubo
+              _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
+-- TODO fix this
-    --mapM_ freeShaderPointers $ _pictureShaders pd
+--mapM_ freeShaderPointers $ _pictureShaders pd
-    --freeShaderPointers' $ _lightingWallShadShader pd
+--freeShaderPointers' $ _lightingWallShadShader pd
-    --freeShaderPointers' $ _fullscreenShader pd
+--freeShaderPointers' $ _fullscreenShader pd

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
+    -- 2. calculate lighting based on each fragment's position and normal
-    -- to consider: adding normals/a "material" for each fragment
     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)

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

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 
+pokeShape shadowtest ptr iptr ieptr is =
-    . VFSM.fromList
+    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
+    nei' <-
-        else UV.foldM' (pokeIndex nv ieptr) nei $
+        if sfid
-            memoTopPrismEdgeIndices V.! (size - 3)
+            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
+    nei' <-
-        then return nei
+        if sfid
-        else UV.foldM' (pokeIndex nv ieptr) nei $
+            then return nei
-            memoTopPrismEdgeIndices V.! (size - 3)
+            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 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 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
+    nei' <-
-        else UV.foldM' (pokeIndex nv ieptr) nei $
+        if sfid
-            memoBoxEdgeIndices V.! (size - 3)
+            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]]
+boxSurfacesIndices :: Int -> [[Int]]
-boxSurfaces' n =
+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
+    f i =
-            [ 0 , 2 ,  1 , 4 
+        map
-            , 0 , 1 , -2 , 3 
+            g
-            , 1 , 3 , -1 , 2 
+            [ 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 
+    f i =
-          , g 0 , n + g 0 , n + g (-1) , g 1
+        [ g 0
-          , n + g 0 , n + g 1 , n + g (-1) , g 1
+        , 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
-    , 2 * n -2 , 1 , 0 -- last side triangle (applies mod 2n)
+    , 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 , 2 * x + 3 , 2 * x + 2
+        , 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
-           , 2 * n -2 , 1 , 0 -- last side triangle (applies mod 2n)
+           , 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 , 2 * x + 3 , 2 * x + 2
+        , 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 ->

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)