From ff77587042a27bc75b51fd811d5aedd6842d4863 Mon Sep 17 00:00:00 2001 From: nek0 Date: Mon, 12 Oct 2020 06:08:33 +0200 Subject: [PATCH] working on textures --- pituicat.cabal | 6 ++++ shell.nix | 6 ++-- src/Classes.hs | 5 +++ src/Classes/Bindable.hs | 10 ++++++ src/Map.hs | 1 + src/Texture.hs | 71 +++++++++++++++++++++++++++++++++++++++++ src/Types.hs | 1 + src/Types/GameMap.hs | 7 ++-- src/Types/Texture.hs | 23 +++++++++++++ 9 files changed, 125 insertions(+), 5 deletions(-) create mode 100644 src/Classes.hs create mode 100644 src/Classes/Bindable.hs create mode 100644 src/Texture.hs create mode 100644 src/Types/Texture.hs diff --git a/pituicat.cabal b/pituicat.cabal index 0dfef9a..d6acc4b 100644 --- a/pituicat.cabal +++ b/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 diff --git a/shell.nix b/shell.nix index 1234c68..37af4e7 100644 --- a/shell.nix +++ b/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; }; diff --git a/src/Classes.hs b/src/Classes.hs new file mode 100644 index 0000000..ec1d9be --- /dev/null +++ b/src/Classes.hs @@ -0,0 +1,5 @@ +module Classes + ( module C + ) where + +import Classes.Bindable as C diff --git a/src/Classes/Bindable.hs b/src/Classes/Bindable.hs new file mode 100644 index 0000000..a6c9b1c --- /dev/null +++ b/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 () diff --git a/src/Map.hs b/src/Map.hs index 21fcd60..4367b7a 100644 --- a/src/Map.hs +++ b/src/Map.hs @@ -10,6 +10,7 @@ import qualified Data.Vector as V -- internal imports import Types +import Texture testLevelDesc :: LevelDescriptor testLevelDesc = LevelDescriptor diff --git a/src/Texture.hs b/src/Texture.hs new file mode 100644 index 0000000..de8dd60 --- /dev/null +++ b/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_) diff --git a/src/Types.hs b/src/Types.hs index 4f79af7..b42bb70 100644 --- a/src/Types.hs +++ b/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 diff --git a/src/Types/GameMap.hs b/src/Types/GameMap.hs index 47a6699..13b96ab 100644 --- a/src/Types/GameMap.hs +++ b/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) diff --git a/src/Types/Texture.hs b/src/Types/Texture.hs new file mode 100644 index 0000000..486fdb0 --- /dev/null +++ b/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