97 lines
4.1 KiB
Haskell
97 lines
4.1 KiB
Haskell
module Shader.AuxAddition
|
|
( addTexture
|
|
, addTextureNoFilter
|
|
, vaddTextureNoFilter
|
|
, addTextureArray
|
|
, addUniforms
|
|
, tilesToLine -- ^ kept in case it is needed in the future
|
|
) where
|
|
import Shader.Data
|
|
|
|
import Data.List.Extra
|
|
import Codec.Picture
|
|
import qualified Data.Vector.Storable as V
|
|
import Control.Lens
|
|
import Graphics.Rendering.OpenGL hiding (Point,translate,scale,imageHeight)
|
|
import Graphics.GL.Core43
|
|
|
|
-- I am not sure if this assumes that the shader is constructed directly before
|
|
-- the texture is added...
|
|
addTexture :: String -> FullShader -> IO FullShader
|
|
addTexture texturePath shad = do
|
|
Right cmap <- readImage texturePath
|
|
let tex = convertRGBA8 cmap
|
|
textureOb <- genObjectName
|
|
textureBinding Texture2D $= Just textureOb
|
|
let wtex = fromIntegral $ imageWidth tex
|
|
htex = fromIntegral $ imageHeight tex
|
|
glTexStorage2D GL_TEXTURE_2D 3 GL_RGBA8 wtex htex
|
|
V.unsafeWith (imageData tex) $ \ptr -> do
|
|
glTexSubImage2D GL_TEXTURE_2D 0 0 0 wtex htex GL_RGBA GL_UNSIGNED_BYTE ptr
|
|
textureFilter Texture2DArray $= ((Linear',Just Linear') , Linear')
|
|
generateMipmap' Texture2D
|
|
return $ shad & shadTex ?~ ShaderTexture {_textureObject = textureOb}
|
|
|
|
vaddTextureNoFilter :: String -> FullShader -> IO FullShader
|
|
vaddTextureNoFilter texturePath shad = do
|
|
Right cmap <- readImage texturePath
|
|
let tex = convertRGBA8 cmap
|
|
textureOb <- genObjectName
|
|
textureBinding Texture2D $= Just textureOb
|
|
textureFilter Texture2D $= ((Nearest,Nothing) , Nearest)
|
|
let wtex = fromIntegral $ imageWidth tex
|
|
htex = fromIntegral $ imageHeight tex
|
|
glTexStorage2D GL_TEXTURE_2D 1 GL_RGBA8 wtex htex
|
|
V.unsafeWith (imageData tex) $ \ptr -> do
|
|
glTexSubImage2D GL_TEXTURE_2D 0 0 0 wtex htex GL_RGBA GL_UNSIGNED_BYTE ptr
|
|
return $ shad & shadTex ?~ ShaderTexture {_textureObject = textureOb}
|
|
|
|
addTextureNoFilter :: String -> FullShader -> IO FullShader
|
|
addTextureNoFilter texturePath shad = do
|
|
Right cmap <- readImage texturePath
|
|
let tex = convertRGBA8 cmap
|
|
textureOb <- genObjectName
|
|
textureBinding Texture2D $= Just textureOb
|
|
textureFilter Texture2D $= ((Nearest,Nothing) , Nearest)
|
|
let wtex = fromIntegral $ imageWidth tex
|
|
htex = fromIntegral $ imageHeight tex
|
|
glTexStorage2D GL_TEXTURE_2D 1 GL_RGBA8 wtex htex
|
|
V.unsafeWith (imageData tex) $ \ptr -> do
|
|
glTexSubImage2D GL_TEXTURE_2D 0 0 0 wtex htex GL_RGBA GL_UNSIGNED_BYTE ptr
|
|
return $ shad & shadTex ?~ ShaderTexture {_textureObject = textureOb}
|
|
|
|
-- | for transforming a 256x256 image containing 64 tiles of 16x16 pixels into
|
|
-- an image that was directly readable by glTexSubImage3D, used the
|
|
-- transformation tilesToLine 8 128 on the underlying pixels.
|
|
addTextureArray :: String -> FullShader -> IO FullShader
|
|
addTextureArray texturePath shad = do
|
|
textureOb <- genObjectName
|
|
textureBinding Texture2DArray $= Just textureOb
|
|
Right cmap <- readImage texturePath
|
|
let tex = convertRGBA8 cmap
|
|
--let texData = tilesToLine 8 128 .
|
|
--let texData = tilesToLine 8 128 .
|
|
-- V.toList $ imageData tex
|
|
glTexStorage3D GL_TEXTURE_2D_ARRAY 3 GL_RGBA8 32 32 64
|
|
--writePng "atest.png" ((Image 256 256 (V.fromList texData)) :: Image PixelRGBA8)
|
|
--withArray texData $ \ptr -> do
|
|
V.unsafeWith (imageData tex) $ \ptr -> do
|
|
--glTexSubImage3D GL_TEXTURE_2D_ARRAY 0 0 0 0 32 32 64 GL_RGBA GL_UNSIGNED_BYTE ptr
|
|
glTexSubImage3D GL_TEXTURE_2D_ARRAY 0 0 0 0 32 32 64 GL_RGBA GL_UNSIGNED_BYTE ptr
|
|
textureFilter Texture2DArray $= ((Linear',Just Linear') , Linear')
|
|
generateMipmap' Texture2DArray
|
|
return $ shad & shadTex ?~ ShaderTexture {_textureObject = textureOb}
|
|
|
|
-- I am completely unclear on why this works with its current parameters
|
|
tilesToLine
|
|
:: Int -- ^ Parameter a
|
|
-> Int -- ^ Parameter b
|
|
-> [a]
|
|
-> [a]
|
|
tilesToLine n w = concat . concat . transpose . chunksOf n . chunksOf w
|
|
|
|
addUniforms :: [String] -> FullShader -> IO FullShader
|
|
addUniforms uniStrings shad = do
|
|
uniLocs <- mapM (uniformLocation $ _shadProg shad) uniStrings
|
|
return $ shad & shadUnis %~ (++ uniLocs)
|