Types.hs

{-# LANGUAGE RecordWildCards #-}
-- So getters can implement typeclasses
{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
module Graphics.Rendering.Rect.Types(Rect(..), size, Rects(..), BoxSelector,
        Uniform, u, us, c, cs, renderRectWith, liftGL) where

import Linear (M44, V2(..), V4(..))
import qualified Data.ByteString.Char8 as B8
import Data.ByteString (ByteString)
import qualified Data.Vector.Unboxed as UV

import Typograffiti.GL
import Graphics.GL.Core32
import Graphics.GL.Types
import Foreign.Marshal.Array (withArray, withArrayLen)
import Foreign.Ptr (castPtr)

import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad (forM)
import System.Exit (die)

import Data.Colour (AlphaColour, over, alphaChannel)
import Data.Colour.SRGB (RGB(..), toSRGB)
import Data.Colour.Names (black)
import Graphics.Rendering.Rect.Image (Texture(..))

data Rect = Rect {
    left :: Float, top :: Float,
    right :: Float, bottom :: Float
} deriving (Read, Show, Eq, Ord)
rect2geom :: Rect -> UV.Vector (V2 Float)
rect2geom Rect{..} = UV.fromList
    [V2 left top, V2 right top, V2 left bottom, V2 right bottom]
size :: Rect -> (Float, Float)
size Rect {..} = (right - left, bottom - top)

data Rects = Rects {
    contentBox :: Rect,
    paddingBox :: Rect,
    borderBox :: Rect,
    marginBox :: Rect
} deriving (Read, Show, Eq, Ord)
rect :: Float -> Rect
rect x = Rect x x x x

type BoxSelector = Rects -> Rect
instance Eq BoxSelector where
    a == b = a rects == b rects
      where rects = Rects (rect 0) (rect 1) (rect 2) (rect 3)
instance Show BoxSelector where
    show a | a rects == rect 0 = "contentBox"
        | a rects == rect 1 = "paddingBox"
        | a rects == rect 2 = "borderBox"
        | a rects == rect 3 = "marginBox"
        | otherwise = "?"
      where rects = Rects (rect 0) (rect 1) (rect 2) (rect 3)
instance Read BoxSelector where
    readsPrec _ ('c':'o':'n':'t':'e':'n':'t':'B':'o':'x':t) = [(contentBox, t)]
    readsPrec _ ('p':'a':'d':'d':'i':'n':'g':'B':'o':'x':t) = [(paddingBox, t)]
    readsPrec _ ('b':'o':'r':'d':'e':'r':'B':'o':'x':t) = [(borderBox, t)]
    readsPrec _ ('m':'a':'r':'g':'i':'n':'B':'o':'x':t) = [(marginBox, t)]
    readsPrec _ _ = []

vertexShader :: ByteString
vertexShader = B8.pack $ unlines [
    "#version 330 core",
    "uniform mat4 transform;",
    "uniform vec2 origin;",
    "in vec2 pos;",
    "out vec2 coord;",
    "void main() {",
    "   gl_Position = vec4(pos, 0, 1) * transform;",
    "   coord = pos - origin;",
    "}"
  ]

type Uniform m = GLuint -> GLint -> m ()
u :: (MonadIO m, UniformValue a) => a -> Uniform m
u val prog slot = liftIO $ updateUniform prog slot val
us :: MonadIO m => [Float] -> Uniform m
us vals prog slot = do
    liftIO $ withArrayLen vals $ \len -> glUniform1fv slot (toEnum len)
    clearUniformUpdateError prog slot vals

c :: MonadIO m => AlphaColour Float -> Uniform m
c rgba = u $ c' rgba
c' :: AlphaColour Float -> V4 Float
c' rgba = V4 r g b a
  where
    a = alphaChannel rgba
    -- Workaround for missing APIs in "colour" hackage.
    RGB r g b = toSRGB $ over rgba black
cs :: MonadIO m => Int -> [AlphaColour Float] -> Uniform m
cs mlen rgba prog slot = do
    let val = map c' $ take mlen rgba
    liftIO $ withArrayLen val $ \len -> glUniform4fv slot (toEnum len) . castPtr
    clearUniformUpdateError prog slot val

renderRectWith :: (MonadIO m, MonadIO n) => ByteString -> [String] ->
        n ([Texture] -> [Uniform m] -> (a -> Rect) -> (a -> Rect) -> a
            -> M44 Float -> m ())
renderRectWith fragmentShader uniformNames = do
    vs <- liftGL $ compileOGLShader vertexShader GL_VERTEX_SHADER
    fs <- liftGL $ compileOGLShader fragmentShader GL_FRAGMENT_SHADER
    prog <- liftGL $ compileOGLProgram [("pos", 0)] [vs, fs]
    uniformIDs <- forM uniformNames $ getUniformLocation prog
    matID <- getUniformLocation prog "transform"
    originID <- getUniformLocation prog "origin"
    szID <- getUniformLocation prog "boxSize"
    glUseProgram prog
    glEnable GL_BLEND
    glBlendFunc GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA
    return $ \textures uniforms clip' origin' rects mat -> do
        vao <- liftIO $ newBoundVAO
        pbuf <- newBuffer
        bufferGeometry 0 pbuf $ rect2geom $ clip' rects

        glUseProgram prog
        liftIO $ updateUniform prog matID $ mflip mat
        let r = origin' rects
        liftIO $ updateUniform prog originID $ V2 (left r) (top r)
        liftIO $ updateUniform prog szID $ V2 (right r - left r) (bottom r - top r)
        _ <- forM (zip uniformIDs uniforms) $ \(slot, cb) -> cb prog slot

        withBoundTextures (map unTexture textures) $ do
            glBindVertexArray vao
            drawVAO prog vao GL_TRIANGLE_STRIP 4
            glBindVertexArray 0

        liftIO $ withArray [pbuf] $ glDeleteBuffers 1
        liftIO $ withArray [vao] $ glDeleteVertexArrays 1

liftGL :: MonadIO m => IO (Either String a) -> m a
liftGL n = do
    ret <- liftIO n
    case ret of
        Left err -> liftIO $ die err
        Right x -> return x

mflip :: V4 (V4 a) -> V4 (V4 a)
mflip (V4 (V4 a b cc d) (V4 e f g h) (V4 i j k l) (V4 m n o p)) =
    V4 (V4 a e i m) (V4 b f j n) (V4 cc g k o) (V4 d h l p)