module FRP.Spice.Graphics.Sprite ( Sprite (..)
, renderSprite
, loadSprite
) where
import Graphics.Rendering.OpenGL
import Data.ByteString.Unsafe
import Control.Applicative
import Codec.Picture.Repa
import Codec.Picture
import Control.Monad
import Foreign.Ptr
import FRP.Spice.Graphics.Color
import FRP.Spice.Graphics.Scene
import FRP.Spice.Graphics.Utils
import FRP.Spice.Math
getInfo :: DynamicImage -> (Int, Int, PixelInternalFormat)
getInfo (ImageRGB8 (Image w h _)) = (w, h, RGB8)
getInfo (ImageRGB16 (Image w h _)) = (w, h, RGB16)
getInfo (ImageRGBA8 (Image w h _)) = (w, h, RGBA8)
getInfo (ImageRGBA16 (Image w h _)) = (w, h, RGBA16)
loadTex :: FilePath -> IO (TextureObject, Size)
loadTex path = do
img <- either error id <$> readImageRGBA path
let dynimg = imgToImage img
(w, h, format) = getInfo dynimg
glSize = TextureSize2D (fromIntegral w) (fromIntegral h)
bs = toByteString img
ptr <- unsafeUseAsCString bs $ \cstr ->
return $ castPtr cstr
[t] <- genObjectNames 1
textureBinding Texture2D $= Just t
texImage2D Texture2D NoProxy 0 format glSize 0 (PixelData ABGR UnsignedByte ptr)
return (t, Size (fromIntegral w) (fromIntegral h))
data Sprite = Sprite { spriteTex :: TextureObject
, spriteSize :: Vector Float
}
renderSprite :: Sprite -> Vector Float -> Scene
renderSprite sprite pos = do
textureWrapMode Texture2D S $= (Repeated, ClampToEdge)
textureWrapMode Texture2D T $= (Repeated, ClampToEdge)
textureFilter Texture2D $= ((Linear', Nothing), Linear')
textureFunction $= Replace
texture Texture2D $= Enabled
textureBinding Texture2D $= (Just $ spriteTex sprite)
renderPrimitive Quads $
forM_ (generateCoords pos $ spriteSize sprite) $ \(Vector x y, Vector tx ty) -> do
texCoord $ TexCoord2 (togl tx) (togl ty)
vertex $ Vertex2 (togl x) (togl y)
texture Texture2D $= Disabled
where generateCoords :: Vector Float -> Vector Float -> [(Vector Float, Vector Float)]
generateCoords (Vector x y) (Vector w h) =
[ (Vector (x ) (y ), Vector 0 0)
, (Vector (x + w) (y ), Vector 1 0)
, (Vector (x + w) (y + h), Vector 1 1)
, (Vector (x ) (y + h), Vector 0 1)
]
makeSprite :: (TextureObject, Size) -> Sprite
makeSprite (to, (Size w h)) =
Sprite { spriteTex = to
, spriteSize = size
}
where size = Vector ((fromIntegral w) / 640) ((fromIntegral h) / 480)
loadSprite :: FilePath -> IO Sprite
loadSprite = liftM makeSprite . loadTex