Cleanup

src/Color.hs

@@ -141,5 +141,5 @@ numColor _ = toV4 (1, 1, 1, 1)
 light4 :: Color -> Color
 light4 = light . light . light . light
 
-toColor256 :: Color -> Color256
+toColor8 :: Color -> Color8
-toColor256 = over each floor . (255 *) . normalizeColor
+toColor8 = over each floor . (255 *) . normalizeColor

src/Color/Data.hs

@@ -32,6 +32,6 @@ type RGBA = Point4
 
 type Color = Point4
 
-type Color256 = V4 Word8
+type Color8 = V4 Word8
 
 deriveJSON defaultOptions ''PaletteColor

src/Data/Preload/Render.hs

@@ -20,7 +20,7 @@ data RenderData = RenderData
     , _shadowEdgeShader :: Shader
     , _shadowCapShader :: Shader
     , _shadowWallShader :: Shader
-    , _shadowLightShader :: (Shader,VBO)
+    , _shadowLightShader :: Shader
     , _shadowCombineShader :: Shader
     , _windowShader :: Shader
     , _fullscreenShader :: Shader

src/Dodge/DisplayInventory.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE TupleSections #-}
+--{-# OPTIONS_GHC -fno-full-laziness #-}
 
 module Dodge.DisplayInventory (
     toggleCombineInv,

src/Dodge/Floor.hs

@@ -20,11 +20,11 @@ initialRoomTree :: State (StdGen, Int) (MetaTree Room String)
 initialRoomTree = annoToRoomTree initialAnoTree
 --initialRoomTree = annoToRoomTree startWorldTreeTest
 
-startWorldTreeTest :: Annotation
+--startWorldTreeTest :: Annotation
-startWorldTreeTest  =
+--startWorldTreeTest  =
-    OnwardList $
+--    OnwardList $
-            [ IntAnno $ AnTree . startRoom
+--            [ IntAnno $ AnTree . startRoom
-            ]
+--            ]
 
 initialAnoTree :: Annotation
 initialAnoTree =

src/Dodge/Render.hs

@@ -46,7 +46,7 @@ doTestDrawing _ _ = do
 doDrawing' :: SDL.Window -> RenderData -> Universe -> IO ()
 doDrawing' win pdata u = do
     --sTicks <- SDL.ticks
-    checkGLError
+    checkGLError "during drawing"
     let w = _uvWorld u
         cfig = _uvConfig u
         rot = w ^. wCam . camRot

src/Dodge/Update.hs

@@ -341,9 +341,6 @@ zoneCreatures w =
     w & crZoning
         .~ foldl' (flip zoneCreature) mempty (w ^. cWorld . lWorld . creatures)
 
---        foldl' (flip $ updateZoning (\cr -> IM.insert (_crID cr) cr))
---            zn (_creatures w)
-
 updateCreatureSoundPositions :: World -> World
 updateCreatureSoundPositions w =
     M.foldlWithKey' insertSound w

src/Dodge/Zoning/Base.hs

@@ -6,7 +6,6 @@ module Dodge.Zoning.Base
     , zoneOfRect
     , zoneMonoid
     , deZoneIX
-    , zoneOfPoint''
     , zoneOfCirc
     , zonesAroundPoint
     , xIntercepts
@@ -87,10 +86,6 @@ zoneMonoid (V2 x y) a = IM.insertWith f x $! IM.singleton y a
 deZoneIX :: Int -> IM.IntMap (IM.IntMap IS.IntSet) -> Int2 -> IM.IntMap (IM.IntMap IS.IntSet)
 deZoneIX i im (V2 x y) = im & ix x . ix y %~ IS.delete i
 
-zoneOfPoint'' :: Float -> Point2 -> Int2
-{-# INLINE zoneOfPoint'' #-}
-zoneOfPoint'' s = fmap (divTo s)
-
 zonesAroundPoint :: Float -> Point2 -> [Int2]
 zonesAroundPoint s p = [V2 a b | a <- [x -1 .. x + 1], b <- [y -1 .. y + 1]]
   where

src/Dodge/Zoning/Cloud.hs

@@ -7,13 +7,13 @@ import qualified IntMapHelp as IM
 import Dodge.Zoning.Common
 
 clsNearPoint :: Point2 -> World -> [Cloud]
-clsNearPoint = nearPoint' clZoneSize _clZoning
+clsNearPoint = nearPoint clZoneSize _clZoning
 
 clsNearSeg :: Point2 -> Point2 -> World -> [Cloud]
-clsNearSeg = nearSeg' clZoneSize _clZoning
+clsNearSeg = nearSeg clZoneSize _clZoning
 
 clsNearRect :: Point2 -> Point2 -> World -> [Cloud]
-clsNearRect = nearRect' clZoneSize _clZoning
+clsNearRect = nearRect clZoneSize _clZoning
 
 clsNearCirc :: Point2 -> Float -> World -> [Cloud]
 clsNearCirc p r = clsNearRect (p +.+ V2 r r) (p -.- V2 r r)
@@ -22,7 +22,7 @@ clZoneSize :: Float
 clZoneSize = 20
 
 zoneOfCl :: Cloud -> Int2
-zoneOfCl = zoneOfPoint'' clZoneSize . xyV3 . _clPos
+zoneOfCl = zoneOfPoint clZoneSize . xyV3 . _clPos
 
 zoneCloud :: Cloud -> IM.IntMap (IM.IntMap [Cloud]) -> IM.IntMap (IM.IntMap [Cloud])
 zoneCloud cl = zoneMonoid (zoneOfCl cl) [cl]

src/Dodge/Zoning/Common.hs

@@ -5,14 +5,14 @@ import Dodge.Zoning.Base
 import Geometry
 import qualified IntMapHelp as IM
 
-nearPoint' :: Monoid m => Float -> (World -> IM.IntMap (IM.IntMap m)) -> Point2 -> World -> m
+nearPoint :: Monoid m => Float -> (World -> IM.IntMap (IM.IntMap m)) -> Point2 -> World -> m
-{-# INLINE nearPoint' #-}
+{-# INLINE nearPoint #-}
-nearPoint' size f p w = zoneExtract (zoneOfPoint size p) (f w)
+nearPoint size f p = zoneExtract (zoneOfPoint size p) . f
 
-nearSeg' :: Monoid m => Float -> (World -> IM.IntMap (IM.IntMap m)) -> Point2 -> Point2 -> World -> m
+nearSeg :: Monoid m => Float -> (World -> IM.IntMap (IM.IntMap m)) -> Point2 -> Point2 -> World -> m
-{-# INLINE nearSeg' #-}
+{-# INLINE nearSeg #-}
-nearSeg' size f sp ep w = zonesExtract (f w) (zoneOfSeg size sp ep)
+nearSeg size f sp ep w = zonesExtract (f w) (zoneOfSeg size sp ep)
 
-nearRect' :: Monoid m => Float -> (World -> IM.IntMap (IM.IntMap m)) -> Point2 -> Point2 -> World -> m
+nearRect :: Monoid m => Float -> (World -> IM.IntMap (IM.IntMap m)) -> Point2 -> Point2 -> World -> m
-{-# INLINE nearRect' #-}
+{-# INLINE nearRect #-}
-nearRect' size f sp ep w = zonesExtract (f w) (zoneOfRect size sp ep)
+nearRect size f sp ep w = zonesExtract (f w) (zoneOfRect size sp ep)

src/Dodge/Zoning/Creature.hs

@@ -12,7 +12,7 @@ import Dodge.Zoning.Common
 
 crIXsNearPoint :: Point2 -> World -> IS.IntSet
 --crIXsNearPoint p w = zoneExtract (zoneOfPoint crZoneSize p) (w ^. cWorld . lWorld . crZoning)
-crIXsNearPoint = nearPoint' crZoneSize _crZoning
+crIXsNearPoint = nearPoint crZoneSize _crZoning
 
 crsNearPoint :: Point2 -> World -> [Creature]
 crsNearPoint p w = mapMaybe (\cid -> w ^? cWorld . lWorld . creatures . ix cid) . IS.toList $ crIXsNearPoint p w
@@ -24,7 +24,7 @@ crsNearSeg sp ep w =
     $ crixsNearSeg sp ep w
 
 crixsNearSeg :: Point2 -> Point2 -> World -> IS.IntSet
-crixsNearSeg = nearSeg' crZoneSize _crZoning
+crixsNearSeg = nearSeg crZoneSize _crZoning
 --crixsNearSeg sp ep w = zonesExtract (w ^. cWorld . lWorld . crZoning) (zoneOfSeg crZoneSize sp ep)
 
 crIXsNearCirc :: Point2 -> Float -> World -> IS.IntSet
@@ -34,7 +34,7 @@ crsNearCirc :: Point2 -> Float -> World -> [Creature]
 crsNearCirc p r w = mapMaybe (\cid -> w ^? cWorld . lWorld . creatures . ix cid) . IS.toList $ crIXsNearCirc p r w
 
 crsNearRect :: Point2 -> Point2 -> World -> IS.IntSet
-crsNearRect = nearRect' crZoneSize _crZoning
+crsNearRect = nearRect crZoneSize _crZoning
 
 crZoneSize :: Float
 crZoneSize = 15
@@ -50,6 +50,7 @@ minCrIXOn f is w = fst <$> IS.foldl' g Nothing is
     h cr = (cr, f cr)
 
 zoneCreature :: Creature -> IM.IntMap (IM.IntMap IS.IntSet) -> IM.IntMap (IM.IntMap IS.IntSet)
+{-# INLINE zoneCreature #-}
 zoneCreature cr im = foldl' f im (zoneOfCr cr)
   where
     f im' i2 = zoneMonoid i2 (IS.singleton $ _crID cr) im'

src/Dodge/Zoning/Pathing.hs

@@ -10,13 +10,13 @@ import qualified Data.Set as Set
 import Dodge.Zoning.Common
 
 pnsNearPoint :: Point2 -> World -> [(Int, Point2)]
-pnsNearPoint = nearPoint' pnZoneSize _pnZoning
+pnsNearPoint = nearPoint pnZoneSize _pnZoning
 
 pnsNearSeg :: Point2 -> Point2 -> World -> [(Int, Point2)]
-pnsNearSeg = nearSeg' pnZoneSize _pnZoning
+pnsNearSeg = nearSeg pnZoneSize _pnZoning
 
 pnsNearRect :: Point2 -> Point2 -> World -> [(Int, Point2)]
-pnsNearRect = nearRect' pnZoneSize _pnZoning
+pnsNearRect = nearRect pnZoneSize _pnZoning
 
 pnsNearCirc :: Point2 -> Float -> World -> [(Int, Point2)]
 pnsNearCirc p r = pnsNearRect (p +.+ V2 r r) (p -.- V2 r r)
@@ -25,20 +25,20 @@ pnZoneSize :: Float
 pnZoneSize = 50
 
 zoneOfPn :: (Int, Point2) -> Int2
-zoneOfPn = zoneOfPoint'' pnZoneSize . snd
+zoneOfPn = zoneOfPoint pnZoneSize . snd
 
 zonePn :: (Int, Point2) -> IM.IntMap (IM.IntMap [(Int, Point2)]) -> IM.IntMap (IM.IntMap [(Int, Point2)])
 zonePn pn = zoneMonoid (zoneOfPn pn) [pn]
 
 pesNearPoint :: Point2 -> World -> Set PathEdgeNodes
-pesNearPoint = nearPoint' peZoneSize _peZoning
+pesNearPoint = nearPoint peZoneSize _peZoning
 --pesNearPoint p w = zoneExtract (zoneOfPoint peZoneSize p) (w ^. cWorld . lWorld . peZoning)
 
 pesNearSeg :: Point2 -> Point2 -> World -> Set PathEdgeNodes
-pesNearSeg = nearSeg' peZoneSize _peZoning
+pesNearSeg = nearSeg peZoneSize _peZoning
 
 pesNearRect :: Point2 -> Point2 -> World -> Set PathEdgeNodes
-pesNearRect = nearRect' peZoneSize _peZoning
+pesNearRect = nearRect peZoneSize _peZoning
 
 pesNearCirc :: Point2 -> Float -> World -> Set PathEdgeNodes
 pesNearCirc p r = pesNearRect (p +.+ V2 r r) (p -.- V2 r r)

src/Dodge/Zoning/Wall.hs

@@ -20,14 +20,14 @@ import qualified IntMapHelp as IM
 import Dodge.Zoning.Common
 
 wlIXsNearPoint :: Point2 -> World -> IS.IntSet
-wlIXsNearPoint = nearPoint' wlZoneSize _wlZoning
+wlIXsNearPoint = nearPoint wlZoneSize _wlZoning
 
 wlIXsNearSeg :: Point2 -> Point2 -> World -> IS.IntSet
 {-# INLINE wlIXsNearSeg #-}
-wlIXsNearSeg = nearSeg' wlZoneSize _wlZoning
+wlIXsNearSeg = nearSeg wlZoneSize _wlZoning
 
 wlIXsNearRect :: Point2 -> Point2 -> World -> IS.IntSet
-wlIXsNearRect = nearRect' wlZoneSize _wlZoning
+wlIXsNearRect = nearRect wlZoneSize _wlZoning
 
 wlIXsNearCirc :: Point2 -> Float -> World -> IS.IntSet
 wlIXsNearCirc p r = wlIXsNearRect (p +.+ V2 r r) (p -.- V2 r r)

src/GLHelp.hs

@@ -14,9 +14,9 @@ mglCreate f = do
 mglDelete :: (GLsizei -> Ptr GLuint -> IO ()) -> GLuint -> IO ()
 mglDelete f i = with i $ \ptr -> f 1 ptr
 
-checkGLError :: IO ()
+checkGLError :: String -> IO ()
-checkGLError = do
+checkGLError s = do
     err <- glGetError
     case err of
         0 -> return ()
-        i -> error $ "OpenGL error: " ++ show i
+        i -> error $ "OpenGL error: " ++ show i ++ " - " ++ s

src/Preload/Render.hs

@@ -5,6 +5,8 @@ module Preload.Render (
     cleanUpRenderPreload,
 ) where
 
+import Shape.Parameters
+import Shader.Parameters
 import Control.Concurrent
 import Control.Lens
 import Control.Monad
@@ -14,12 +16,9 @@ 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 Shape.Data
 
 {- BINDING LIST:
 0   base
@@ -68,12 +67,14 @@ preloadRender = do
 
     -- setup shape geometry/cap VBO and two VAOs
     putStrLn "Setup shape VBO, VAO, EBO"
-    shVBO <- setupVBO nShapeVerxComp
+    shVBO <- setupVBO shapeVerxSize
     shPosVAO <- setupVAOUsingVBO [VertexAttribute 4 GL_FLOAT GL_FALSE 0] shVBO
     shEBO <- setupEBO shPosVAO
     -- note the shape shader vao is distinct from the position vao, but they
     -- share an EBO
-    shapeshader <- makeShaderUsingVBO "shape/basic" [vert, frag] shapeVerxSizes pmTriangles shVBO
+    shapeshader <- makeShaderUsingVBO "shape/basic" [vert, frag] 
+        shapeVerxAttributes
+        pmTriangles shVBO
     glVertexArrayElementBuffer (shapeshader ^. shaderVAO . vaoName) (shEBO ^. eboName)
 
     --setup silhouette edge VAO
@@ -83,13 +84,13 @@ preloadRender = do
 
     putStrLn "Setup wall/windows VBO, VAO, EBO, shader"
     let wallverxstrd = 8
-    wallvbo <- setupVBO wallverxstrd
+    wallvbo <- setupVBO (floatSize * wallverxstrd)
-    winvbo <- setupVBO 8
+    winvbo <- setupVBO (floatSize * 8)
-    windowshader <- makeShaderUsingVBO "wall/blank" [vert, geom, frag] [4, 4] pmPoints winvbo
+    windowshader <- makeShaderUsingVBO "wall/blank" [vert, geom, frag] (toFloatVAs [4, 4]) pmPoints winvbo
-    wallshader <- makeShaderUsingVBO "wall/basic" [vert, geom, frag] [4, 4] pmPoints wallvbo
+    wallshader <- makeShaderUsingVBO "wall/basic" [vert, geom, frag] (toFloatVAs [4, 4]) pmPoints wallvbo
     putStrLn "Setup lighting shaders"
     lightingWallShadShad <-
-        makeShaderUsingVBO "lighting/wallShadow" [vert, geom] [4] pmPoints wallvbo
+        makeShaderUsingVBO "lighting/wallShadow" [vert, geom] (toFloatVAs [4]) pmPoints wallvbo
     lightingCapShad <-
         makeShaderUsingVAO "lighting/cap" [vert, geom] pmTriangles shPosVAO
     lightingLineShadowShad <-
@@ -99,24 +100,23 @@ preloadRender = do
     shadowcapshader <-
         makeShaderUsingVAO "shadow/cap" [vert, geom] pmTriangles shPosVAO
     shadowwallshader <-
-        makeShaderUsingVBO "shadow/wallShadow" [vert, geom] [4] pmPoints wallvbo
+        makeShaderUsingVBO "shadow/wallShadow" [vert, geom] (toFloatVAs [4]) pmPoints wallvbo
     shadowlightshader <-
-        makeShaderFixedVertices
+        makeStaticShader
             "shadow/light"
             [vert, geom, frag]
-            [1]
+            [VertexAttribute 1 GL_BYTE GL_FALSE 0]
-            1
+            ([1] :: [GLbyte])
             pmPoints
     shadowcombineshader <- makeShaderUsingVAO "shadow/combine" [vert, geom, frag] pmPoints 
-        (shadowlightshader ^. _1 . shaderVAO)
+        (shadowlightshader ^. shaderVAO)
-    poke (shadVBOptr shadowlightshader) 1
 
     putStrLn "Setup 2D shaders"
-    bslist <- makeShaderVBO "dualTwoD/basic" [vert, frag] [3, 4] pmTriangles
+    bslist <- makeShaderVBO "dualTwoD/basic" [vert, frag] (toFloatVAs [3, 4]) pmTriangles
-    aslist <- makeShaderVBO "dualTwoD/arc" [vert, frag] [3, 4, 3] pmTriangles
+    aslist <- makeShaderVBO "dualTwoD/arc" [vert, frag] (toFloatVAs [3, 4, 3]) pmTriangles
-    eslist <- makeShaderVBO "dualTwoD/ellipse" [vert, geom, frag] [3, 4] pmTriangles
+    eslist <- makeShaderVBO "dualTwoD/ellipse" [vert, geom, frag] (toFloatVAs [3, 4]) pmTriangles
     cslist <-
-        makeShaderVBO "picture/charArray" [vert, frag] [3, 4, 4] pmTriangles
+        makeShaderVBO "picture/charArray" [vert, frag] (toFloatVAs [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
@@ -124,14 +124,7 @@ preloadRender = do
     --initTexture2DArray 50 "data/texture/charMapVertBig.png" 2 32 64 95 GL_LINEAR_MIPMAP_NEAREST GL_LINEAR
 
     putStrLn "Setup full screen shaders"
-    screentexturevbo <- mglCreate glCreateBuffers
+    (_,screentexturevao) <- setupStaticVBOVAO (toFloatVAs [2,2]) (concat cornerList)
-    withArray (concat cornerList) $ \ptr ->
-        glNamedBufferStorage
-            screentexturevbo
-            (fromIntegral $ floatSize * length (concat cornerList))
-            ptr
-            0
-    screentexturevao <- setupVAOvbo (toFloatVAs [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
@@ -139,20 +132,20 @@ preloadRender = do
     grayscaleShad <- makeShaderUsingVAO "texture/grayscale" [vert, frag] pmTriangleStrip screentexturevao
     lightingTextureShad <-
         makeShaderUsingVAO "lighting/texture" [vert, frag] pmTriangleStrip screentexturevao
-    barrelShad <- makeShaderVBO "texture/barrel" [vert, geom, frag] [2, 2, 2, 1] pmPoints
+    barrelShad <- makeShaderVBO "texture/barrel" [vert, geom, frag] (toFloatVAs [2, 2, 2, 1]) pmPoints
     -- blank wallShader
     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] (toFloatVAs [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"
 
     putStrLn "Setup cloud VBO, shader"
     let cloudverxsizes = [4, 4, 4, 4]
-    cloudvbo <- setupVBO (sum cloudverxsizes)
+    cloudvbo <- setupVBO (floatSize * sum cloudverxsizes)
     (cloudshader, cloudebo) <-
-        makeShaderEBO "cloud/basic" [vert, frag] cloudverxsizes pmTriangles cloudvbo
+        makeShaderEBO "cloud/basic" [vert, frag] (toFloatVAs cloudverxsizes) pmTriangles cloudvbo
     framebuf2 <- newTextureFramebuffer
     framebuf3 <- newTextureFramebuffer
 

src/Render.hs

@@ -150,7 +150,7 @@ renderShadows ::
     RenderData ->
     IO ()
 renderShadows shadrendertype nWalls nSils nCaps positiontexture normaltexture lightPoints pdata = do
-    glBindFramebuffer GL_FRAMEBUFFER $ pdata ^. fboLighting . _1 . unFBO --(_unFBO (fst (_fboLighting pdata)))
+    glBindFramebuffer GL_FRAMEBUFFER $ pdata ^. fboLighting . _1 . unFBO
     let llinesShad = _lightingLineShadowShader pdata
         lcapShad = _lightingCapShader pdata
         lwallShad = _lightingWallShadShader pdata
@@ -339,12 +339,12 @@ instanceLightMap cfig nWalls nSils nCaps toPos tanormals lightPoints pdata = do
     glDepthFunc GL_ALWAYS
     glColorMask GL_TRUE GL_TRUE GL_TRUE GL_TRUE
     glStencilFunc GL_EQUAL 0 255
-    glUseProgram (pdata ^. shadowLightShader . _1 . shaderUINT)
+    glUseProgram (pdata ^. shadowLightShader . shaderUINT)
     -- bind world position texture
     glBindTextureUnit 0 (toPos ^. unTO)
     glBindTextureUnit 1 (tanormals ^. unTO)
     glDrawArrays
-        (_unPrimitiveMode $ pdata ^. shadowLightShader . _1 . shaderPrimitive)
+        (_unPrimitiveMode $ pdata ^. shadowLightShader . shaderPrimitive)
         0
         1
     glDisable GL_CULL_FACE

src/Shader/Bind.hs

@@ -21,7 +21,7 @@ bufferPokedVBO theVBO numVs =
     glNamedBufferSubData
         (_vboName theVBO)
         0
-        (fromIntegral $ floatSize * numVs * _vboVertexSize theVBO)
+        (fromIntegral $ numVs * _vboVertexBytes theVBO)
         (_vboPtr theVBO)
 
 bufferEBO :: EBO -> Int -> IO ()
@@ -37,7 +37,7 @@ bufferShaderLayers shads counts = MV.imapM_ f shads
   where
     f i shad = do
         let theVBO = snd shad
-            stride = _vboVertexSize theVBO
+            stride = _vboVertexBytes theVBO `div` floatSize
         VFSM.mapM_ (g stride theVBO) $ VFSM.enumFromStepN 0 1 6 -- [0..5]
       where
         g stride theVBO lay = do

src/Shader/Compile.hs

@@ -5,7 +5,7 @@ module Shader.Compile (
     makeShaderVBO,
     makeShaderUsingVBO,
     makeByteStringShaderUsingVAO,
-    makeShaderFixedVertices,
+    makeStaticShader,
     makeShaderUsingVAO,
     setupVAOUsingVBO,
     setupVAOvbo,
@@ -13,8 +13,10 @@ module Shader.Compile (
     setupVertexAttribPointer,
     makeSourcedShader,
     toFloatVAs,
+    setupStaticVBOVAO
 ) where
 
+import Foreign.C.Types
 import Graphics.GL.Types
 import Control.Lens
 import Control.Monad
@@ -39,12 +41,12 @@ makeShaderVBO ::
     -- | shader types
     [GLenum] ->
     -- | The input vertex sizes
-    [Int] ->
+    [VertexAttribute] ->
     PrimitiveMode ->
     IO (Shader, VBO)
 makeShaderVBO s shaderlist sizes pm = do
     prog <- makeSourcedShader s shaderlist
-    (vao, vbo) <- setupVBOVAO sizes
+    (vao, vbo) <- setupVBOVAO (sizes)
     return
         ( Shader
             { _shaderUINT = prog
@@ -60,7 +62,7 @@ makeShaderEBO ::
     -- | shader types
     [GLenum] ->
     -- | The input vertex sizes
-    [Int] ->
+    [VertexAttribute] ->
     PrimitiveMode ->
     VBO ->
     IO (Shader, EBO)
@@ -79,25 +81,46 @@ makeShaderUsingVBO ::
     -- | shader types
     [GLenum] ->
     -- | The input vertex sizes
-    [Int] ->
+    [VertexAttribute] ->
     PrimitiveMode ->
     VBO ->
     IO Shader
 makeShaderUsingVBO s shaderlist sizes pm vbo = do
-    vao <- setupVAOUsingVBO (toFloatVAs sizes) vbo
+    vao <- setupVAOUsingVBO sizes vbo
     makeShaderUsingVAO s shaderlist pm vao
 
 setupVBO :: Int -> IO VBO
 setupVBO vertexsize = do
     vboname <- mglCreate glCreateBuffers
-    thePtr <- mallocArray (vertexsize * numDrawableElements)
+    thePtr <- mallocBytes (vertexsize * numDrawableElements)
     -- Allocate space
     glNamedBufferData
         vboname
-        (fromIntegral $ floatSize * numDrawableElements * vertexsize)
+        (fromIntegral $ numDrawableElements * vertexsize)
         nullPtr
         GL_STREAM_DRAW
-    return VBO{_vboName = vboname, _vboPtr = thePtr, _vboVertexSize = vertexsize}
+    return VBO{_vboName = vboname, _vboPtr = thePtr, _vboVertexBytes = vertexsize}
+
+-- the input ptr is assumed to contain the correct amount of data according to
+-- the specified number and type of vertices
+-- note the VBO here does not have a sensible ptr value
+setupStaticVBOVAO :: Storable a => [VertexAttribute] -> [a] -> IO (VBO,VAO)
+setupStaticVBOVAO vas vdata = withArrayLen vdata $ \i ptr -> do
+    vboname <- mglCreate glCreateBuffers
+    glNamedBufferStorage
+        vboname
+        (CPtrdiff (fromIntegral (i * sizeOf (head vdata))))
+        ptr
+        0
+    let vbo = VBO 
+            { _vboName = vboname 
+            , _vboPtr = nullPtr
+            , _vboVertexBytes = vasTightStride vas
+            }
+    vao <- setupVAOUsingVBO vas vbo
+    return (vbo,vao)
+    
+    
 
 setupVBOStatic :: Int -> IO VBO
 setupVBOStatic vertexsize = do
@@ -109,7 +132,7 @@ setupVBOStatic vertexsize = do
         (fromIntegral $ floatSize * numDrawableElements * vertexsize)
         nullPtr
         GL_STATIC_DRAW
-    return VBO{_vboName = vboname, _vboPtr = thePtr, _vboVertexSize = vertexsize}
+    return VBO{_vboName = vboname, _vboPtr = thePtr, _vboVertexBytes = floatSize * vertexsize}
 
 makeByteStringShaderUsingVAO ::
     -- | (Arbitrary) name of the shader
@@ -152,27 +175,25 @@ makeShaderUsingVAO s shaderlist pm theVAO = do
 Compiles a full shader found within the shader directory.
 The shader is made up of files begining with the inputted string with extensions .vert, .geom etc.
 -}
-makeShaderFixedVertices ::
+makeStaticShader ::
+    Storable a =>
     -- | First part of the name of the shader
     String ->
     -- | shader types
     [GLenum] ->
-    -- | The input vertex sizes
+    [VertexAttribute] ->
-    [Int] ->
+    [a] ->
-    -- | Number of vertexes that can be poked
-    Int ->
     PrimitiveMode ->
-    IO (Shader, VBO)
+    IO Shader
-makeShaderFixedVertices s shaderlist sizes ndraw pm = do
+makeStaticShader s shaderlist vas vdata pm = do
     prog <- makeSourcedShader s shaderlist
-    (vao, vbo) <- setupVBOVAO sizes
+    (_, vao) <- setupStaticVBOVAO vas vdata
     return
         ( Shader
             { _shaderUINT = prog
             , _shaderVAO = vao
             , _shaderPrimitive = pm
             }
-        , vbo
         )
 
 {- | Compile shader and get its uniform locations.
@@ -203,32 +224,35 @@ setupVAOvbo sizes strd vbo = do
 
 setupVAOUsingVBO :: [VertexAttribute] -> VBO -> IO VAO
 setupVAOUsingVBO vas vbo = do
-    let strd = vbo ^. vboVertexSize
+    let strd = vbo ^. vboVertexBytes
     vaoname <- mglCreate glCreateVertexArrays
     glBindVertexArray vaoname
     setupVertexAttribs (vbo ^. vboName) vaoname vas 
-        (fromIntegral strd * fromIntegral floatSize)
+        (fromIntegral strd)
     return VAO{_vaoName = vaoname}
 
 setupEBO :: VAO -> IO EBO
 setupEBO vao = do
-    eboptr <- mallocArray numDrawableElements
+    eboptr <- mallocArray numGLushort
     eboname <- mglCreate glCreateBuffers
     glNamedBufferData
         eboname
-        (fromIntegral $ glushortSize * numDrawableElements)
+        (fromIntegral $ glushortSize * numGLushort)
         nullPtr
         GL_STREAM_DRAW
     glVertexArrayElementBuffer (vao ^. vaoName) eboname
     return $ EBO eboname eboptr
 
-setupVBOVAO :: [Int] -> IO (VAO, VBO)
+setupVBOVAO :: [VertexAttribute] -> IO (VAO, VBO)
-setupVBOVAO sizes = do
+setupVBOVAO vas = do
     vaoname <- mglCreate glCreateVertexArrays
     glBindVertexArray vaoname
-    vbo <- setupVBO (sum sizes)
+    vbo <- setupVBO strd
-    vao <- setupVAOvbo (toFloatVAs sizes) (sum sizes) (vbo ^. vboName)
+    --vao <- setupVAOvbo (toFloatVAs sizes) (sum sizes) (vbo ^. vboName)
+    vao <- setupVAOUsingVBO vas vbo
     return (vao,vbo)
+  where
+    strd = vasTightStride vas
 
 toFloatVAs :: [Int] -> [VertexAttribute]
 toFloatVAs = go 0
@@ -340,6 +364,7 @@ attribSize x = case x of
 --    GL_INT_2_10_10_10_REV                 -> sizeOf (0 ::  GL_INT_2_10_10_10_REV)
 --    GL_UNSIGNED_INT_2_10_10_10_REV        -> sizeOf (0 ::  GL_UNSIGNED_INT_2_10_10_10_REV)
 --    GL_UNSIGNED_INT_10F_11F_11F_REV       -> sizeOf (0 ::  GL_UNSIGNED_INT_10F_11F_11F_REV)
+    _ -> error "attribSize : unkown GLenum attribute size"
 
 -- https://hackage.haskell.org/package/OpenGL-3.0.3.0/docs/src/Graphics.Rendering.OpenGL.GL.ByteString.html#withByteStringP
 withByteString :: Num t => BS.ByteString -> (Ptr b -> t -> IO a) -> IO a

src/Shader/Data.hs

@@ -81,7 +81,7 @@ Vertex attributes are interleaved within the vbo.
 data VBO = VBO
     { _vboName :: GLuint
     , _vboPtr :: Ptr Float
-    , _vboVertexSize :: Int
+    , _vboVertexBytes :: Int
     -- add int for AMOUNT of data poked!
     }
 

src/Shader/Parameters.hs

@@ -1,12 +1,18 @@
 module Shader.Parameters
     ( floatSize
+    , ubyteSize
     , numDrawableElements
     , numSubElements
     , glushortSize
+    , numGLushort
     ) where
 import Graphics.GL.Core45
 import Foreign
 
+ubyteSize :: Int
+ubyteSize = sizeOf (5 :: Word8)
+{-# INLINE ubyteSize #-}
+
 floatSize :: Int
 floatSize = sizeOf (0.5 :: GLfloat)
 {-# INLINE floatSize #-}
@@ -19,10 +25,14 @@ glushortSize :: Int
 glushortSize = sizeOf (0 :: GLushort)
 {-# INLINE glushortSize #-}
 
+numGLushort :: Int
+numGLushort = fromIntegral (maxBound :: GLushort) + 1
+{-# INLINE numGLushort #-}
+
 numDrawableElements :: Int
 {-# INLINE numDrawableElements #-}
 numDrawableElements = 6 * numSubElements
 
 numSubElements :: Int
 {-# INLINE numSubElements #-}
-numSubElements = 100000
+numSubElements = 65536

src/Shader/Poke.hs

@@ -3,12 +3,13 @@ module Shader.Poke (
     pokeLayVerxs,
     pokeArrayOff,
     pokeShape,
-    pokeShape',
     pokeWallsWindows,
     memoTopPrismEdgeIndices,
     pokeFloors,
 ) where
 
+import Shape.Parameters
+import Color
 import Control.Monad.Primitive
 import qualified Data.Vector as V
 import qualified Data.Vector.Fusion.Stream.Monadic as VFSM
@@ -98,14 +99,14 @@ pokeW ptr i' ((V2 a b, V2 c d), V4 e f g h) = do
     pokeElemOff ptr (i + 7) h
     return $ i' + 1
 
-pokeShape' ::
+--pokeShape' ::
-    Ptr Float ->
+--    Ptr Float ->
-    Ptr GLushort ->
+--    Ptr GLushort ->
-    Ptr GLushort ->
+--    Ptr GLushort ->
-    (Int, Int, Int) ->
+--    (Int, Int, Int) ->
-    [Surface] ->
+--    [Surface] ->
-    IO (Int, Int, Int)
+--    IO (Int, Int, Int)
-pokeShape' = pokeShape $ const False
+--pokeShape' = pokeShape $ const False
 
 pokeShape ::
     (Surface -> Bool) ->
@@ -115,6 +116,7 @@ pokeShape ::
     (Int, Int, Int) ->
     [Surface] ->
     IO (Int, Int, Int)
+{-# INLINE pokeShape #-}
 pokeShape shadowtest ptr iptr ieptr is =
     VFSM.foldlM' (pokeShapeObj shadowtest ptr iptr ieptr) is
         . VFSM.fromList
@@ -226,12 +228,15 @@ pokeBox ::
     IO (Int, Int, Int)
 {-# INLINE pokeBox #-}
 pokeBox sfid col size ptr iptr ieptr (nv, nsi, nei) svs = do
-    nv' <- VFSM.foldM' (pokeBoxSurface xdata col ptr svsv) nv $ VFSM.fromList $ boxSurfaces size
+    nv' <- VFSM.foldM' (pokeBoxSurface xdata col ptr svsv) nv $ VFSM.fromList $ memoBoxSurfaces V.! size
+--    nv' <- VFSM.foldM' (pokeBoxSurface xdata col ptr svsv) nv $ VFSM.fromList $ boxSurfaces size
     nsi' <-
         UV.foldM'
             (pokeIndex nv iptr)
             nsi
             (memoFlatIndices V.! (size -3))
+--        VFSM.foldM' (pokeIndex nv iptr) nsi 
+--            (VFSM.fromList . concatMap polyToTris $ boxSurfacesIndices size)
     nei' <-
         if sfid
             then return nei
@@ -262,6 +267,7 @@ pokeBoxSurface xdata col ptr vs n is =
 
 -- should probably memoize this
 boxSurfaces :: Int -> [[Int]]
+{-# INLINE boxSurfaces #-}
 boxSurfaces size =
     [0, 2 .. size * 2 -1] :
     [1, 3 .. size * 2] :
@@ -269,7 +275,12 @@ boxSurfaces size =
   where
     f x = map (`mod` (size * 2)) [x, x + 1, x + 3, x + 2]
 
+memoBoxSurfaces :: V.Vector [[Int]]
+{-# INLINE memoBoxSurfaces #-}
+memoBoxSurfaces = V.generate 10 $ boxSurfaces
+
 boxSurfacesIndices :: Int -> [[Int]]
+{-# INLINE boxSurfacesIndices #-}
 boxSurfacesIndices n =
     [0 .. n -1] :
     reverse [n .. n * 2 -1] :
@@ -302,11 +313,13 @@ memoTopPrismIndices =
         UV.fromList . topPrismIndices . (+ 3)
 
 memoCylinderIndices :: V.Vector (UV.Vector Int)
+{-# INLINE memoCylinderIndices #-}
 memoCylinderIndices =
     V.generate 10 $
         UV.fromList . cylinderIndices . (+ 3)
 
 memoTopPrismEdgeIndices :: V.Vector (UV.Vector Int)
+{-# INLINE memoTopPrismEdgeIndices #-}
 memoTopPrismEdgeIndices =
     V.generate 10 $
         UV.fromList . topPrismEdgeIndices . (+ 3)
@@ -315,28 +328,21 @@ topPrismEdgeIndices ::
     -- | the number of vertices on the top surface, ie. half the total
     Int ->
     [Int]
+{-# INLINE topPrismEdgeIndices #-}
 topPrismEdgeIndices n = concatMap f [0 .. n -1]
   where
     f i =
         map
             g
-            [ 0
+            [ 0 , 2 , 1 , 4
-            , 2
+            , 0 , 1 , -2 , 3
-            , 1
+            , 1 , 3 , -1 , 2
-            , 4
-            , 0
-            , 1
-            , -2
-            , 3
-            , 1
-            , 3
-            , -1
-            , 2
             ]
       where
         g j = (2 * i + j) `mod` (2 * n)
 
 memoBoxEdgeIndices :: V.Vector (UV.Vector Int)
+{-# INLINE memoBoxEdgeIndices #-}
 memoBoxEdgeIndices =
     V.generate 10 $
         UV.fromList . boxEdgeIndices . (+ 3)
@@ -345,6 +351,7 @@ boxEdgeIndices ::
     -- | the number of vertices on the top surface, ie. half the total
     Int ->
     [Int]
+{-# INLINE boxEdgeIndices #-}
 boxEdgeIndices n = concatMap f [0 .. n -1]
   where
     f i =
@@ -365,12 +372,14 @@ boxEdgeIndices n = concatMap f [0 .. n -1]
         g j = (i + j) `mod` n
 
 cylinderIndices :: Int -> [Int]
+{-# INLINE cylinderIndices #-}
 cylinderIndices n =
     cylinderRoundIndices n
         ++ polyToTris [2 * n, 2 * n + 2 .. 4 * n - 1]
         ++ polyToTris [2 * n + 1, 2 * n + 3 .. 4 * n - 1]
 
 cylinderRoundIndices :: Int -> [Int]
+{-# INLINE cylinderRoundIndices #-}
 cylinderRoundIndices n =
     [ 2 * n -2
     , 2 * n -1
@@ -391,6 +400,7 @@ cylinderRoundIndices n =
         ]
 
 topPrismIndices :: Int -> [Int]
+{-# INLINE topPrismIndices #-}
 topPrismIndices n =
     concatMap f [1 .. n -2] -- triangles on top face
         ++ concatMap f' [1 .. n -2] -- triangles on bottom face
@@ -426,12 +436,12 @@ pokeJustV ::
     IO Int
 {-# INLINE pokeJustV #-}
 pokeJustV xdata cp col ptr nv sh = do
-    UV.imapM_ f $ UV.fromList [x, y, z, xdata, r, g, b, a, nx, ny, nz, 1]
+    pokeByteOff ptr (nv * shapeVerxSize) (V4 x y z xdata)
+    pokeByteOff ptr (nv *shapeVerxSize + 4 * floatSize) (toColor8 col)
+    pokeByteOff ptr (nv *shapeVerxSize + 4 * (floatSize + ubyteSize)) (V4 nx ny nz 1)
     return (nv + 1)
   where
-    f i = pokeElemOff ptr (nv * nShapeVerxComp + i)
     V3 x y z = sh
-    V4 r g b a = col
     V3 nx ny nz = cp
 
 pokeJustVInvNormal ::
@@ -444,12 +454,12 @@ pokeJustVInvNormal ::
     IO Int
 {-# INLINE pokeJustVInvNormal #-}
 pokeJustVInvNormal xdata cp col ptr nv sh = do
-    UV.imapM_ f $ UV.fromList [x, y, z, xdata, r, g, b, a, nx, ny, nz, 1]
+    pokeByteOff ptr (nv * shapeVerxSize) (V4 x y z xdata)
+    pokeByteOff ptr (nv *shapeVerxSize + 4 * floatSize) (toColor8 col)
+    pokeByteOff ptr (nv *shapeVerxSize + 4 * (floatSize + ubyteSize)) (V4 nx ny nz 1)
     return (nv + 1)
   where
-    f i = pokeElemOff ptr (nv * nShapeVerxComp + i)
     V3 x y z = sh
-    V4 r g b a = col
     V3 nx ny nz = (2 * sh) - cp
 
 pokeFlatV ::
@@ -462,12 +472,12 @@ pokeFlatV ::
     IO Int
 {-# INLINE pokeFlatV #-}
 pokeFlatV xdata norm col ptr nv sh = do
-    UV.imapM_ f $ UV.fromList [x, y, z, xdata, r, g, b, a, nx, ny, nz, 1]
+    pokeByteOff ptr (nv * shapeVerxSize) (V4 x y z xdata)
+    pokeByteOff ptr (nv *shapeVerxSize + 4 * floatSize) (toColor8 col)
+    pokeByteOff ptr (nv *shapeVerxSize + 4 * (floatSize + ubyteSize)) (V4 nx ny nz 1)
     return (nv + 1)
   where
-    f i = pokeElemOff ptr (nv * nShapeVerxComp + i)
     V3 x y z = sh
-    V4 r g b a = col
     V3 nx ny nz = sh - norm
 
 pokeLayVerxs ::

src/Shape/Data.hs

@@ -52,11 +52,12 @@ makeLenses ''ShapeType
 
 type Shape = [Surface]
 
-nShapeVerxComp :: Int
-nShapeVerxComp = sum shapeVerxSizes
 
-shapeVerxSizes :: [Int]
+--nShapeVerxComp :: Int
-shapeVerxSizes = [4,4,4]
+--nShapeVerxComp = sum shapeVerxSizes
+--
+--shapeVerxSizes :: [Int]
+--shapeVerxSizes = [4,4,4]
 
 deriveJSON defaultOptions ''ShadowFidelity
 deriveJSON defaultOptions ''ShapeType

src/Shape/Parameters.hs

@@ -0,0 +1,19 @@
+module Shape.Parameters
+    where
+
+import Shader.Parameters
+import Shader.Data
+import Data.Word
+import Foreign.Storable
+import Graphics.GL.Core45
+
+shapeVerxSize :: Int
+shapeVerxSize = sizeOf (0 :: Float) * 8 + 4 * sizeOf (0 :: Word8)
+
+shapeVerxAttributes :: [VertexAttribute]
+shapeVerxAttributes = 
+        [VertexAttribute 4 GL_FLOAT GL_FALSE 0 
+        ,VertexAttribute 4 GL_UNSIGNED_BYTE GL_TRUE (fromIntegral (4 :: Int) * fromIntegral floatSize) 
+        ,VertexAttribute 4 GL_FLOAT GL_FALSE (fromIntegral (4 :: Int) * fromIntegral (floatSize + ubyteSize))
+        ]
+