working on textures

This commit is contained in:
nek0 2020-10-12 06:08:33 +02:00
parent 31a58280ae
commit ff77587042
9 changed files with 125 additions and 5 deletions

View File

@ -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

View File

@ -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;
};

5
src/Classes.hs Normal file
View File

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

10
src/Classes/Bindable.hs Normal file
View File

@ -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 ()

View File

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

71
src/Texture.hs Normal file
View File

@ -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_)

View File

@ -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

View File

@ -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)

23
src/Types/Texture.hs Normal file
View File

@ -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