{-# 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 {
    Rect -> Float
left :: Float, Rect -> Float
top :: Float,
    Rect -> Float
right :: Float, Rect -> Float
bottom :: Float
} deriving (ReadPrec [Rect]
ReadPrec Rect
Int -> ReadS Rect
ReadS [Rect]
(Int -> ReadS Rect)
-> ReadS [Rect] -> ReadPrec Rect -> ReadPrec [Rect] -> Read Rect
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Rect]
$creadListPrec :: ReadPrec [Rect]
readPrec :: ReadPrec Rect
$creadPrec :: ReadPrec Rect
readList :: ReadS [Rect]
$creadList :: ReadS [Rect]
readsPrec :: Int -> ReadS Rect
$creadsPrec :: Int -> ReadS Rect
Read, Int -> Rect -> ShowS
[Rect] -> ShowS
Rect -> String
(Int -> Rect -> ShowS)
-> (Rect -> String) -> ([Rect] -> ShowS) -> Show Rect
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Rect] -> ShowS
$cshowList :: [Rect] -> ShowS
show :: Rect -> String
$cshow :: Rect -> String
showsPrec :: Int -> Rect -> ShowS
$cshowsPrec :: Int -> Rect -> ShowS
Show, Rect -> Rect -> Bool
(Rect -> Rect -> Bool) -> (Rect -> Rect -> Bool) -> Eq Rect
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Rect -> Rect -> Bool
$c/= :: Rect -> Rect -> Bool
== :: Rect -> Rect -> Bool
$c== :: Rect -> Rect -> Bool
Eq, Eq Rect
Eq Rect =>
(Rect -> Rect -> Ordering)
-> (Rect -> Rect -> Bool)
-> (Rect -> Rect -> Bool)
-> (Rect -> Rect -> Bool)
-> (Rect -> Rect -> Bool)
-> (Rect -> Rect -> Rect)
-> (Rect -> Rect -> Rect)
-> Ord Rect
Rect -> Rect -> Bool
Rect -> Rect -> Ordering
Rect -> Rect -> Rect
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Rect -> Rect -> Rect
$cmin :: Rect -> Rect -> Rect
max :: Rect -> Rect -> Rect
$cmax :: Rect -> Rect -> Rect
>= :: Rect -> Rect -> Bool
$c>= :: Rect -> Rect -> Bool
> :: Rect -> Rect -> Bool
$c> :: Rect -> Rect -> Bool
<= :: Rect -> Rect -> Bool
$c<= :: Rect -> Rect -> Bool
< :: Rect -> Rect -> Bool
$c< :: Rect -> Rect -> Bool
compare :: Rect -> Rect -> Ordering
$ccompare :: Rect -> Rect -> Ordering
$cp1Ord :: Eq Rect
Ord)
rect2geom :: Rect -> UV.Vector (V2 Float)
rect2geom :: Rect -> Vector (V2 Float)
rect2geom Rect{..} = [V2 Float] -> Vector (V2 Float)
forall a. Unbox a => [a] -> Vector a
UV.fromList
    [Float -> Float -> V2 Float
forall a. a -> a -> V2 a
V2 Float
left Float
top, Float -> Float -> V2 Float
forall a. a -> a -> V2 a
V2 Float
right Float
top, Float -> Float -> V2 Float
forall a. a -> a -> V2 a
V2 Float
left Float
bottom, Float -> Float -> V2 Float
forall a. a -> a -> V2 a
V2 Float
right Float
bottom]
size :: Rect -> (Float, Float)
size :: Rect -> (Float, Float)
size Rect {..} = (Float
right Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
left, Float
bottom Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
top)

