diff --git a/GPipe-TextureLoad.cabal b/GPipe-TextureLoad.cabal new file mode 100644 --- /dev/null +++ b/GPipe-TextureLoad.cabal @@ -0,0 +1,46 @@ +name: GPipe-TextureLoad +version: 1.0.0 +cabal-version: >=1.2.3 +build-type: Simple +license: BSD3 +license-file: "" +copyright: Tobias Bexelius +maintainer: Tobias Bexelius +build-depends: GPipe -any, base ==4.1.0.0, stb-image -any +stability: Experimental +homepage: http://www.haskell.org/haskellwiki/GPipe +package-url: +bug-reports: mailto:tobias_bexelius@hotmail.com +synopsis: Load GPipe textures from filesystem +description: The functions of this package helps loading GPipe textures from file. It is based on the stb-image package, and supports subsets of the JPG, PNG, TGA, BMP and PSD formats. +category: Graphics +author: Tobias Bexelius +tested-with: +data-files: +data-dir: "" +extra-source-files: +extra-tmp-files: +exposed-modules: Graphics.GPipe.Texture.Load +exposed: True +buildable: True +build-tools: +cpp-options: +cc-options: +ld-options: +pkgconfig-depends: +frameworks: +c-sources: +extensions: FlexibleContexts FlexibleInstances +extra-libraries: +extra-lib-dirs: +includes: +install-includes: +include-dirs: +hs-source-dirs: src +other-modules: +ghc-prof-options: +ghc-shared-options: +ghc-options: +hugs-options: +nhc98-options: +jhc-options: diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,6 @@ +#!/usr/bin/runhaskell +> module Main where +> import Distribution.Simple +> main :: IO () +> main = defaultMain + diff --git a/src/Graphics/GPipe/Texture/Load.hs b/src/Graphics/GPipe/Texture/Load.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/GPipe/Texture/Load.hs @@ -0,0 +1,124 @@ +----------------------------------------------------------------------------- +-- +-- Module : Graphics.GPipe.Texture.Load +-- Copyright : Tobias Bexelius +-- License : BSD3 +-- +-- Maintainer : Tobias Bexelius +-- Stability : Experimental +-- Portability : +-- +-- | +-- This module provides the means to load all kinds of textures from file. +-- It's based on the stb-image package, and inherits its strengths and limitations. +-- Specifically, it handles a subset of the JPEG, PNG, TGA, BMP and PSD file formats, but is not +-- entirely thread safe. See for more information. +-- +----------------------------------------------------------------------------- + +module Graphics.GPipe.Texture.Load ( + LoadableTexture(..), + LoadableTexture3D(..), +) where + +import Graphics.GPipe +import Codec.Image.STB +import Data.Either +import Foreign.Ptr (plusPtr) + +-- | Provides the general way of loading any kind of textures. A 3D texture is assumed to be an array of square images +-- tiled vertically in the image file. Cube textures are assumed to be composed of 6 equally sized images +-- tiled vertically. No additional mipmaps are loaded. +-- +-- Filesystem errors or bad texture dimensions (e.g. loading a cube texture from a file where the height +-- is not a multiple of 6) are thrown as 'IOError's. +class Texture t => LoadableTexture t where + loadTexture :: TextureFormat t + -> FilePath + -> IO t + +-- | Provides an alternative way of loading 'Texture3D's that are arrays of non-square images tiled vertically. No additional mipmaps are loaded. +-- +-- Filesystem errors or bad texture dimensions (i.e. the height of the image is not a multiple of the supplied depth) +-- are thrown as 'IOError's. +class LoadableTexture3D f where + loadTexture3D :: Int -- ^ The depth of the resulting 'Texture3D' + -> 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