Use texture array for character rendering, condense rendering

src/Dodge/Render.hs

@@ -62,7 +62,7 @@ doDrawing' win pdata u = do
     -- count mutable vectors setup
     layerCounts <- UMV.replicate (numLayers * 6) 0
     -- attempt to poke in parallel
-    let (ws, wp) = wallSPics <> worldSPic cfig w
+    let (ws, wp) = wallSPics <> worldSPic cfig u
     ((nWalls, nWins,trueNWalls), (nShapeVs, nIndices, nSilIndices)) <-
         MP.bindM3
             (\_ a b -> return (a, b))
@@ -373,16 +373,15 @@ doDrawing' win pdata u = do
     glBlendFunc GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA
     glBindBufferBase GL_UNIFORM_BUFFER 0 (pdata ^. orthonormalMatUBO)
     renderLayer FixedCoordLayer shadV layerCounts
-    renderFoldable shadV $ fixedCoordPictures u
     glDepthMask GL_TRUE
-    when (debugOn Show_ms_frame $ _uvConfig u) $
+--    when (debugOn Show_ms_frame $ _uvConfig u) $
-        renderFoldable
+--        renderFoldable
-            (_pictureShaders pdata)
+--            (_pictureShaders pdata)
-            ( setDepth (-1)
+--            ( setDepth (-1)
-                . translate (-0.5) (-0.8)
+--                . translate (-0.5) (-0.8)
-                . scale 0.0005 0.0005
+--                . scale 0.0005 0.0005
-                $ fpsText (u ^. uvFrameTicks - u ^. uvLastFrameTicks)
+--                $ fpsText (u ^. uvFrameTicks - u ^. uvLastFrameTicks)
-            )
+--            )
     SDL.glSwapWindow win
 
 fpsText :: (Show a, Ord a, Num a) => a -> Picture

src/Dodge/Render/Picture.hs

@@ -17,9 +17,29 @@ fixedCoordPictures u = drawMenuOrHUD cfig u
     <> drawConcurrentMessage u 
     <> customMouseCursor cfig (u ^. uvWorld . input)
     <> listPicturesAt (halfWidth cfig) 0 cfig (map text (_uvTestString u u))
+    <> displayFrameTicks u
   where
     cfig = _uvConfig u
 
+displayFrameTicks :: Universe -> Picture
+displayFrameTicks u =   if (debugOn Show_ms_frame $ _uvConfig u) then
+         ( setDepth (-1)
+                . translate (-0.5) (-0.8)
+                . scale 0.0005 0.0005
+                $ fpsText (u ^. uvFrameTicks - u ^. uvLastFrameTicks)
+            )
+  else mempty
+
+fpsText :: (Show a, Ord a, Num a) => a -> Picture
+fpsText x = color col $ text $ "ms/frame " ++ show x
+  where
+    col
+        | x < 22 = blue
+        | x < 30 = green
+        | x < 40 = yellow
+        | x < 50 = orange
+        | otherwise = red
+
 drawMenuOrHUD :: Configuration -> Universe -> Picture
 drawMenuOrHUD cfig u = case u ^. uvScreenLayers of
     [] -> drawHUD (u ^. uvConfig) (u ^. uvWorld)

src/Dodge/Render/ShapePicture.hs

@@ -2,6 +2,8 @@ module Dodge.Render.ShapePicture (
     worldSPic,
 ) where
 
+import Dodge.Render.Picture
+import Dodge.Data.Universe
 import Control.Lens
 import Control.Monad (guard)
 import Data.Foldable
@@ -41,9 +43,9 @@ import ShapePicture
 import ShortShow
 import Sound.Data
 
-worldSPic :: Configuration -> World -> SPic
+worldSPic :: Configuration -> Universe -> SPic
-worldSPic cfig w =
+worldSPic cfig u =
-    (mempty, extraPics cfig w)
+    (mempty, extraPics cfig u)
         <> foldup drawProp' (filtOn _prPos _props)
         <> foldup drawProjectile (filtOn _prjPos _projectiles)
         <> foldup (shiftDraw _blPos _blDir (drawBlock . _blDraw)) (filtOn _blPos _blocks)
@@ -56,6 +58,7 @@ worldSPic cfig w =
         <> aimDelaySweep cfig w
         <> anyTargeting cfig w
   where
+    w = _uvWorld u
     foldup = foldMap'
     filtOn f g = IM.filter (pointIsClose . f) (g (_lWorld (_cWorld w)))
     pointIsClose = cullPoint cfig w