data Rects = Rects {
    Rects -> Rect
contentBox :: Rect,
    Rects -> Rect
paddingBox :: Rect,
    Rects -> Rect
borderBox :: Rect,
    Rects -> Rect
marginBox :: Rect
} deriving (ReadPrec [Rects]
ReadPrec Rects
Int -> ReadS Rects
ReadS [Rects]
(Int -> ReadS Rects)
-> ReadS [Rects]
-> ReadPrec Rects
-> ReadPrec [Rects]
-> Read Rects
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Rects]
$creadListPrec :: ReadPrec [Rects]
readPrec :: ReadPrec Rects
$creadPrec :: ReadPrec Rects
readList :: ReadS [Rects]
$creadList :: ReadS [Rects]
readsPrec :: Int -> ReadS Rects
$creadsPrec :: Int -> ReadS Rects
Read, Int -> Rects -> ShowS
[Rects] -> ShowS
Rects -> String
(Int -> Rects -> ShowS)
-> (Rects -> String) -> ([Rects] -> ShowS) -> Show Rects
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Rects] -> ShowS
$cshowList :: [Rects] -> ShowS
show :: Rects -> String
$cshow :: Rects -> String
showsPrec :: Int -> Rects -> ShowS
$cshowsPrec :: Int -> Rects -> ShowS
Show, Rects -> Rects -> Bool
(Rects -> Rects -> Bool) -> (Rects -> Rects -> Bool) -> Eq Rects
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Rects -> Rects -> Bool
$c/= :: Rects -> Rects -> Bool
== :: Rects -> Rects -> Bool
$c== :: Rects -> Rects -> Bool
Eq, Eq Rects
Eq Rects =>
(Rects -> Rects -> Ordering)
-> (Rects -> Rects -> Bool)
-> (Rects -> Rects -> Bool)
-> (Rects -> Rects -> Bool)
-> (Rects -> Rects -> Bool)
-> (Rects -> Rects -> Rects)
-> (Rects -> Rects -> Rects)
-> Ord Rects
Rects -> Rects -> Bool
Rects -> Rects -> Ordering
Rects -> Rects -> Rects
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Rects -> Rects -> Rects
$cmin :: Rects -> Rects -> Rects
max :: Rects -> Rects -> Rects
$cmax :: Rects -> Rects -> Rects
>= :: Rects -> Rects -> Bool
$c>= :: Rects -> Rects -> Bool
> :: Rects -> Rects -> Bool
$c> :: Rects -> Rects -> Bool
<= :: Rects -> Rects -> Bool
$c<= :: Rects -> Rects -> Bool
< :: Rects -> Rects -> Bool
$c< :: Rects -> Rects -> Bool
compare :: Rects -> Rects -> Ordering
$ccompare :: Rects -> Rects -> Ordering
$cp1Ord :: Eq Rects
Ord)
rect :: Float -> Rect
rect :: Float -> Rect
rect x :: Float
x = Float -> Float -> Float -> Float -> Rect
Rect Float
x Float
x Float
x Float
x

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

vertexShader :: ByteString
vertexShader :: ByteString
vertexShader = String -> ByteString
B8.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ [String] -> String
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 :: a -> Uniform m
u val :: a
val prog :: GLuint
prog slot :: GLint
slot = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ GLuint -> GLint -> a -> IO ()
forall a (m :: * -> *).
(UniformValue a, MonadIO m) =>
GLuint -> GLint -> a -> m ()
updateUniform GLuint
prog GLint
slot a
val
us :: MonadIO m => [Float] -> Uniform m
us :: [Float] -> Uniform m
us vals :: [Float]
vals prog :: GLuint
prog slot :: GLint
slot = do
    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ [Float] -> (Int -> Ptr Float -> IO ()) -> IO ()
