{-# LANGUAGE RecordWildCards #-}
{-# 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
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)