Implement texture atlas, details on why it works unclear

shader/texture/array.frag

@@ -0,0 +1,10 @@
+#version 430 core
+in vec3 vTexPos;
+out vec4 fColor;
+
+uniform sampler2DArray tilesetSampler;
+
+void main()
+{
+    fColor = texture(tilesetSampler, vTexPos);
+}

shader/texture/array.vert

@@ -0,0 +1,12 @@
+#version 430 core
+layout (location = 0) in vec3 pos;
+layout (location = 1) in vec3 texPos;
+out vec3 vTexPos;
+
+uniform mat4 worldMat;
+
+void main()
+{
+  gl_Position = worldMat * vec4(pos,1.0) ;
+  vTexPos = texPos;
+}

shader/texture/simpleWorld.vert

@@ -7,6 +7,6 @@ uniform mat4 worldMat;
 
 void main()
 {
-  gl_Position = worldMat * vec4(pos,1);
+  gl_Position = worldMat * vec4(pos,1.0) ;
   vTexPos = texPos;
 }

shader/twoD/basic.vert

@@ -7,6 +7,6 @@ uniform mat4 worldMat;
 
 void main()
 {
-  gl_Position = worldMat * vec4(position.xyz,1);
+  gl_Position = worldMat * vec4(position,1);
   vColor = color;
 }

src/Data/Preload/Render.hs

@@ -13,7 +13,8 @@ data RenderData = RenderData
     , _wallBlankShader          :: FullShader
     , _wallTextureShader        :: FullShader
     , _backgroundShader         :: FullShader
-    --, _textureShader            :: FullShader (Point3,Point2)
+    , _textureShader            :: FullShader
+    , _textureArrayShader       :: FullShader
     , _fullscreenShader         :: FullShader
     , _boxBlurShader            :: FullShader
     , _grayscaleShader          :: FullShader

src/Dodge/Data.hs

@@ -63,6 +63,7 @@ data World = World
     , _wallsZone            :: IM.IntMap (IM.IntMap (IM.IntMap Wall))
     , _forceFields          :: IM.IntMap ForceField
     , _floorItems           :: IM.IntMap FloorItem
+    , _floorTiles           :: [RenderType]
     , _randGen              :: StdGen
     , _mousePos             :: !(Float,Float)
     , _testString           :: String

src/Dodge/Default/World.hs

@@ -9,6 +9,7 @@ import Dodge.Config.KeyConfig
 import Dodge.Item.Data
 import Picture
 import Geometry
+import Picture.Texture
 
 import System.Random
 import qualified Data.IntMap.Strict as IM
@@ -36,6 +37,17 @@ defaultWorld = World
     , _wallsZone = IM.empty
     , _forceFields = IM.empty
     , _floorItems = IM.empty
+    , _floorTiles = 
+        let x = 200
+            y = 0.9
+            z = 16
+            r = 4
+        in tileToRender [(0,0,z),(r,0,z),(r,r,z),(0,r,z)]
+            [(20,100 + 20,y)
+            ,( x,100 + 20,y)
+            ,( x,100 +  x,y)
+            ,(20,100 +  x,y)
+            ]
     , _randGen = mkStdGen 2
     , _mousePos = (0,0)
     , _testString = []

src/Dodge/Render.hs

@@ -1,8 +1,7 @@
 {- |
 Contains the central drawing functions for the dodge loop. -}
 module Dodge.Render 
-    ( module Dodge.Render.Picture
+    ( doDrawing
-    , doDrawing
     )
   where
 import Dodge.Data
@@ -39,10 +38,8 @@ import Data.Tuple.Extra
 import Graphics.Rendering.OpenGL hiding (color,scale,translate,rotate)
 import qualified SDL
 
-{- |
+{- | Central drawing function.
-Central drawing function.
+Returns a 'Word32' that should give the number of ticks it took to evaluate.  -}
-Returns a 'Word32' that should give the number of ticks it took to evaluate.
- -}
 doDrawing :: RenderData -> World -> IO Word32
 doDrawing pdata w = do
     sTicks <- SDL.ticks
@@ -73,6 +70,9 @@ doDrawing pdata w = do
     -- the depth buffer is ready to be drawn on
     blendFuncSeparate    $= ((SrcAlphaSaturate, OneMinusSrcAlpha), (Zero,One))
     renderBackground pdata rot camzoom trans wins
+
+    _ <- renderShader (_textureArrayShader pdata) (_floorTiles w)
+
     -- draw the walls
     depthFunc $= Just Less
     if w ^. config . wall_textured

src/Picture/Data.hs

@@ -25,6 +25,7 @@ data RenderType
     | Render22 {_unRender22 :: (Point2,Point2)}
     | Render22x4 {_unRender22x4 :: ((Point2,Point2),Point4)}
     | Render3x2 {_unRender3x2 :: (Point3,Point2)}
+    | Render3x3 {_unRender3x3 :: (Point3,Point3)}
 
 type RGBA = (Float,Float,Float,Float)
 type Color = (Float,Float,Float,Float)

src/Picture/Render.hs

@@ -198,7 +198,7 @@ renderBackground pdata rot camZoom (tranx,trany) (winx,winy) = do
     --blendFuncSeparate    $= ((SrcAlphaSaturate, OneMinusSrcAlpha), (Zero,One))
 -- draw background
     --bindArrayBuffers 1 $ _vaoBufferTargets $ _shaderVAO $ _backgroundShader pdata
-    bindArrayBuffers' 1 $ _vaoVBO $ _shaderVAO $ _backgroundShader pdata
+    bindArrayBuffers 1 $ _vaoVBO $ _shaderVAO $ _backgroundShader pdata
     currentProgram $= Just (_shaderProgram $ _backgroundShader pdata)
     bindVertexArrayObject $= Just (_vao $ _shaderVAO $ _backgroundShader pdata)
     let backPtr = _vboPointer $ _vaoVBO $ _shaderVAO $ _backgroundShader pdata
@@ -219,6 +219,7 @@ setCommonUniforms pdata rot camZoom (tranx,trany) (winx,winy) = do
         : extractProgAndUnis (_lightingOccludeShader pdata) 
         : extractProgAndUnis (_lightingWallShader pdata) 
         : extractProgAndUnis (_backgroundShader pdata) 
+        : extractProgAndUnis (_textureShader pdata) 
         : map extractProgAndUnis (_pictureShaders pdata)
         )
 
