module Graphics.GPipe.Texture.Load (
LoadableTexture(..),
LoadableTexture3D(..),
) where
import Graphics.GPipe
import Codec.Image.STB
import Data.Either
import Foreign.Ptr (plusPtr)
class Texture t => LoadableTexture t where
loadTexture :: TextureFormat t
-> FilePath
-> IO t
class LoadableTexture3D f where
loadTexture3D :: Int
-> f
-> FilePath
-> IO (Texture3D f)
loadTexture' comp io path = do image <- loadImage' path comp
either
(ioError . userError)
(flip withImage io)
image
texture3DFromImage cpufmt fmt path ptr s@(w,h) comp =
case quotRem h w of
(q, 0) -> newTexture cpufmt fmt (w:.w:.q:.()) [ptr]
_ -> ioError $ userError ("loadTexture: Bad 3D image size " ++ show s ++ " in " ++ show path)
texture2DFromImage cpufmt fmt ptr (w,h) comp = newTexture cpufmt fmt (w:.h:.()) [ptr]
texture1DFromImage cpufmt fmt ptr (w,h) comp = newTexture cpufmt fmt (w*h) [ptr]
textureCubeFromImage cpufmt fmt path ptr s@(w,h) comp =
case quotRem h 6 of
(q, 0) -> newTexture cpufmt fmt (w:.q:.()) [ptr `plusPtr` (off*w*q) | off <- [0..5]]
_ -> ioError $ userError ("loadTexture: Bad cube image size " ++ show s ++ " in " ++ show path)
texture3DFromImage' d cpufmt fmt path ptr s@(w,h) comp =
case quotRem h d of
(q, 0) -> newTexture cpufmt fmt (w:.q:.d:.()) [ptr]
_ -> ioError $ userError ("loadTexture: Bad 3D image size " ++ show s ++ " in " ++ show path)
instance LoadableTexture (Texture3D AlphaFormat) where
loadTexture fmt path = loadTexture' 1 (texture3DFromImage UnsignedByteFormat fmt path) path
instance LoadableTexture (Texture3D LuminanceFormat) where
loadTexture fmt path = loadTexture' 1 (texture3DFromImage UnsignedByteFormat fmt path) path
instance LoadableTexture (Texture3D LuminanceAlphaFormat) where
loadTexture fmt path = loadTexture' 2 (texture3DFromImage (PerComp2 UnsignedByteFormat) fmt path) path
instance LoadableTexture (Texture3D RGBFormat) where
loadTexture fmt path = loadTexture' 3 (texture3DFromImage (PerComp3 UnsignedByteFormat) fmt path) path
instance LoadableTexture (Texture3D RGBAFormat) where
loadTexture fmt path = loadTexture' 4 (texture3DFromImage (PerComp4 UnsignedByteFormat) fmt path) path
instance LoadableTexture (Texture2D AlphaFormat) where
loadTexture fmt = loadTexture' 1 $ texture2DFromImage UnsignedByteFormat fmt
instance LoadableTexture (Texture2D LuminanceFormat) where
loadTexture fmt = loadTexture' 1 $ texture2DFromImage UnsignedByteFormat fmt
instance LoadableTexture (Texture2D LuminanceAlphaFormat) where
loadTexture fmt = loadTexture' 2 $ texture2DFromImage (PerComp2 UnsignedByteFormat) fmt
instance LoadableTexture (Texture2D RGBFormat) where
loadTexture fmt = loadTexture' 3 $ texture2DFromImage (PerComp3 UnsignedByteFormat) fmt
instance LoadableTexture (Texture2D RGBAFormat) where
loadTexture fmt = loadTexture' 4 $ texture2DFromImage (PerComp4 UnsignedByteFormat) fmt
instance LoadableTexture (Texture1D AlphaFormat) where
loadTexture fmt = loadTexture' 1 $ texture1DFromImage UnsignedByteFormat fmt
instance LoadableTexture (Texture1D LuminanceFormat) where
loadTexture fmt = loadTexture' 1 $ texture1DFromImage UnsignedByteFormat fmt
instance LoadableTexture (Texture1D LuminanceAlphaFormat) where
loadTexture fmt = loadTexture' 2 $ texture1DFromImage (PerComp2 UnsignedByteFormat) fmt
instance LoadableTexture (Texture1D RGBFormat) where
loadTexture fmt = loadTexture' 3 $ texture1DFromImage (PerComp3 UnsignedByteFormat) fmt
instance LoadableTexture (Texture1D RGBAFormat) where
loadTexture fmt = loadTexture' 4 $ texture1DFromImage (PerComp4 UnsignedByteFormat) fmt
instance LoadableTexture (TextureCube AlphaFormat) where
loadTexture fmt path = loadTexture' 1 (textureCubeFromImage UnsignedByteFormat fmt path) path
instance LoadableTexture (TextureCube LuminanceFormat) where
loadTexture fmt path = loadTexture' 1 (textureCubeFromImage UnsignedByteFormat fmt path) path
instance LoadableTexture (TextureCube LuminanceAlphaFormat) where
loadTexture fmt path = loadTexture' 2 (textureCubeFromImage (PerComp2 UnsignedByteFormat) fmt path) path
instance LoadableTexture (TextureCube RGBFormat) where
loadTexture fmt path = loadTexture' 3 (textureCubeFromImage (PerComp3 UnsignedByteFormat) fmt path) path
instance LoadableTexture (TextureCube RGBAFormat) where
loadTexture fmt path = loadTexture' 4 (textureCubeFromImage (PerComp4 UnsignedByteFormat) fmt path) path
instance LoadableTexture3D AlphaFormat where
loadTexture3D d fmt path = loadTexture' 1 (texture3DFromImage' d UnsignedByteFormat fmt path) path
instance LoadableTexture3D LuminanceFormat where
loadTexture3D d fmt path = loadTexture' 1 (texture3DFromImage' d UnsignedByteFormat fmt path) path
instance LoadableTexture3D LuminanceAlphaFormat where
loadTexture3D d fmt path = loadTexture' 2 (texture3DFromImage' d (PerComp2 UnsignedByteFormat) fmt path) path
instance LoadableTexture3D RGBFormat where
loadTexture3D d fmt path = loadTexture' 3 (texture3DFromImage' d (PerComp3 UnsignedByteFormat) fmt path) path
instance LoadableTexture3D RGBAFormat where
loadTexture3D d fmt path = loadTexture' 4 (texture3DFromImage' d (PerComp4 UnsignedByteFormat) fmt path) path