working on textures

pituicat.cabal

@@ -21,11 +21,16 @@ executable pituicat
                      , Types.Application
                      , Types.Subsystems
                      , Types.GameMap
+                     , Types.Texture
+                     , Classes
+                     , Classes.Bindable
                      , Map
+                     , Texture
   -- other-extensions:
   build-depends:       base ^>=4.13.0.0
                      , affection
                      , stm
+                     , OpenGL
                      , sdl2
                      , containers
                      , linear
@@ -33,5 +38,6 @@ executable pituicat
                      , aeson
                      , vector
                      , JuicyPixels
+                     , JuicyPixels-extra
   hs-source-dirs:      src
   default-language:    Haskell2010

shell.nix

@@ -24,8 +24,8 @@ let
       license = stdenv.lib.licenses.lgpl3;
     }) {};
 
-  f = { mkDerivation, aeson, base, containers, JuicyPixels, linear, stdenv
-      , sdl2, stm, text, vector}:
+  f = { mkDerivation, aeson, base, containers, JuicyPixels, JuicyPixels-extra
+      , linear, OpenGL, stdenv , sdl2, stm, text, vector}:
       mkDerivation {
         pname = "pituicat";
         version = "0.0.0.0";
@@ -33,7 +33,7 @@ let
         isLibrary = false;
         isExecutable = true;
         executableHaskellDepends = [ aeson affection base linear containers
-        JuicyPixels sdl2 stm text vector];
+        JuicyPixels JuicyPixels-extra OpenGL sdl2 stm text vector];
         license = stdenv.lib.licenses.gpl3;
       };
 

src/Classes.hs

@@ -0,0 +1,5 @@
+module Classes
+  ( module C
+  ) where
+
+import Classes.Bindable as C

src/Classes/Bindable.hs

@@ -0,0 +1,10 @@
+module Classes.Bindable where
+
+-- | typeclass for bindable objects like buffers, vertex arrays or shaders
+class Bindable a where
+
+  -- bind the object in context
+  bind :: a -> IO ()
+  
+  -- release object from context
+  unbind :: a -> IO ()

src/Map.hs

@@ -10,6 +10,7 @@ import qualified Data.Vector as V
 -- internal imports
 
 import Types
+import Texture
 
 testLevelDesc :: LevelDescriptor
 testLevelDesc = LevelDescriptor

src/Texture.hs

@@ -0,0 +1,71 @@
+module Texture where
+
+import Data.Vector.Storable as VS
+
+import qualified Graphics.Rendering.OpenGL as GL
+
+import SDL (($=), get)
+
+import Codec.Picture
+import Codec.Picture.Extra
+
+import Linear
+
+import Foreign
+import Foreign.Ptr
+
+-- internal imports
+
+import Classes.Bindable
+import Types.Texture
+
+newTexture :: FilePath -> GL.GLuint -> IO Texture
+newTexture fp slot = do
+
+  -- read in image from filesystem
+  img <- flipVertically <$> convertRGBA8 <$>
+    either (error $ "reading image file " <> fp <> " failed!") id <$>
+    readImage fp
+
+  -- extract the raw pointer from vector
+  unsafeWith (imageData img) $ \ptr -> do
+    -- create texture object
+    tex <- Texture
+      <$> GL.genObjectName
+      <*> (pure $ GL.TextureUnit slot)
+      -- <*> (pure fp)
+    let dimensions = fromIntegral <$> V2 (imageWidth img) (imageHeight img)
+      -- <*> (pure $ componentCount (VS.head $ imageData img))
+        data_ = castPtr ptr
+
+    -- bind texture
+    bind tex
+
+    -- set texture parameters
+    GL.textureFilter GL.Texture2D $= ((GL.Linear', Nothing), GL.Linear')
+    GL.textureWrapMode GL.Texture2D GL.S $= (GL.Repeated, GL.Clamp)
+    GL.textureWrapMode GL.Texture2D GL.T $= (GL.Repeated, GL.Clamp)
+
+    -- put data into GPU memory
+    loadTexture tex dimensions data_
+
+    -- unbind texture
+    unbind tex
+
+    -- -- throw away the data on the CPU side
+    -- free (texData tex)
+
+    -- pass texture object out
+    return tex
+
+loadTexture :: Texture -> V2 GL.GLsizei -> Ptr () -> IO ()
+loadTexture tex dimensions data_ =
+  let (V2 w h) = dimensions
+  in  GL.texImage2D
+    GL.Texture2D
+    GL.NoProxy
+    0
+    GL.RGBA'
+    (GL.TextureSize2D w h)
+    0
+    (GL.PixelData GL.RGBA GL.UnsignedByte data_)

src/Types.hs

@@ -5,3 +5,4 @@ module Types
 import Types.Application as T
 import Types.Subsystems as T
 import Types.GameMap as T
+import Types.Texture as T

src/Types/GameMap.hs

@@ -4,6 +4,10 @@ import Data.Vector
 
 import Linear
 
+-- internal imports
+
+import Types.Texture
+
 data LevelMap = LevelMap
   { mapLayers     :: Vector MapLayer -- | Layer stack
   , mapWalkLayer  :: Word            -- | Collision layer index in stack
@@ -32,8 +36,7 @@ data TileType
 
 data TileMap = TileMap
   { tileMapDimensions :: V2 Word  -- | Dimensions of tile map image in pixels
-  , tileMapPath       :: FilePath -- | Filepath to image
-  , tileMapIndex      :: Word     -- | Index on GPU
+  , tileMapTecture    :: Texture  -- | Texture object on GPU
   }
   deriving (Eq, Show)
 

src/Types/Texture.hs

@@ -0,0 +1,23 @@
+module Types.Texture where
+
+import SDL (($=), get)
+
+import qualified Graphics.Rendering.OpenGL as GL
+
+-- internal imports
+
+import Classes.Bindable
+
+data Texture = Texture
+  { textureId   :: GL.TextureObject
+  , textureSlot :: GL.TextureUnit
+  }
+  deriving (Eq, Show)
+
+instance Bindable Texture where
+
+  bind t = do
+    GL.activeTexture $= textureSlot t
+    GL.textureBinding GL.Texture2D $= Just (textureId t)
+
+  unbind t = GL.textureBinding GL.Texture2D $= Nothing