{-# LANGUAGE OverloadedStrings #-}
module Graphics.Rendering.Rect.Image(
    Atlas, buildAtlas, Texture(..), atlasLookup, textureSetRepeat) where

import qualified Data.HashMap.Lazy as HM
import Data.Text (Text)
import Codec.Picture (DynamicImage(..), Image(..), PixelF, pixelMap)
import Codec.Picture.Types (promoteImage, dynamicMap, convertImage)

import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad (forM)
import Data.Maybe (fromMaybe)

import Graphics.GL.Core32
import Graphics.GL.Types
import Graphics.GL.Ext.EXT.Cmyka
import Graphics.GL.Ext.SGIX.Ycrcb
import Graphics.GL.Compatibility32

import Data.Vector.Storable (unsafeWith, unsafeCast, Vector)
import Foreign.Ptr (castPtr)
import Foreign.Marshal.Array (allocaArray, peekArray)

data Atlas = Atlas { Atlas -> HashMap Text Texture
unAtlas :: HM.HashMap Text Texture }

buildAtlas :: MonadIO m => (Text -> IO DynamicImage) -> [Text] -> m Atlas
buildAtlas :: (Text -> IO DynamicImage) -> [Text] -> m Atlas
buildAtlas _ [] = Atlas -> m Atlas
forall (m :: * -> *) a. Monad m => a -> m a
return (Atlas -> m Atlas) -> Atlas -> m Atlas
forall a b. (a -> b) -> a -> b
$ HashMap Text Texture -> Atlas
Atlas HashMap Text Texture
forall k v. HashMap k v
HM.empty
buildAtlas cb :: Text -> IO DynamicImage
cb srcs :: [Text]
srcs = do
    -- TODO Merge textures into an actual atlas.
    let len :: Int
len = [Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
srcs
    [GLuint]
textures <- IO [GLuint] -> m [GLuint]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [GLuint] -> m [GLuint]) -> IO [GLuint] -> m [GLuint]
forall a b. (a -> b) -> a -> b
$ Int -> (Ptr GLuint -> IO [GLuint]) -> IO [GLuint]
forall a b. Storable a => Int -> (Ptr a -> IO b) -> IO b
allocaArray (Int -> Int
forall a. Enum a => Int -> a
toEnum Int
len) ((Ptr GLuint -> IO [GLuint]) -> IO [GLuint])
-> (Ptr GLuint -> IO [GLuint]) -> IO [GLuint]
forall a b. (a -> b) -> a -> b
$ \ptr :: Ptr GLuint
ptr -> do
        GLsizei -> Ptr GLuint -> IO ()
forall (m :: * -> *). MonadIO m => GLsizei -> Ptr GLuint -> m ()
glGenTextures (Int -> GLsizei
forall a. Enum a => Int -> a
toEnum Int
len) Ptr GLuint
ptr
        Int -> Ptr GLuint -> IO [GLuint]
forall a. Storable a => Int -> Ptr a -> IO [a]
peekArray Int
len Ptr GLuint
ptr
    [DynamicImage]
imgs <- IO [DynamicImage] -> m [DynamicImage]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [DynamicImage] -> m [DynamicImage])
-> IO [DynamicImage] -> m [DynamicImage]
forall a b. (a -> b) -> a -> b
$ [Text] -> (Text -> IO DynamicImage) -> IO [DynamicImage]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Text]
srcs Text -> IO DynamicImage
cb

    [(Float, Float)]