@@ -144,9 +147,10 @@ cullPoint cfig w p
     | debugOn Close_shape_culling cfig = pointInPolygon p (w ^. cWorld . camPos . camBoundBox)
     | otherwise = dist (w ^. cWorld . camPos . camCenter) p < (w ^. cWorld . camPos . camViewDistance)
 
-extraPics :: Configuration -> World -> Picture
+extraPics :: Configuration -> Universe -> Picture
-extraPics cfig w =
+extraPics cfig u =
     pictures (_decorations lw)
+        <> setLayer FixedCoordLayer (fixedCoordPictures u)
         <> concatMapPic drawTractorBeam (_tractorBeams lw)
         <> concatMapPic drawLinearShockwave (_linearShockwaves lw)
         <> concatMapPic drawShockwave (_shockwaves lw)
@@ -167,6 +171,7 @@ extraPics cfig w =
         <> viewClipBounds cfig w
         <> debugDraw cfig w
   where
+    w = u ^. uvWorld
     lw = w ^. cWorld . lWorld
 
 debugDraw :: Configuration -> World -> Picture

src/Dodge/TestString.hs

@@ -14,8 +14,6 @@ import Dodge.Data.Universe
 testStringInit :: Universe -> [String]
 testStringInit u = [show $ length $ lightsToRender (u ^. uvConfig) (u ^. uvWorld . cWorld . camPos) 
         (u ^. uvWorld . cWorld . lWorld)
-        , show $ length $ fst $ worldSPic (u ^. uvConfig) (u ^. uvWorld)
-        , show $ length $ snd $ worldSPic (u ^. uvConfig) (u ^. uvWorld) 
         , show $ u ^. uvWorld . input . scrollTestInt
         ]
     --[show $ u ^? uvWorld . hud . hudElement . diSections . sssExtra . sssSelPos . _Just]

src/Picture/Base.hs