@@ -233,7 +234,8 @@ setIsoMatrixUniforms pdata rot camZoom (tranx,trany) (winx,winy) = do
     setShaderUniforms rot camZoom (tranx,trany) (winx,winy) 
         ( extractProgAndUnis (_lightingFloorShader pdata) 
         : extractProgAndUnis (_backgroundShader pdata) 
-        -- : extractProgAndUnis (_textureShader pdata)
+        : extractProgAndUnis (_textureShader pdata)
+        : extractProgAndUnis (_textureArrayShader pdata)
         : map extractProgAndUnis (_pictureShaders pdata)
         )
 
@@ -250,6 +252,12 @@ renderShader shad dat = do
     eticks <- SDL.ticks
     return $ eticks - sticks
 
+--renderPictureLayer
+--    :: PictureShaderData
+--    -> Picture
+--    -> IO Word32
+--renderPictureLayer 
+
 renderFoldable
     :: Foldable f
     => RenderData

src/Picture/Texture.hs

@@ -0,0 +1,15 @@
+module Picture.Texture
+    where
+import Geometry.Data
+import Picture.Data
+
+tileToRender :: [Point3] -> [Point3] -> [RenderType]
+tileToRender [a,b,c,d] [x,y,z,w] = 
+    [ Render3x3 (x,a)
+    , Render3x3 (y,b)
+    , Render3x3 (z,c)
+    , Render3x3 (x,a)
+    , Render3x3 (z,c)
+    , Render3x3 (w,d)
+    ]
+tileToRender _ _ = undefined

src/Picture/Tree.hs

@@ -14,7 +14,7 @@ import Data.Maybe (isNothing)
 -- consider generalising to alternative rather than using LTree
 -- | Transform a picture into a tree of renderable objects
 picToLTree 