forall a b. Storable a => [a] -> (Int -> Ptr a -> IO b) -> IO b
withArrayLen [Float]
vals ((Int -> Ptr Float -> IO ()) -> IO ())
-> (Int -> Ptr Float -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \len :: Int
len -> GLint -> GLint -> Ptr Float -> IO ()
forall (m :: * -> *).
MonadIO m =>
GLint -> GLint -> Ptr Float -> m ()
glUniform1fv GLint
slot (Int -> GLint
forall a. Enum a => Int -> a
toEnum Int
len)
    GLuint -> GLint -> [Float] -> m ()
forall (m :: * -> *) a.
(MonadIO m, Show a) =>
GLuint -> GLint -> a -> m ()
clearUniformUpdateError GLuint
prog GLint
slot [Float]
vals

c :: MonadIO m => AlphaColour Float -> Uniform m
c :: AlphaColour Float -> Uniform m
c rgba :: AlphaColour Float
rgba = V4 Float -> Uniform m
forall (m :: * -> *) a.
(MonadIO m, UniformValue a) =>
a -> Uniform m
u (V4 Float -> Uniform m) -> V4 Float -> Uniform m
forall a b. (a -> b) -> a -> b
$ AlphaColour Float -> V4 Float
c' AlphaColour Float
rgba
c' :: AlphaColour Float -> V4 Float
c' :: AlphaColour Float -> V4 Float
c' rgba :: AlphaColour Float
rgba = Float -> Float -> Float -> Float -> V4 Float
forall a. a -> a -> a -> a -> V4 a
V4 Float
r Float
g Float
b Float
a
  where
    a :: Float
a = AlphaColour Float -> Float
forall a. AlphaColour a -> a
alphaChannel AlphaColour Float
rgba
    -- Workaround for missing APIs in "colour" hackage.
    RGB r :: Float
r g :: Float
g b :: Float
b = Colour Float -> RGB Float
forall b. (Ord b, Floating b) => Colour b -> RGB b
toSRGB (Colour Float -> RGB Float) -> Colour Float -> RGB Float
forall a b. (a -> b) -> a -> b
$ AlphaColour Float -> Colour Float -> Colour Float
forall (f :: * -> *) a.
(ColourOps f, Num a) =>
AlphaColour a -> f a -> f a
over AlphaColour Float
rgba Colour Float
forall a. Num a => Colour a
black
cs :: MonadIO m => Int -> [AlphaColour Float] -> Uniform m
cs :: Int -> [AlphaColour Float] -> Uniform m
cs mlen :: Int
mlen rgba :: [AlphaColour Float]
rgba prog :: GLuint
prog slot :: GLint
slot = do
    let val :: [V4 Float]
val = (AlphaColour Float -> V4 Float)
-> [AlphaColour Float] -> [V4 Float]
forall a b. (a -> b) -> [a] -> [b]
map AlphaColour Float -> V4 Float
c' ([AlphaColour Float] -> [V4 Float])
-> [AlphaColour Float] -> [V4 Float]
forall a b. (a -> b) -> a -> b
$ Int -> [AlphaColour Float] -> [AlphaColour Float]
forall a. Int -> [a] -> [a]
take Int
mlen [AlphaColour Float]
rgba
    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ [V4 Float] -> (Int -> Ptr (V4 Float) -> IO ()) -> IO ()
forall a b. Storable a => [a] -> (Int -> Ptr a -> IO b) -> IO b
withArrayLen [V4 Float]
val ((Int -> Ptr (V4 Float) -> IO ()) -> IO ())
-> (Int -> Ptr (V4 Float) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \len :: Int
len -> GLint -> GLint -> Ptr Float -> IO ()
forall (m :: * -> *).
MonadIO m =>
GLint -> GLint -> Ptr Float -> m ()
glUniform4fv GLint
slot (Int -> GLint
forall a. Enum a => Int -> a
toEnum Int
len) (Ptr Float -> IO ())
-> (Ptr (V4 Float) -> Ptr Float) -> Ptr (V4 Float) -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr (V4 Float) -> Ptr Float
forall a b. Ptr a -> Ptr b
castPtr
    GLuint -> GLint -> [V4 Float] -> m ()
forall (m :: * -> *) a.
(MonadIO m, Show a) =>
GLuint -> GLint -> a -> m ()
clearUniformUpdateError GLuint
prog GLint
slot [V4 Float]
val

renderRectWith :: (MonadIO m, MonadIO n) => ByteString -> [String] ->
        n ([Texture] -> [Uniform m] -> (a -> Rect) -> (a -> Rect) -> a
            -> M44 Float -> m ())
renderRectWith :: ByteString
-> [String]
-> n ([Texture]
      -> [Uniform m]
      -> (a -> Rect)
      -> (a -> Rect)
      -> a
      -> M44 Float
      -> m ())
renderRectWith fragmentShader :: ByteString
fragmentShader uniformNames :: [String]
uniformNames = do
    GLuint
vs <- IO (Either String GLuint) -> n GLuint
forall (m :: * -> *) a. MonadIO m => IO (Either String a) -> m a
liftGL (IO (Either String GLuint) -> n GLuint)
-> IO (Either String GLuint) -> n GLuint
forall a b. (a -> b) -> a -> b
$ ByteString -> GLuint -> IO (Either String GLuint)
forall (m :: * -> *).
MonadIO m =>
ByteString -> GLuint -> m (Either String GLuint)
compileOGLShader ByteString
vertexShader GLuint
forall a. (Eq a, Num a) => a
GL_VERTEX_SHADER
    GLuint
fs <- IO (Either String GLuint) -> n GLuint
forall (m :: * -> *) a. MonadIO m => IO (Either String a) -> m a
liftGL (IO (Either String GLuint) -> n GLuint)
-> IO (Either String GLuint) -> n GLuint
forall a b. (a -> b) -> a -> b
$ ByteString -> GLuint -> IO (Either String GLuint)
forall (m :: * -> *).
MonadIO m =>
ByteString -> GLuint -> m (Either String GLuint)
compileOGLShader ByteString
fragmentShader GLuint
forall a. (Eq a, Num a) => a
GL_FRAGMENT_SHADER
    GLuint
prog <- IO (Either String GLuint) -> n GLuint
forall (m :: * -> *) a. MonadIO m => IO (Either String a) -> m a
liftGL (IO (Either String GLuint) -> n GLuint)
-> IO (Either String GLuint) -> n GLuint
forall a b. (a -> b) -> a -> b
$ [(String, Integer)] -> [GLuint] -> IO (Either String GLuint)
forall (m :: * -> *).
MonadIO m =>
[(String, Integer)] -> [GLuint] -> m (Either String GLuint)
compileOGLProgram [("pos", 0)] [GLuint
vs, GLuint
fs]
    [GLint]
uniformIDs <- [String] -> (String -> n GLint) -> n [GLint]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [String]
uniformNames ((String -> n GLint) -> n [GLint])
-> (String -> n GLint) -> n [GLint]
forall a b. (a -> b) -> a -> b
$ GLuint -> String -> n GLint
forall (m :: * -> *). MonadIO m => GLuint -> String -> m GLint
getUniformLocation GLuint
prog
    GLint
matID <- GLuint -> String -> n GLint
forall (m :: * -> *). MonadIO m => GLuint -> String -> m GLint
getUniformLocation GLuint
prog "transform"
    GLint
originID <- GLuint -> String -> n GLint
forall (m :: * -> *). MonadIO m => GLuint -> String -> m GLint
getUniformLocation GLuint
prog "origin"
    GLint
szID <- GLuint -> String -> n GLint
forall (m :: * -> *). MonadIO m => GLuint -> String -> m GLint
getUniformLocation GLuint
prog "boxSize"
    GLuint -> n ()
forall (m :: * -> *). MonadIO m => GLuint -> m ()
glUseProgram GLuint
prog
    GLuint -> n ()
forall (m :: * -> *). MonadIO m => GLuint -> m ()
glEnable GLuint
forall a. (Eq a, Num a) => a
GL_BLEND
    GLuint -> GLuint -> n ()
forall (m :: * -> *). MonadIO m => GLuint -> GLuint -> m ()
glBlendFunc GLuint
forall a. (Eq a, Num a) => a
GL_SRC_ALPHA GLuint
forall a. (Eq a, Num a) => a
GL_ONE_MINUS_SRC_ALPHA
    ([Texture]
 -> [Uniform m]
 -> (a -> Rect)
 -> (a -> Rect)
 -> a
 -> M44 Float
 -> m ())
-> n ([Texture]
      -> [Uniform m]
      -> (a -> Rect)
      -> (a -> Rect)
      -> a
      -> M44 Float
      -> m ())
forall (m :: * -> *) a. Monad m => a -> m a
return (([Texture]
  -> [Uniform m]
  -> (a -> Rect)
  -> (a -> Rect)
  -> a
  -> M44 Float
  -> m ())
 -> n ([Texture]
       -> [Uniform m]
       -> (a -> Rect)
       -> (a -> Rect)
       -> a
       -> M44 Float
       -> m ()))
-> ([Texture]
    -> [Uniform m]
    -> (a -> Rect)
    -> (a -> Rect)
    -> a
    -> M44 Float
    -> m ())
-> n ([Texture]
      -> [Uniform m]
      -> (a -> Rect)
      -> (a -> Rect)
      -> a
      -> M44 Float
      -> m ())
forall a b. (a -> b) -> a -> b
$ \textures :: [Texture]
textures uniforms :: [Uniform m]
uniforms clip' :: a -> Rect
clip' origin' :: a -> Rect
origin' rects :: a
rects mat :: M44 Float
mat -> do
        GLuint
vao <- 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
$ IO GLuint
forall (m :: * -> *). (MonadIO m, MonadFail m) => m GLuint
newBoundVAO
        GLuint
pbuf <- m GLuint
forall (m :: * -> *). MonadIO m => m GLuint
newBuffer
        GLuint -> GLuint -> Vector (V2 Float) -> m ()
forall (f :: * -> *) (m :: * -> *).
(Foldable f, Unbox (f Float), Storable (f Float), Finite f,
 KnownNat (Size f), MonadIO m) =>
GLuint -> GLuint -> Vector (f Float) -> m ()
bufferGeometry 0 GLuint
pbuf (Vector (V2 Float) -> m ()) -> Vector (V2 Float) -> m ()
forall a b. (a -> b) -> a -> b
$ Rect -> Vector (V2 Float)
rect2geom (Rect -> Vector (V2 Float)) -> Rect -> Vector (V2 Float)
forall a b. (a -> b) -> a -> b
$ a -> Rect
clip' a
rects

        GLuint -> m ()
forall (m :: * -> *). MonadIO m => GLuint -> m ()
glUseProgram GLuint
prog
        IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ GLuint -> GLint -> M44 Float -> IO ()
forall a (m :: * -> *).
(UniformValue a, MonadIO m) =>
GLuint -> GLint -> a -> m ()
updateUniform GLuint
prog GLint
matID (M44 Float -> IO ()) -> M44 Float -> IO ()
forall a b. (a -> b) -> a -> b
$ M44 Float -> M44 Float
forall a. V4 (V4 a) -> V4 (V4 a)
mflip M44 Float
mat
        let r :: Rect
r = a -> Rect
origin' a
rects
        IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ GLuint -> GLint -> V2 Float -> IO ()
forall a (m :: * -> *).
(UniformValue a, MonadIO m) =>
GLuint -> GLint -> a -> m ()
updateUniform GLuint
prog GLint
originID (V2 Float -> IO ()) -> V2 Float -> IO ()
forall a b. (a -> b) -> a -> b
$ Float -> Float -> V2 Float
forall a. a -> a -> V2 a
V2 (Rect -> Float
left Rect
r) (Rect -> Float
top Rect
r)
        IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ GLuint -> GLint -> V2 Float -> IO ()
forall a (m :: * -> *).
(UniformValue a, MonadIO m) =>
GLuint -> GLint -> a -> m ()
updateUniform GLuint
prog GLint
szID (V2 Float -> IO ()) -> V2 Float -> IO ()
forall a b. (a -> b) -> a -> b
$ Float -> Float -> V2 Float
forall a. a -> a -> V2 a
V2 (Rect -> Float
right Rect
r Float -> Float -> Float
forall a. Num a => a -> a -> a
- Rect -> Float
left Rect
r) (Rect -> Float
bottom Rect
r Float -> Float -> Float
forall a. Num a => a -> a -> a
- Rect -> Float
top Rect
r)
        [()]
_ <- [(GLint, Uniform m)] -> ((GLint, Uniform m) -> m ()) -> m [()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ([GLint] -> [Uniform m] -> [(GLint, Uniform m)]
forall a b. [a] -> [b] -> [(a, b)]
zip [GLint]
uniformIDs [Uniform m]
uniforms) (((GLint, Uniform m) -> m ()) -> m [()])
-> ((GLint, Uniform m) -> m ()) -> m [()]
forall a b. (a -> b) -> a -> b
$ \(slot :: GLint
slot, cb :: Uniform m
cb) -> Uniform m
cb GLuint
prog GLint
slot

        [GLuint] -> m () -> m ()
forall (m :: * -> *) a. MonadIO m => [GLuint] -> m a -> m a
withBoundTextures ((Texture -> GLuint) -> [Texture] -> [GLuint]
forall a b. (a -> b) -> [a] -> [b]
map Texture -> GLuint
unTexture [Texture]
textures) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
            GLuint -> m ()
forall (m :: * -> *). MonadIO m => GLuint -> m ()
glBindVertexArray GLuint
vao
            GLuint -> GLuint -> Uniform m
forall (m :: * -> *).
MonadIO m =>
GLuint -> GLuint -> GLuint -> GLint -> m ()
drawVAO GLuint
prog GLuint
vao GLuint
forall a. (Eq a, Num a) => a
GL_TRIANGLE_STRIP 4
            GLuint -> m ()
forall (m :: * -> *). MonadIO m => GLuint -> m ()
glBindVertexArray 0

        IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ [GLuint] -> (Ptr GLuint -> IO ()) -> IO ()
forall a b. Storable a => [a] -> (Ptr a -> IO b) -> IO b
withArray [GLuint
pbuf] ((Ptr GLuint -> IO ()) -> IO ()) -> (Ptr GLuint -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ GLint -> Ptr GLuint -> IO ()
forall (m :: * -> *). MonadIO m => GLint -> Ptr GLuint -> m ()
glDeleteBuffers 1
        IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ [GLuint] -> (Ptr GLuint -> IO ()) -> IO ()
forall a b. Storable a => [a] -> (Ptr a -> IO b) -> IO b
withArray [GLuint
vao] ((Ptr GLuint -> IO ()) -> IO ()) -> (Ptr GLuint -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ GLint -> Ptr GLuint -> IO ()
forall (m :: * -> *). MonadIO m => GLint -> Ptr GLuint -> m ()
glDeleteVertexArrays 1

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

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