sizes <- [(GLuint, DynamicImage)]
-> ((GLuint, DynamicImage) -> m (Float, Float))
-> m [(Float, Float)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ([GLuint] -> [DynamicImage] -> [(GLuint, DynamicImage)]
forall a b. [a] -> [b] -> [(a, b)]
zip [GLuint]
textures [DynamicImage]
imgs) (((GLuint, DynamicImage) -> m (Float, Float))
 -> m [(Float, Float)])
-> ((GLuint, DynamicImage) -> m (Float, Float))
-> m [(Float, Float)]
forall a b. (a -> b) -> a -> b
$ \(texture :: GLuint
texture, dyn :: DynamicImage
dyn) -> do
        -- NOTE: `unsafe` crashes with a divide-by-zero given a `Vector ()`
        let dyn' :: DynamicImage
dyn' = DynamicImage -> DynamicImage
convertDyn DynamicImage
dyn
        let img :: Vector Word
img = (forall pixel. Pixel pixel => Image pixel -> Vector Word)
-> DynamicImage -> Vector Word
forall a.
(forall pixel. Pixel pixel => Image pixel -> a)
-> DynamicImage -> a
dynamicMap (Vector (PixelBaseComponent pixel) -> Vector Word
forall a b. (Storable a, Storable b) => Vector a -> Vector b
unsafeCast (Vector (PixelBaseComponent pixel) -> Vector Word)
-> (Image pixel -> Vector (PixelBaseComponent pixel))
-> Image pixel
-> Vector Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image pixel -> Vector (PixelBaseComponent pixel)
forall a. Image a -> Vector (PixelBaseComponent a)
imageData) DynamicImage
dyn' :: Vector Word
        let (format :: GLuint
format, word :: GLuint
word) = DynamicImage -> (GLuint, GLuint)
glFormat DynamicImage
dyn'
        IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ GLuint -> GLuint -> IO ()
forall (m :: * -> *). MonadIO m => GLuint -> GLuint -> m ()
glBindTexture GLuint
forall a. (Eq a, Num a) => a
GL_TEXTURE_2D GLuint
texture
        IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Vector Word -> (Ptr Word -> IO ()) -> IO ()
forall a b. Storable a => Vector a -> (Ptr a -> IO b) -> IO b
unsafeWith Vector Word
img ((Ptr Word -> IO ()) -> IO ()) -> (Ptr Word -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ GLuint
-> GLsizei
-> GLsizei
-> GLsizei
-> GLsizei
-> GLsizei
-> GLuint
-> GLuint
-> Ptr ()
-> IO ()
forall (m :: * -> *).
MonadIO m =>
GLuint
-> GLsizei
-> GLsizei
-> GLsizei
-> GLsizei
-> GLsizei
-> GLuint
-> GLuint
-> Ptr ()
-> m ()
glTexImage2D GLuint
forall a. (Eq a, Num a) => a
GL_TEXTURE_2D 0 GLsizei
forall a. (Eq a, Num a) => a
GL_RGBA
                    (Int -> GLsizei
forall a. Enum a => Int -> a
toEnum (Int -> GLsizei) -> Int -> GLsizei
forall a b. (a -> b) -> a -> b
$ (forall pixel. Pixel pixel => Image pixel -> Int)
-> DynamicImage -> Int
forall a.
(forall pixel. Pixel pixel => Image pixel -> a)
-> DynamicImage -> a
dynamicMap forall a. Image a -> Int
forall pixel. Pixel pixel => Image pixel -> Int
imageWidth DynamicImage
dyn')
                    (Int -> GLsizei
forall a. Enum a => Int -> a
toEnum (Int -> GLsizei) -> Int -> GLsizei
forall a b. (a -> b) -> a -> b
$ (forall pixel. Pixel pixel => Image pixel -> Int)
-> DynamicImage -> Int
forall a.
(forall pixel. Pixel pixel => Image pixel -> a)
-> DynamicImage -> a
dynamicMap forall a. Image a -> Int
forall pixel. Pixel pixel => Image pixel -> Int
imageHeight DynamicImage
dyn')
                    0 GLuint
format GLuint
word (Ptr () -> IO ()) -> (Ptr Word -> Ptr ()) -> Ptr Word -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr Word -> Ptr ()
forall a b. Ptr a -> Ptr b
castPtr
        IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ GLuint -> GLuint -> GLsizei -> IO ()
forall (m :: * -> *).
MonadIO m =>
GLuint -> GLuint -> GLsizei -> m ()
glTexParameteri GLuint
forall a. (Eq a, Num a) => a
GL_TEXTURE_2D GLuint
forall a. (Eq a, Num a) => a
GL_TEXTURE_MIN_FILTER GLsizei
forall a. (Eq a, Num a) => a
GL_LINEAR
        IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ GLuint -> GLuint -> GLsizei -> IO ()
forall (m :: * -> *).
MonadIO m =>
GLuint -> GLuint -> GLsizei -> m ()
glTexParameteri GLuint
forall a. (Eq a, Num a) => a
GL_TEXTURE_2D GLuint
forall a. (Eq a, Num a) => a
GL_TEXTURE_MAG_FILTER GLsizei
forall a. (Eq a, Num a) => a
GL_LINEAR

        (Float, Float) -> m (Float, Float)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Float
forall a. Enum a => Int -> a
toEnum (Int -> Float) -> Int -> Float
forall a b. (a -> b) -> a -> b
$ (forall pixel. Pixel pixel => Image pixel -> Int)
-> DynamicImage -> Int
forall a.
(forall pixel. Pixel pixel => Image pixel -> a)
-> DynamicImage -> a
dynamicMap forall a. Image a -> Int
forall pixel. Pixel pixel => Image pixel -> Int
imageWidth DynamicImage
dyn',
                Int -> Float
forall a. Enum a => Int -> a
toEnum (Int -> Float) -> Int -> Float
forall a b. (a -> b) -> a -> b
$ (forall pixel. Pixel pixel => Image pixel -> Int)
-> DynamicImage -> Int
forall a.
(forall pixel. Pixel pixel => Image pixel -> a)
-> DynamicImage -> a
dynamicMap forall a. Image a -> Int
forall pixel. Pixel pixel => Image pixel -> Int
imageHeight DynamicImage
dyn')

    let textures' :: [Texture]
textures' = ((GLuint, (Float, Float)) -> Texture)
-> [(GLuint, (Float, Float))] -> [Texture]
forall a b. (a -> b) -> [a] -> [b]
map ((GLuint -> (Float, Float) -> Texture)
-> (GLuint, (Float, Float)) -> Texture
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry GLuint -> (Float, Float) -> Texture
Texture) ([(GLuint, (Float, Float))] -> [Texture])
-> [(GLuint, (Float, Float))] -> [Texture]
forall a b. (a -> b) -> a -> b
$ [GLuint] -> [(Float, Float)] -> [(GLuint, (Float, Float))]
forall a b. [a] -> [b] -> [(a, b)]
zip [GLuint]
textures [(Float, Float)]
sizes
    Atlas -> m Atlas
forall (m :: * -> *) a. Monad m => a -> m a
return (Atlas -> m Atlas) -> Atlas -> m Atlas
forall a b. (a -> b) -> a -> b
$ HashMap Text Texture -> Atlas
Atlas (HashMap Text Texture -> Atlas) -> HashMap Text Texture -> Atlas
forall a b. (a -> b) -> a -> b
$ [(Text, Texture)] -> HashMap Text Texture
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList ([(Text, Texture)] -> HashMap Text Texture)
-> [(Text, Texture)] -> HashMap Text Texture
forall a b. (a -> b) -> a -> b
$ [Text] -> [Texture] -> [(Text, Texture)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
srcs [Texture]
textures'

data Texture = Texture { Texture -> GLuint
unTexture :: GLuint, Texture -> (Float, Float)
texSize :: (Float, Float) }
nilTexture :: Texture
nilTexture :: Texture
nilTexture = GLuint -> (Float, Float) -> Texture
Texture 0 (0, 0)
atlasLookup :: Text -> Atlas -> Texture
atlasLookup :: Text -> Atlas -> Texture
atlasLookup key :: Text
key = Texture -> Maybe Texture -> Texture
forall a. a -> Maybe a -> a
fromMaybe Texture
nilTexture (Maybe Texture -> Texture)
-> (Atlas -> Maybe Texture) -> Atlas -> Texture
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> HashMap Text Texture -> Maybe Texture
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Text
key (HashMap Text Texture -> Maybe Texture)
-> (Atlas -> HashMap Text Texture) -> Atlas -> Maybe Texture
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Atlas -> HashMap Text Texture
unAtlas
textureSetRepeat :: MonadIO m => Texture -> (Bool, Bool) -> m ()
textureSetRepeat :: Texture -> (Bool, Bool) -> m ()
textureSetRepeat tex :: Texture
tex (repeatX :: Bool
repeatX, repeatY :: Bool
repeatY) = do
    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ GLuint -> GLuint -> IO ()
forall (m :: * -> *). MonadIO m => GLuint -> GLuint -> m ()
glBindTexture GLuint
forall a. (Eq a, Num a) => a
GL_TEXTURE_2D (GLuint -> IO ()) -> GLuint -> IO ()
forall a b. (a -> b) -> a -> b
$ Texture -> GLuint
unTexture Texture
tex
    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ GLuint -> GLuint -> GLsizei -> IO ()
forall (m :: * -> *).
MonadIO m =>
GLuint -> GLuint -> GLsizei -> m ()
glTexParameteri GLuint
forall a. (Eq a, Num a) => a
GL_TEXTURE_2D GLuint
forall a. (Eq a, Num a) => a
GL_TEXTURE_WRAP_S (GLsizei -> IO ()) -> GLsizei -> IO ()
forall a b. (a -> b) -> a -> b
$
        if Bool
repeatX then GLsizei
forall a. (Eq a, Num a) => a
GL_REPEAT else GLsizei
forall a. (Eq a, Num a) => a
GL_CLAMP_TO_BORDER
    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ GLuint -> GLuint -> GLsizei -> IO ()
forall (m :: * -> *).
MonadIO m =>
GLuint -> GLuint -> GLsizei -> m ()
glTexParameteri GLuint
forall a. (Eq a, Num a) => a
GL_TEXTURE_2D GLuint
forall a. (Eq a, Num a) => a
GL_TEXTURE_WRAP_T (GLsizei -> IO ()) -> GLsizei -> IO ()
forall a b. (a -> b) -> a -> b
$
        if Bool
repeatY then GLsizei
forall a. (Eq a, Num a) => a
GL_REPEAT else GLsizei
forall a. (Eq a, Num a) => a
GL_CLAMP_TO_BORDER

-- Convert pixels to some flavour of RGBA
convertDyn :: DynamicImage -> DynamicImage
convertDyn :: DynamicImage -> DynamicImage
convertDyn (ImageY8 img :: Image Pixel8
img) = Image PixelRGBA8 -> DynamicImage
ImageRGBA8 (Image PixelRGBA8 -> DynamicImage)
-> Image PixelRGBA8 -> DynamicImage
forall a b. (a -> b) -> a -> b
$ Image Pixel8 -> Image PixelRGBA8
forall a b. ColorConvertible a b => Image a -> Image b
promoteImage Image Pixel8
img
convertDyn (ImageY16 img :: Image Pixel16
img) = Image PixelRGBA16 -> DynamicImage
ImageRGBA16 (Image PixelRGBA16 -> DynamicImage)
-> Image PixelRGBA16 -> DynamicImage
forall a b. (a -> b) -> a -> b
$ Image Pixel16 -> Image PixelRGBA16
forall a b. ColorConvertible a b => Image a -> Image b
promoteImage Image Pixel16
img
convertDyn (ImageY32 img :: Image GLuint
img) =
    Image PixelRGBF -> DynamicImage
ImageRGBF (Image PixelRGBF -> DynamicImage)
-> Image PixelRGBF -> DynamicImage
forall a b. (a -> b) -> a -> b
$ Image Float -> Image PixelRGBF
forall a b. ColorConvertible a b => Image a -> Image b
promoteImage ((GLuint -> Float) -> Image GLuint -> Image Float
forall a b. (Pixel a, Pixel b) => (a -> b) -> Image a -> Image b
pixelMap GLuint -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Image GLuint
img :: Image PixelF)
convertDyn (ImageYF img :: Image Float
img) = Image PixelRGBF -> DynamicImage
ImageRGBF (Image PixelRGBF -> DynamicImage)
-> Image PixelRGBF -> DynamicImage
forall a b. (a -> b) -> a -> b
$ Image Float -> Image PixelRGBF
forall a b. ColorConvertible a b => Image a -> Image b
promoteImage Image Float
img
convertDyn (ImageYA8 img :: Image PixelYA8
img) = Image PixelRGBA8 -> DynamicImage
ImageRGBA8 (Image PixelRGBA8 -> DynamicImage)
-> Image PixelRGBA8 -> DynamicImage
forall a b. (a -> b) -> a -> b
$ Image PixelYA8 -> Image PixelRGBA8
forall a b. ColorConvertible a b => Image a -> Image b
promoteImage Image PixelYA8
img
convertDyn (ImageYA16 img :: Image PixelYA16
img) = Image PixelRGBA16 -> DynamicImage
ImageRGBA16 (Image PixelRGBA16 -> DynamicImage)
-> Image PixelRGBA16 -> DynamicImage
forall a b. (a -> b) -> a -> b
$ Image PixelYA16 -> Image PixelRGBA16
forall a b. ColorConvertible a b => Image a -> Image b
promoteImage Image PixelYA16
img
convertDyn (ImageRGB8 img :: Image PixelRGB8
img) = Image PixelRGB8 -> DynamicImage
ImageRGB8 Image PixelRGB8
img
convertDyn (ImageRGB16 img :: Image PixelRGB16
img) = Image PixelRGB16 -> DynamicImage
ImageRGB16 Image PixelRGB16
img
convertDyn (ImageRGBF img :: Image PixelRGBF
img) = Image PixelRGBF -> DynamicImage
ImageRGBF Image PixelRGBF
img
convertDyn (ImageRGBA8 img :: Image PixelRGBA8
img) = Image PixelRGBA8 -> DynamicImage
ImageRGBA8 Image PixelRGBA8
img
convertDyn (ImageRGBA16 img :: Image PixelRGBA16
img) = Image PixelRGBA16 -> DynamicImage
ImageRGBA16 Image PixelRGBA16
img
convertDyn (ImageYCbCr8 img :: Image PixelYCbCr8
img) = Image PixelRGB8 -> DynamicImage
ImageRGB8 (Image PixelRGB8 -> DynamicImage)
-> Image PixelRGB8 -> DynamicImage
forall a b. (a -> b) -> a -> b
$ Image PixelYCbCr8 -> Image PixelRGB8
forall a b. ColorSpaceConvertible a b => Image a -> Image b
convertImage Image PixelYCbCr8
img
convertDyn (ImageCMYK8 img :: Image PixelCMYK8
img) = Image PixelRGB8 -> DynamicImage
ImageRGB8 (Image PixelRGB8 -> DynamicImage)
-> Image PixelRGB8 -> DynamicImage
forall a b. (a -> b) -> a -> b
$ Image PixelCMYK8 -> Image PixelRGB8
forall a b. ColorSpaceConvertible a b => Image a -> Image b
convertImage Image PixelCMYK8
img
convertDyn (ImageCMYK16 img :: Image PixelCMYK16
img) = Image PixelRGB16 -> DynamicImage
ImageRGB16 (Image PixelRGB16 -> DynamicImage)
-> Image PixelRGB16 -> DynamicImage
forall a b. (a -> b) -> a -> b
$ Image PixelCMYK16 -> Image PixelRGB16
forall a b. ColorSpaceConvertible a b => Image a -> Image b
convertImage Image PixelCMYK16
img

glFormat :: DynamicImage -> (GLenum, GLenum)
glFormat :: DynamicImage -> (GLuint, GLuint)
glFormat (ImageY8 _) = (GLuint
forall a. (Eq a, Num a) => a
GL_LUMINANCE, GLuint
forall a. (Eq a, Num a) => a
GL_UNSIGNED_BYTE)
glFormat (ImageY16 _) = (GLuint
forall a. (Eq a, Num a) => a
GL_LUMINANCE, GLuint
forall a. (Eq a, Num a) => a
GL_UNSIGNED_SHORT)
glFormat (ImageY32 _) = (GLuint
forall a. (Eq a, Num a) => a
GL_LUMINANCE, GLuint
forall a. (Eq a, Num a) => a
GL_UNSIGNED_INT)
glFormat (ImageYF _) = (GLuint
forall a. (Eq a, Num a) => a
GL_LUMINANCE, GLuint
forall a. (Eq a, Num a) => a
GL_FLOAT)
glFormat (ImageYA8 _) = (GLuint
forall a. (Eq a, Num a) => a
GL_LUMINANCE_ALPHA, GLuint
forall a. (Eq a, Num a) => a
GL_BYTE)
glFormat (ImageYA16 _) = (GLuint
forall a. (Eq a, Num a) => a
GL_LUMINANCE_ALPHA, GLuint
forall a. (Eq a, Num a) => a
GL_UNSIGNED_SHORT)
glFormat (ImageRGB8 _) = (GLuint
forall a. (Eq a, Num a) => a
GL_RGB, GLuint
forall a. (Eq a, Num a) => a
GL_UNSIGNED_BYTE)
glFormat (ImageRGB16 _) = (GLuint
forall a. (Eq a, Num a) => a
GL_RGB, GLuint
forall a. (Eq a, Num a) => a
GL_UNSIGNED_SHORT)
glFormat (ImageRGBF _) = (GLuint
forall a. (Eq a, Num a) => a
GL_RGB, GLuint
forall a. (Eq a, Num a) => a
GL_FLOAT)
glFormat (ImageRGBA8 _) = (GLuint
forall a. (Eq a, Num a) => a
GL_RGBA, GLuint
forall a. (Eq a, Num a) => a
GL_UNSIGNED_BYTE)
glFormat (ImageRGBA16 _) = (GLuint
forall a. (Eq a, Num a) => a
GL_RGBA, GLuint
forall a. (Eq a, Num a) => a
GL_UNSIGNED_BYTE)
glFormat (ImageYCbCr8 _) = (GLuint
forall a. (Eq a, Num a) => a
GL_YCRCB_444_SGIX, GLuint
forall a. (Eq a, Num a) => a
GL_UNSIGNED_BYTE)
glFormat (ImageCMYK8 _) = (GLuint
forall a. (Eq a, Num a) => a
GL_CMYK_EXT, GLuint
forall a. (Eq a, Num a) => a
GL_UNSIGNED_BYTE)
glFormat (ImageCMYK16 _) = (GLuint
forall a. (Eq a, Num a) => a
GL_CMYK_EXT, GLuint
forall a. (Eq a, Num a) => a
GL_UNSIGNED_SHORT)