-    :: Maybe Int -- ^ Layer filter. Draw if 'Nothing' or when value is the same as at the leaf.
+    :: Maybe Int -- ^ Layer filter. Draw 'Nothing' when value is the same as at the leaf.
     -> Picture
     -> LTree RenderType
 {-# INLINE picToLTree #-}

src/Preload.hs

@@ -1,10 +1,6 @@
 module Preload
-    ( module Preload
-    , module Preload.Update
-    )
   where
 import Data.Preload
-import Preload.Update
 import Preload.Render
 import Sound.Data
 

src/Preload/Render.hs

@@ -10,7 +10,6 @@ import Shader
 import Shader.Data
 import Shader.Compile
 import Shader.AuxAddition
-import Geometry.Data
 import Data.Preload.Render
 
 import Graphics.Rendering.OpenGL hiding (Point,translate,scale,imageHeight)
@@ -54,8 +53,12 @@ preloadRender = do
                 >>= addTexture "data/texture/grayscaleDirt.png"
 
 ---- texture shader
---    textShad <- makeShader "texture/simpleWorld" [vert,frag] [(0,3),(1,2)] Triangles poke32
+    textShad <- makeShader "texture/simpleWorld" [vert,frag] [3,2] Triangles poke32
---        >>= addTexture "data/texture/ayene_wooden_floor.png"
+        >>= addTexture "data/texture/ayene_wooden_floor.png"
+
+---- texture array shader
+    textArrayShad <- makeShader "texture/array" [vert,frag] [3,3] Triangles poke33
+        >>= addTextureArray "data/texture/ayene_wooden_floor.png"
 
 -- framebuffer for lighting
     (fbo,fboTO,fboRBO) <- setupFramebufferWithStencil
@@ -70,7 +73,8 @@ preloadRender = do
         , _lightingWallShader       = wlLightShad
         , _wallBlankShader          = wlBlank
         , _wallTextureShader        = wlTexture
-        --, _textureShader            = textShad
+        , _textureShader            = textShad
+        , _textureArrayShader       = textArrayShad
         , _backgroundShader         = bgShad
         , _fullscreenShader         = fsShad
         , _boxBlurShader            = boxBlurShad
@@ -195,8 +199,13 @@ pokeWPColStrat :: RenderType -> [[Float]]
 pokeWPColStrat Render22x4{_unRender22x4=(((x,y),(z,w)),(r,g,b,a))} = [[x,y,z,w,r,g,b,a]]
 pokeWPColStrat _ = undefined
 
-poke32 :: (Point3,Point2) -> [[Float]]
+poke32 :: RenderType -> [[Float]]
-poke32 ((x,y,z),(a,b)) = [[x,y,z,a,b]]
+poke32 Render3x2{_unRender3x2=((x,y,z),(a,b))} = [[x,y,z,a,b]]
+poke32 _ = undefined
+
+poke33 :: RenderType -> [[Float]]
+poke33 Render3x3{_unRender3x3=((x,y,z),(a,b,c))} = [[x,y,z,a,b,c]]
+poke33 _ = undefined
 
 pokeBGStrat :: a -> [[Float]]
 pokeBGStrat = const []

src/Shader.hs

@@ -1,5 +1,5 @@
 module Shader
-    ( bindArrayBuffers'
+    ( bindArrayBuffers
     , bindShaderBuffers
     , drawShader
     , drawShaders
@@ -24,8 +24,8 @@ import Linear.V4
 extractProgAndUnis :: FullShader -> (Program,UniformLocation)
 extractProgAndUnis s = (_shaderProgram s, _shaderMatrixUniform s)
 
-bindArrayBuffers' :: Int -> VBO -> IO ()
+bindArrayBuffers :: Int -> VBO -> IO ()
-bindArrayBuffers' numVs theVBO = do
+bindArrayBuffers numVs theVBO = do
     bindBuffer ArrayBuffer $= Just (_vbo theVBO)
     bufferData ArrayBuffer $= 
         (fromIntegral $ floatSize * numVs * (sum $ _vboAttribSizes theVBO), _vboPointer theVBO, DynamicDraw)
@@ -34,7 +34,7 @@ bindArrayBuffers' numVs theVBO = do
 bindShaderBuffers :: [FullShader] -> [Int] -> IO ()
 bindShaderBuffers = zipWithM_ f
   where 
-    f fs i = bindArrayBuffers' i $ _vaoVBO $ _shaderVAO fs
+    f fs i = bindArrayBuffers i $ _vaoVBO $ _shaderVAO fs
 
 drawShaders :: [FullShader] -> [Int] -> IO ()
 drawShaders = zipWithM_ drawShader

src/Shader/AuxAddition.hs

@@ -1,9 +1,11 @@
 module Shader.AuxAddition
     ( addTexture
+    , addTextureArray
     , addUniforms
     ) where
 import Shader.Data
 
+import Data.List.Extra
 import Foreign
 import Codec.Picture
 import qualified Data.Vector.Storable as V
@@ -29,6 +31,31 @@ addTexture texturePath shad = do
     textureFilter Texture2D $= ((Linear',Just Linear') , Nearest)
     return $ shad & shaderTexture ?~ ShaderTexture {_textureObject = textureOb}
 
+addTextureArray :: String -> FullShader -> IO (FullShader)
+addTextureArray texturePath shad = do
+    Right cmap <- readImage texturePath
+    let tex = convertRGBA8 cmap
+    textureOb <- genObjectName
+    textureBinding Texture2DArray $= Just textureOb
+    let texData = tilesToLine 128 32 8 . 
+            V.toList $ imageData tex
+        --wtex = fromIntegral $ imageWidth  tex
+        --htex = fromIntegral $ imageHeight tex
+    withArray texData $ \ptr -> do
+        texImage3D Texture2DArray NoProxy 0 RGBA8 (TextureSize3D 32 32 64) 0 
+                        (PixelData RGBA UnsignedByte ptr)
+    textureFilter Texture2DArray $= ((Linear',Just Linear') , Linear')
+    generateMipmap' Texture2DArray
+    return $ shad & shaderTexture ?~ ShaderTexture {_textureObject = textureOb}
+
+-- I am completely unclear on why this works with its current parameters
+tilesToLine 
+    :: Int -- ^ Tile width
+    -> Int -- ^ Tile height
+    -> Int -- ^ Number of tiles per line
+    -> [a]
+    -> [a]
+tilesToLine w h n = concat . concat . transpose . chunksOf n . chunksOf w
 
 addUniforms :: [String] -> FullShader -> IO (FullShader)
 addUniforms uniStrings shad = do