~alcinnz/Mondrian

ref: 7564554b3527f7e220c09c24cc9f8035d3f196b0 Mondrian/lib/Graphics/Rendering/Rect/Image.hs -rw-r--r-- 4.4 KiB
7564554b — Adrian Cochrane Commit border renderer, make them trapazoidal. 1 year, 5 months ago 
                                                                                
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
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
{-# 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 { unAtlas :: HM.HashMap Text Texture }

buildAtlas :: MonadIO m => (Text -> IO DynamicImage) -> [Text] -> m Atlas
buildAtlas _ [] = return $ Atlas HM.empty
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

    sizes <- forM (zip textures imgs) $ \(texture, dyn) -> do
        -- NOTE: `unsafe` crashes with a divide-by-zero given a `Vector ()`
        let dyn' = convertDyn dyn
        let img = dynamicMap (unsafeCast . imageData) dyn' :: Vector Word
        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 . castPtr
        liftIO $ glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_LINEAR
        liftIO $ glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_LINEAR

        return (toEnum $ dynamicMap imageWidth dyn',
                toEnum $ dynamicMap imageHeight dyn')

    let textures' = map (uncurry Texture) $ zip textures sizes
    return $ Atlas $ HM.fromList $ zip srcs textures'

data Texture = Texture { unTexture :: GLuint, texSize :: (Float, Float) }
nilTexture :: Texture
nilTexture = Texture 0 (0, 0)
atlasLookup :: Text -> Atlas -> Texture
atlasLookup key = fromMaybe nilTexture . HM.lookup key . unAtlas
textureSetRepeat :: MonadIO m => Texture -> (Bool, Bool) -> m ()
textureSetRepeat tex (repeatX, repeatY) = do
    liftIO $ glBindTexture GL_TEXTURE_2D $ unTexture tex
    liftIO $ glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S $
        if repeatX then GL_REPEAT else GL_CLAMP_TO_BORDER
    liftIO $ glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T $
        if repeatY then GL_REPEAT else GL_CLAMP_TO_BORDER

-- Convert pixels to some flavour of RGBA
convertDyn :: DynamicImage -> DynamicImage
convertDyn (ImageY8 img) = ImageRGBA8 $ promoteImage img
convertDyn (ImageY16 img) = ImageRGBA16 $ promoteImage img
convertDyn (ImageY32 img) =
    ImageRGBF $ promoteImage (pixelMap fromIntegral img :: Image PixelF)
convertDyn (ImageYF img) = ImageRGBF $ promoteImage img
convertDyn (ImageYA8 img) = ImageRGBA8 $ promoteImage img
convertDyn (ImageYA16 img) = ImageRGBA16 $ promoteImage img
convertDyn (ImageRGB8 img) = ImageRGB8 img
convertDyn (ImageRGB16 img) = ImageRGB16 img
convertDyn (ImageRGBF img) = ImageRGBF img
convertDyn (ImageRGBA8 img) = ImageRGBA8 img
convertDyn (ImageRGBA16 img) = ImageRGBA16 img
convertDyn (ImageYCbCr8 img) = ImageRGB8 $ convertImage img
convertDyn (ImageCMYK8 img) = ImageRGB8 $ convertImage img
convertDyn (ImageCMYK16 img) = ImageRGB16 $ convertImage img

glFormat :: DynamicImage -> (GLenum, GLenum)
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)