~alcinnz/Mondrian

ref: 54ddd7a18fcb0fb3d730c8735d7dbc3cc8cc21bb Mondrian/lib/Graphics/Rendering/Rect/Image.hs -rw-r--r-- 2.5 KiB
54ddd7a1 — Adrian Cochrane Commit missing Image module. 1 year, 4 months ago
                                                                                
54ddd7a1 Adrian Cochrane
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
module Graphics.Rendering.Rect.Image(
    Atlas, buildAtlas, Texture(..), atlasLookup) where

import qualified Data.HashMap.Lazy as HM
import Data.Text (Text)
import Codec.Picture (DynamicImage(..), Image(..), PixelRGBA8(..), generateImage)
import Codec.Picture.Types (promoteImage, dynamicMap)

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

import Typograffiti.GL
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)
import Foreign.Ptr (castPtr)
import Foreign.Marshal.Array (allocaArray, peekArray)

data Atlas = Atlas { unAtlas :: HM.HashMap Text GLuint }

buildAtlas :: MonadIO m => (Text -> IO DynamicImage) -> [Text] -> m Atlas
buildAtlas cb srcs = do
    -- TODO Merge textures into an actual atlas.
    let len = length srcs
    textures <- liftIO $ allocaArray (toEnum len) $ \ptr -> do
        glGenTextures (toEnum len) ptr
        peekArray len ptr
    imgs <- liftIO $ forM srcs cb

    forM (zip textures imgs) $ \(texture, dyn) -> do
        let img = dynamicMap (unsafeCast . imageData) dyn
        let (format, word) = glFormat dyn
        liftIO $ glBindTexture GL_TEXTURE_2D texture
        liftIO $ unsafeWith img $
            glTexImage2D GL_TEXTURE_2D 0 GL_RGBA
                    (toEnum $ dynamicMap imageWidth dyn)
                    (toEnum $ dynamicMap imageHeight dyn)
                    0 format word

    return $ Atlas $ HM.fromList $ zip srcs textures

data Texture = Texture GLuint
atlasLookup :: Text -> Atlas -> Texture
atlasLookup key = Texture . fromMaybe 0 . HM.lookup key . unAtlas


glFormat (ImageY8 _) = (GL_LUMINANCE, GL_UNSIGNED_BYTE)
glFormat (ImageY16 _) = (GL_LUMINANCE, GL_UNSIGNED_SHORT)
glFormat (ImageY32 _) = (GL_LUMINANCE, GL_UNSIGNED_INT)
glFormat (ImageYF _) = (GL_LUMINANCE, GL_FLOAT)
glFormat (ImageYA8 _) = (GL_LUMINANCE_ALPHA, GL_BYTE)
glFormat (ImageYA16 _) = (GL_LUMINANCE_ALPHA, GL_UNSIGNED_SHORT)
glFormat (ImageRGB8 _) = (GL_RGB, GL_UNSIGNED_BYTE)
glFormat (ImageRGB16 _) = (GL_RGB, GL_UNSIGNED_SHORT)
glFormat (ImageRGBF _) = (GL_RGB, GL_FLOAT)
glFormat (ImageRGBA8 _) = (GL_RGBA, GL_UNSIGNED_BYTE)
glFormat (ImageRGBA16 _) = (GL_RGBA, GL_UNSIGNED_BYTE)
glFormat (ImageYCbCr8 _) = (GL_YCRCB_444_SGIX, GL_UNSIGNED_BYTE)
glFormat (ImageCMYK8 _) = (GL_CMYK_EXT, GL_UNSIGNED_BYTE)
glFormat (ImageCMYK16 _) = (GL_CMYK_EXT, GL_UNSIGNED_SHORT)