Texture.hs

{-# LANGUAGE RankNTypes #-}
module SimpleH.GL.Texture (
  Texture,
  imageTexture,readTexture,readTextures,readTextures'
  ) where

import SimpleH
import Codec.Picture
import qualified Graphics.Rendering.OpenGL as GL
import Data.Vector.Storable (unsafeWith)
import SimpleH.GL.Base

-- |The abstract Texture type
data Texture = Texture GL.TextureObject
             deriving Show

data TextureFormat = RGB | RGBA | Greyscale | GreyscaleA

pixelFormats RGBA = (GL.RGBA',GL.RGBA)
pixelFormats RGB = (GL.RGB',GL.RGB)
pixelFormats Greyscale = (GL.SLuminance8,GL.Luminance)
pixelFormats GreyscaleA = (GL.SLuminance8Alpha8,GL.LuminanceAlpha)

-- |Read a texture from a file.
readTexture name = at' _eitherT $ (readImage name)^._eitherT
                   >>= at _eitherT<$>imageTexture
-- |Try to convert a JuicyPixels image to a texture.
imageTexture i = at' _eitherT $ do
  ((f,f'),w,h,d) <- at _eitherT $ pure $ case i of
    ImageRGB8 (Image w h d)  -> pure (pixelFormats RGB,w,h,d)
    ImageY8 (Image w h d)    -> pure (pixelFormats Greyscale,w,h,d)
    ImageRGBA8 (Image w h d) -> pure (pixelFormats RGBA,w,h,d)
    ImageYA8 (Image w h d)   -> pure (pixelFormats GreyscaleA,w,h,d)
    _             -> throw "Could not load image format to texture"
  
  lift $ do
    [tex] <- GL.genObjectNames 1
    GL.textureBinding GL.Texture2D GL.$= Just tex
    unsafeWith d $ GL.build2DMipmaps GL.Texture2D f (fromIntegral w) (fromIntegral h)
      . GL.PixelData f' GL.UnsignedByte
    GL.textureFilter  GL.Texture2D GL.$= ((GL.Linear', Just GL.Nearest), GL.Linear')
    GL.textureFunction GL.$= GL.Modulate
    return (Texture tex)

-- |Try to read a structure of files into a structure of textures.
readTextures = map sequence . traverse readTexture
-- |Read a structure of files into a structure of textures, raising an error
-- if it fails.
readTextures' = map2 (error<|>id) readTextures

instance Graphics Texture where
  draw (Texture t) = GL.textureBinding GL.Texture2D GL.$= Just t