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
{-# LANGUAGE OverloadedStrings #-}
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(..), PixelYCbCr8(..),
pixelMap, 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, Vector)
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 [] = 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
forM (zip textures imgs) $ \(texture, dyn) -> do
-- NOTE: `unsafe` crashes with a divide-by-zero given a `Vector ()`
let img = dynamicMap (unsafeCast . imageData) $ adjustGL dyn :: Vector Word
let (format, word) = glFormat dyn
liftIO $ glBindTexture GL_TEXTURE_2D texture
liftIO $ unsafeWith img $ -- FIXME: Crashes
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
liftIO $ glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_REPEAT
liftIO $ glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_REPEAT
return $ Atlas $ HM.fromList $ zip srcs textures
data Texture = Texture GLuint
atlasLookup :: Text -> Atlas -> Texture
atlasLookup key = Texture . fromMaybe 0 . HM.lookup key . unAtlas
-- OpenGL deals in CrCb not CbCr...
adjustGL (ImageYCbCr8 img) = ImageYCbCr8 $ pixelMap swapCrCb img
where swapCrCb (PixelYCbCr8 y cb cr) = PixelYCbCr8 y cr cb
adjustGL img = img
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)