@@ -202,7 +202,7 @@ text :: String -> Picture
 {-# INLINE text #-}
 text = map f . stringToList
   where
-    f (pos, col, V2 a b) = Verx pos col [a, b] BottomLayer textNum
+    f (pos, col, V3 a b c) = Verx pos col [a, b, c, 1] BottomLayer textNum
 
 line :: [Point2] -> Picture
 {-# INLINE line #-}
@@ -291,25 +291,26 @@ overCol :: (Point4 -> Point4) -> Verx -> Verx
 overCol f vx = vx{_vxCol = f (_vxCol vx)}
 
 -- no premature optimisation, consider changing to use texture arrays
-stringToList :: String -> [(Point3, Point4, Point2)]
+stringToList :: String -> [(Point3, Point4, Point3)]
 {-# INLINE stringToList #-}
 stringToList = concatMap (uncurry charToTuple) . zip [0, 0.9 * dimText ..]
   where
     dimText = 100
 
-charToTuple :: Float -> Char -> [(Point3, Point4, Point2)]
+charToTuple :: Float -> Char -> [(Point3, Point4, Point3)]
 {-# INLINE charToTuple #-}
-charToTuple x c =
+charToTuple xoff c = [f 0 0, f 1 0, f 1 1, f 0 0, f 1 1, f 0 1]
-    [ (V3 (x -50) (-100) 0, white, V2 offset 1)
-    , (V3 (x -50) 100 0, white, V2 offset 0)
-    , (V3 (x + 50) 100 0, white, V2 (offset + 1) 0)
-    , (V3 (x -50) (-100) 0, white, V2 offset 1)
-    , (V3 (x + 50) (-100) 0, white, V2 (offset + 1) 1)
-    , (V3 (x + 50) 100 0, white, V2 (offset + 1) 0)
-    ]
   where
+    f x y = (V3 (xoff - 50 + x * 100) (100 - y * 200) 0, white, V3 x y offset)
     offset = fromIntegral (fromEnum c) - 32
 
+--charToTuple' :: Float -> Char -> [(Point3, Point4, Point3)]
+--{-# INLINE charToTuple' #-}
+--charToTuple' xoff c = [f 0 0, f 1 0, f 1 1, f 0 0, f 1 1, f 0 1]
+--  where
+--    f x y = (V3 (xoff + x * 100) (y * 200) 0, white, V3 x y offset)
+--    offset = fromIntegral (fromEnum c) - 32
+
 mirrorxz :: Picture -> Picture
 mirrorxz = picMap (overPos flipy)
   where

src/Picture/Data.hs

@@ -36,7 +36,6 @@ numLayers = length [minBound :: Layer .. maxBound]
 
 data ShadNum
     = PolyShad
-    | BezShad
     | TextShad
     | ArcShad
     | EllShad

src/Preload/Render.hs

@@ -129,8 +129,9 @@ preloadRender = do
     aslist <- makeShader "dualTwoD/arc" [vert, frag] [3, 4, 3] pmTriangles
     eslist <- makeShader "dualTwoD/ellipse" [vert, geom, frag] [3, 4] pmTriangles
     cslist <-
-        makeShader "dualTwoD/character" [vert, frag] [3, 4, 2] pmTriangles
+        makeShader "picture/textureArray" [vert, frag] [3, 4, 4] pmTriangles
-            >>= _1 (vaddTextureNoFilter "data/texture/charMap.png")
+--            >>= _1 (addTextureArray' "data/texture/charMapVert.png" 2 16 32 95 GL_LINEAR_MIPMAP_LINEAR GL_LINEAR)
+            >>= _1 (addTextureArray' "data/texture/charMapVert.png" 2 16 32 95 GL_NEAREST_MIPMAP_LINEAR GL_LINEAR)
     -- this should really be a 2d texture array
 
     screentexturevbo <- mglCreate glCreateBuffers

src/Shader/AuxAddition.hs

@@ -2,6 +2,7 @@ module Shader.AuxAddition
     ( addSamplerTexture2D
     , vaddTextureNoFilter
     , addTextureArray
+    , addTextureArray'
     , initTexture2D
     , initTexture2DArray
     , tilesToLine
@@ -127,6 +128,20 @@ addTextureArray texturePath (shad,vbo) = do
         return (shad & shaderTextures .:~ TO texname 
             , vbo)
 
+addTextureArray' :: String -> GLsizei -> GLsizei -> GLsizei -> GLsizei -> GLenum -> GLenum 
+    -> Shader -> IO Shader
+addTextureArray' fp nlev w h d minfilt magfilt shad = do
+    Right cmap <- readImage fp
+    let texdata = convertRGBA8 cmap
+    texname <- mglCreate $ glCreateTextures GL_TEXTURE_2D_ARRAY
+    glTextureStorage3D texname nlev GL_RGBA8 w h d
+    VS.unsafeWith (imageData texdata) $ \ptr -> do
+        glTextureSubImage3D texname 0 0 0 0 w h d GL_RGBA GL_UNSIGNED_BYTE ptr
+        glGenerateTextureMipmap texname
+        glTextureParameteri texname GL_TEXTURE_MIN_FILTER (unsafeCoerce minfilt)
+        glTextureParameteri texname GL_TEXTURE_MAG_FILTER (unsafeCoerce magfilt)
+        return (shad & shaderTextures .:~ TO texname )
+
 tilesToLine 
     :: Int -- ^ Parameter a
     -> Int -- ^ Parameter b

src/Shader/Poke.hs

@@ -34,15 +34,15 @@ 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 ()
-pokeVerx vbos offsets Verx{_vxPos = thePos, _vxCol = theCol, _vxExt = ext, _vxShadNum = theShadNum} = do
+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
-    let thePtr = plusPtr basePtr (typeOff * pokeStride sn * floatSize)
+    let thePtr = plusPtr basePtr (typeOff * pokeStride shadnum * floatSize)
     poke34 thePtr thePos theCol
     pokeArrayOff thePtr 7 ext
     UMV.unsafeModify offsets (+ 1) sn
   where
-    sn = _unShadNum theShadNum
+    sn = _unShadNum shadnum
 
 pokeWallsWindows ::
     Ptr Float ->
@@ -416,21 +416,21 @@ pokeLayVerx vbos counts vx = do
     pokeArrayOff thePtr 7 (_vxExt vx)
     UMV.unsafeModify counts (+ 1) vecPos
   where
-    sn = _unShadNum (_vxShadNum vx)
+    sn = _unShadNum shadnum
+    shadnum = _vxShadNum vx
     vecPos = theLayer * numLayers + sn
     theLayer = layerNum $ _vxLayer vx
     thePos = _vxPos vx
     theCol = _vxCol vx
     layOff = theLayer * numSubElements
-    theStride = pokeStride sn
+    theStride = pokeStride shadnum
 
-pokeStride :: Int -> Int
+pokeStride :: ShadNum -> Int
 {-# INLINE pokeStride #-}
-pokeStride 0 = 7
+pokeStride PolyShad = 7
-pokeStride 1 = 9
+pokeStride TextShad = 11
-pokeStride 2 = 10
+pokeStride ArcShad = 10
-pokeStride 3 = 7
+pokeStride EllShad = 7
-pokeStride _ = undefined
 
 poke34 :: Ptr Float -> Point3 -> Point4 -> IO ()
 {-# INLINE poke34 #-}