packages feed

opengles 0.5.0 → 0.6.0

raw patch · 16 files changed

+812/−452 lines, 16 filesdep +distributivedep +lensdep +lineardep −linear-vect

Dependencies added: distributive, lens, linear

Dependencies removed: linear-vect

Files

Graphics/EGL.hs view
@@ -9,11 +9,9 @@ -- <http://www.khronos.org/files/egl-1-4-quick-reference-card.pdf> module Graphics.EGL where import Control.Applicative-import Data.IORef import Foreign import Foreign.C.String import System.IO.Unsafe (unsafePerformIO)-import Unsafe.Coerce #if __GLASGOW_HASKELL__ import GHC.Base (realWorld#) import GHC.CString (unpackCString#)
Graphics/OpenGLES.hs view
@@ -14,22 +14,24 @@   module Data.Int,   module Data.Word,   module Graphics.OpenGLES.Buffer,+  module Graphics.OpenGLES.Framebuffer,   module Graphics.OpenGLES.Core,+  module Graphics.OpenGLES.Env,+  module Graphics.OpenGLES.PixelFormat,   module Graphics.OpenGLES.State,   module Graphics.OpenGLES.Texture,   module Graphics.OpenGLES.Types,-  module Linear.Class,-  module Linear.Vect,-  module Linear.Mat+  module Linear   ) where import Control.Future import Data.Int import Data.Word import Graphics.OpenGLES.Buffer+import Graphics.OpenGLES.Framebuffer import Graphics.OpenGLES.Core+import Graphics.OpenGLES.Env+import Graphics.OpenGLES.PixelFormat import Graphics.OpenGLES.State import Graphics.OpenGLES.Texture import Graphics.OpenGLES.Types-import Linear.Class-import Linear.Vect-import Linear.Mat+import Linear
Graphics/OpenGLES/Buffer.hs view
@@ -1,7 +1,12 @@-{-# LANGUAGE ScopedTypeVariables#-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances,KindSignatures,TypeFamilies,OverlappingInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverlappingInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeFamilies #-}+ module Graphics.OpenGLES.Buffer (+   -- * Buffer   -- ** Constructing Mutable Buffers   Buffer,@@ -34,8 +39,8 @@   -- | /3+ or GL_NV_copy_buffer/   copy_read_buffer, copy_write_buffer   ) where+ import Control.Applicative-import Data.Array.Base (getNumElements) import Data.Array.Storable import Data.Array.Storable.Internals import qualified Data.ByteString as B@@ -44,6 +49,7 @@ import Graphics.OpenGLES.Base import Graphics.OpenGLES.Internal import Graphics.OpenGLES.Env+import Graphics.OpenGLES.Types import Foreign hiding (newArray)  -- ** Constructing Mutable Buffers@@ -54,7 +60,7 @@ type instance Content Int x = x type instance Content B.ByteString x = x type instance Content [a] x = a-type instance Content ([a],Int) x = a+type instance Content ([a], Int) x = a type instance Content (GLArray a) x = a  class (Storable b, b ~ Content a b) => GLSource a b where@@ -66,12 +72,15 @@ 	makeWriter len = (\ptr -> B.memset (castPtr ptr) 0 		(fromIntegral $ len * sizeOf (undefined :: b)) 			>> return (), len)+ instance Storable a => GLSource ([a], Int) a where-	makeAref (xs, len) = Left <$> newListArray (0, len) (cycle xs)+	makeAref (xs, len) = Left <$> newListArray (0, len - 1) (cycle xs) 	makeWriter (xs, len) = (\ptr -> pokeArray ptr xs, len)+ instance Storable a => GLSource [a] a where-	makeAref xs = Left <$> newListArray (0, length xs) xs+	makeAref xs = Left <$> newListArray (0, length xs - 1) xs 	makeWriter xs = (\ptr -> pokeArray ptr xs, length xs)+ instance Storable b => GLSource B.ByteString b where 	makeAref bs@(B.PS foreignPtr offset len) = do 		let fp | offset == 0 = foreignPtr@@ -83,6 +92,7 @@ 		withForeignPtr fp $ \src -> 			B.memcpy (castPtr dst) (advancePtr (castPtr src) offset) len 		, len `div` sizeOf (undefined :: b))+ instance Storable a => GLSource (GLArray a) a where 	makeAref = return . Left 	makeWriter sa@(StorableArray _ _ len fp) =@@ -90,6 +100,7 @@ 			B.memcpy (castPtr dst) (castPtr src) 			(len * sizeOf (undefined :: a)) 		, len)+ --instance GLSource (Buffer a) a where --	makeAref (Buffer aref glo) = return . Left =<< go =<< readIORef aref --	where@@ -126,6 +137,7 @@ 				withStorableArraySize sa (bufferData array_buffer usage) 			Right elems -> 				bufferData array_buffer usage (elems * unit) nullPtr+		void $ showError "glBufferData" 		) where unit = sizeOf (undefined :: b) 	-- TODO BufferArchive @@ -148,8 +160,10 @@ 	if hasES3 then do 		ptr <- mapBufferRange array_buffer (offsetIx * unit) size 			(map_write_bit + map_invalidate_range_bit + map_unsynchronized_bit)+		showError "glMapBufferRange" 		fillSubArray ptr 		unmapBuffer array_buffer+		showError "glUnmapBuffer" 		case aref' of Left (StorableArray _ _ len _) -> 				writeIORef aref (Right (len * unit)) 	else do@@ -160,6 +174,7 @@ 			let ptr = advancePtr p (offsetIx * unit) 			fillSubArray ptr 			bufferSubData array_buffer (offsetIx * unit) size ptr+			showError "glBufferSubData" 		writeIORef aref (Left sa)
Graphics/OpenGLES/Core.hs view
@@ -15,7 +15,8 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-}-+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-} module Graphics.OpenGLES.Core (   GL,   -- * Lifecycle@@ -24,10 +25,11 @@   withGL, resetDrawQueue,   glLog, glReadLogs, glLogContents,   flushCommandQ, finishCommands,+  glFrameCount, glFlipping, framesize,      -- * Draw Operation   -- ** Clear Screen-  clear, ClearBufferMask,+  clear, BufferMask,   depthBuffer, stencilBuffer, colorBuffer,      -- ** Draw@@ -39,13 +41,13 @@   drawTriangles, triangleStrip, triangleFan,    -- ** Graphics State-  GraphicsState,+  RenderConfig, renderTo,    -- ** Programmable Shader   Shader, vertexShader, fragmentShader, pixelShader,   computeShader, geometryShader,   tessellationEvalS, tessellationCtrlS,-  Program,+  Program, module Data.Typeable,   TransformFeedback(..), ProgramBinary,   glCompile, glValidate,   @@ -55,7 +57,7 @@   -- ** Vertex Attribute Array   Attrib, attrib, normalized, divisor, (&=),   VertexArray, glVA,-  ShaderAttribute, AttrStruct, SetVertexAttr,+  VertexAttribute, AttrStruct, SetVertexAttr,      -- ** Constant Vertex Attribute   constAttrib,@@ -80,12 +82,11 @@ import Data.IORef import Data.Typeable import Foreign-import Foreign.C.String (peekCString, peekCStringLen)+import Foreign.C.String (peekCStringLen) import Graphics.OpenGLES.Base import Graphics.OpenGLES.Buffer import Graphics.OpenGLES.Env import Graphics.OpenGLES.Internal-import Graphics.OpenGLES.Types   -- * Initialization@@ -103,7 +104,7 @@ 	let loop count = do 		putStrLn $ "start draw " ++ show count 		readChan drawQueue >>= id-		loop (count + 1)+		loop (count + 1 :: Integer) 	catch (loop 0) $ \(e :: SomeException) -> do 		glLog $ "Rendering thread terminated: " ++ show e 		suspendGL@@ -146,13 +147,13 @@ -- so make it sure they are removed from the queue. resetDrawQueue :: IO () resetDrawQueue = do-	empty <- isEmptyChan drawQueue-	when (not empty) (readChan drawQueue >> resetDrawQueue)+	isEmpty <- isEmptyChan drawQueue+	when (not isEmpty) (readChan drawQueue >> resetDrawQueue)  glReadLogs :: IO [String] glReadLogs = do-	empty <- isEmptyChan errorQueue-	if empty+	isEmpty <- isEmptyChan errorQueue+	if isEmpty 		then return [] 		else (:) <$> readChan errorQueue <*> glReadLogs @@ -175,26 +176,32 @@ glFlipping :: IO Bool glFlipping = fmap odd glFrameCount +-- | > GLFW.setFramebufferSizeCallback win $ Just (const framesize)+framesize :: Int -> Int -> IO ()+framesize w h = runGL $ glViewport 0 0 (f w) (f h)+	where f = fromIntegral + -- * Drawing  -- | -- > clear [] colorBuffer--- > clear [bindFramebuffer buf] (colorBuffer+depthBuffer)+-- > clear [bindFb framebuffer] (colorBuffer+depthBuffer) clear-	:: [GraphicsState]-	-> ClearBufferMask+	:: [RenderConfig]+	-> BufferMask 	-> GL ()-clear gs (ClearBufferMask flags) = sequence gs >> glClear flags+clear gs (BufferMask flags) = sequence gs >> glClear flags -depthBuffer = ClearBufferMask 0x100-stencilBuffer = ClearBufferMask 0x400-colorBuffer = ClearBufferMask 0x4000+depthBuffer, stencilBuffer, colorBuffer :: BufferMask+depthBuffer = BufferMask 0x100+stencilBuffer = BufferMask 0x400+colorBuffer = BufferMask 0x4000  glDraw :: Typeable p 	=> DrawMode 	-> Program p-	-> [GraphicsState]+	-> [RenderConfig] 	-> [UniformAssignment p] 	-> VertexArray p 	-> VertexPicker@@ -211,11 +218,23 @@ 	picker mode  -- | See "Graphics.OpenGLES.State"-type GraphicsState = GL ()+type RenderConfig = GL () +-- |+-- > renderTo $ do+-- >     bindFb defaultFramebuffer+-- >     viewport $ V4 0 0 512 512+-- >     depthRange $ V2 0.1 10.0+-- >     begin culling+-- >     cullFace hideBack+renderTo :: RenderConfig -> GL ()+renderTo = id + -- ** Draw Mode +drawPoints, drawLines, drawLineLoop, drawLineStrip,+	drawTriangles, triangleStrip, triangleFan :: DrawMode drawPoints = DrawMode 0 drawLines = DrawMode 1 drawLineLoop = DrawMode 2@@ -300,9 +319,9 @@  -- ** Vertex Attribute --- normalized color `divisor` 1 &= buffer+-- | @normalized color `divisor` 1 &= buffer@ attrib-	:: forall p a. (ShaderAttribute a, Typeable p)+	:: forall p a. (VertexAttribute a, Typeable p) 	=> GLName -> IO (Attrib p a) attrib name = do 	desc <- lookupVarDesc typ@@ -327,10 +346,10 @@  type SetVertexAttr p = GL () -(&=) :: AttrStruct b a p => a -> Buffer b -> SetVertexAttr p-attrib &= buf = do+(&=) :: AttrStruct a p b => a -> Buffer b -> SetVertexAttr p+attribs &= buf = do 	bindBuffer array_buffer buf-	glVertexAttribPtr attrib buf+	glVertexBuffer attribs buf   glVA :: [SetVertexAttr p] -> GL (VertexArray p)@@ -339,28 +358,16 @@ 	glo <- case extVAO of 		Nothing -> return (error "GLO not used") 		Just (gen, bind, del) ->-			newGLO gen del (\i-> bind i >> setVA)+			newGLO gen del (\i -> bind i >> setVA) 	return $ VertexArray (glo, setVA)   -- ** Constant Vertex Attribute -constAttrib :: ShaderAttribute a => Attrib p a -> a -> SetVertexAttr p-constAttrib (Attrib (idx, s, n, d)) val = do-	glDisableVertexAttribArray idx-	glVertexAttrib idx val----withConstAttr :: Attrib p a -> GL b -> GL b---withConstAttr (Attrib (idx, _, _, _)) io = do---	glDisableVertexAttribArray idx---	result <- io---	glEnableVertexAttribArray idx----- ** Texture-data Texture = Texture Int32-instance UnifVal Texture where-	glUniform unif (Texture i) = glUniform unif i+constAttrib :: VertexAttribute a => Attrib p a -> a -> SetVertexAttr p+constAttrib (Attrib (ix, _, _, _)) val = do+	glDisableVertexAttribArray ix+	glVertexAttrib ix val   -- ** Vertex Picker
Graphics/OpenGLES/Framebuffer.hs view
@@ -2,16 +2,32 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-}-module Graphics.OpenGLES.Framebuffer where+module Graphics.OpenGLES.Framebuffer (+  -- * Renderbuffer+  glRenderbuffer,+  unsafeRenderbuffer,+  +  -- * Framebuffer+  glFramebuffer,+  CR(..), Attachable, DepthStencil,+  colorOnly, depthImage, stencilImage, depthStencil,+  +  -- * Framebuffer Settings+  bindFb, withFb,+  defaultFramebuffer,+  viewport, getViewport, withViewport,+  depthRange, getDepthRange, withDepthRange+  ) where import Control.Applicative-import Control.Monad (when) import Data.IORef import Foreign import Graphics.OpenGLES.Base import Graphics.OpenGLES.Env (hasES3) import Graphics.OpenGLES.Internal import Graphics.OpenGLES.PixelFormat-import Linear.Vect+import Graphics.TextureContainer.KTX+import Linear.V2+import Linear.V4  -- | -- New Renderbuffer with specified sample count and dimentions.@@ -42,21 +58,28 @@ 		modifyIORef maxDims (\(V2 mw mh)-> V2 (max w mw) (max h mh)) 		glFramebufferRenderbuffer 0x8D40 attachment 0x8D41 rb ---instance Attachable Texture a where---	glAttachToFramebuffer attachment (Texture textgt ktx glo) maxDims = do---		tex <- getObjId glo---		let V2 w h = ktx...---		modifyIORef maxDims (\(V2 mw mh)-> V2 (max w mw) (max h mh))---		case textgt of-			-- Texture2D-			-- CubeMap---			glFramebufferTexture2D 0x8D40 attachment textgt tex level-			-- Texture3D-			-- Texture2DArray---			glFramebufferTextureLayer 0x8D40 attachment tex level layer+instance Attachable Texture a where+	glAttachToFramebuffer attachment (Texture textgt ktx glo) maxDims = do+		tex <- getObjId glo+		k <- readIORef ktx+		let w = fromIntegral $ ktxPixelWidth k+		let h = fromIntegral $ ktxPixelHeight k+		modifyIORef maxDims (\(V2 mw mh)-> V2 (max w mw) (max h mh))+		let level = 0; layer = 0+		-- XXX multisample texure sholud use texture_2d_multisample+		case textgt of+			x | x == texture_2d ->+				glFramebufferTexture2D 0x8D40 attachment textgt tex level+			x | x == texture_cube_map ->+				glFramebufferTexture2D 0x8D40 attachment texture_cube_map_positive_x tex level+			x | x == texture_2d_array ->+				glFramebufferTextureLayer textgt attachment tex level layer+			x | x == texture_3d ->+				glFramebufferTextureLayer textgt attachment tex level layer+			_ -> error "glAttachToFramebuffer: Invalid Texture target" -newtype DepthStencil = DepthStencil (IORef (V2 Int32) -> GL ()) data CR = forall a c. (Attachable a c, ColorRenderable c) => CR (a c)+newtype DepthStencil = DepthStencil (IORef (V2 Int32) -> GL ())  colorOnly :: DepthStencil colorOnly = DepthStencil (const $ return ())@@ -106,15 +129,15 @@  -- | -- Cliping current framebuffer. Note that origin is left-bottom.-setViewport :: V4 Int32 -> GL ()-setViewport (V4 x y w h) = glViewport x y w h+viewport :: V4 Int32 -> GL ()+viewport (V4 x y w h) = glViewport x y w h  withViewport :: V4 Int32 -> GL a -> GL a withViewport vp io = do 	old <- getViewport-	setViewport vp+	viewport vp 	result <- io-	setViewport old+	viewport old 	return result  -- XXX maybe slow (untested)@@ -124,14 +147,14 @@ 	[n,f] <- peekArray 2 p 	return $ V2 n f -setDepthRange :: V2 Float -> GL ()-setDepthRange (V2 near far) = glDepthRangef near far+depthRange :: V2 Float -> GL ()+depthRange (V2 near far) = glDepthRangef near far  withDepthRange :: V2 Float -> GL a -> GL a withDepthRange dr io = do 	old <- getDepthRange-	setDepthRange dr+	depthRange dr 	result <- io-	setDepthRange old+	depthRange old 	return result
Graphics/OpenGLES/Internal.hs view
@@ -15,7 +15,8 @@ import Foreign.C.String (peekCString, peekCStringLen) import Foreign.Concurrent (newForeignPtr, addForeignPtrFinalizer) import Graphics.OpenGLES.Base-import Linear.Vect+import Graphics.TextureContainer.KTX+import Linear.V2 import System.IO.Unsafe (unsafePerformIO)  -- * Internal@@ -29,6 +30,7 @@ frameCounter :: IORef Int frameCounter = unsafePerformIO $ newIORef 0 + -- ** Logging  errorQueue :: Chan String@@ -62,7 +64,9 @@ 		glLog ("E " ++ location ++ ": " ++ show err) 		return True ) + -- ** GL Object management+ type GLO = IORef GLObj data GLObj = GLObj GLuint (GL GLObj) (ForeignPtr GLuint) @@ -105,6 +109,7 @@   -- ** Types+ -- VertexArray -- 2.0 newtype HalfFloat = HalfFloat Word16 deriving (Num,Storable)@@ -173,6 +178,7 @@  newtype BufferSlot = BufferSlot GLenum + -- ** DrawMode  newtype DrawMode = DrawMode GLenum@@ -409,6 +415,7 @@ -- ** Uniform  -- (location, length of array or 1, ptr)+-- Uniform location is unique to each program newtype Uniform p a = Uniform (GLint, GLsizei, Ptr ())  -- @@ -431,24 +438,17 @@  -- ** Attrib --- (index, size, normalize, divisor)-newtype Attrib p a = Attrib (GLuint, GLsizei, GLboolean, GLuint) deriving Show--class (Num a, Storable a) => GenericVertexAttribute a where-	glVertexAttrib4v :: GLuint -> Ptr (V4 a) -> GL ()--instance GenericVertexAttribute Float where-	glVertexAttrib4v idx = glVertexAttrib4fv idx . castPtr-instance GenericVertexAttribute Int32 where-	glVertexAttrib4v idx = glVertexAttribI4iv idx . castPtr-instance GenericVertexAttribute Word32 where-	glVertexAttrib4v idx = glVertexAttribI4uiv idx . castPtr+-- Attrib program glsl_type = (index, size, normalize, divisor)+newtype Attrib p a = Attrib (GLuint, GLsizei, GLboolean, GLuint)+	deriving Show -class ShaderAttribute a where+-- | GLSL vertex attribute type+class VertexAttribute a where 	glVertexAttrib :: GLuint -> a -> GL () -class Storable b => AttrStruct b a p | a -> p where-	glVertexAttribPtr :: a -> Buffer b -> GL ()+-- | A set of 'VertexAttribute's packed in a 'Buffer'+class AttrStruct a p b | a -> p where+	glVertexBuffer :: a -> Buffer b -> GL ()   -- ** Vertex Array Object@@ -473,7 +473,7 @@  -- ** Draw Operation -newtype ClearBufferMask = ClearBufferMask GLenum deriving Num+newtype BufferMask = BufferMask GLenum deriving Num  -- [MainThread, GLThread] -- if Nothing, main GL thread should stop before the next frame.@@ -499,3 +499,17 @@ 	dummy <- newIORef undefined 	return $ Framebuffer dummy glo ++-- ** Texture++-- glo, target, ktx+data Texture a = Texture GLenum (IORef Ktx) GLO++texture_2d, texture_cube_map, texture_2d_array, texture_3d,+	texture_cube_map_positive_x :: Word32+texture_2d = 0x0DE1+texture_cube_map = 0x8513+texture_2d_array = 0x8C1A+texture_3d = 0x806F++texture_cube_map_positive_x = 0x8515
Graphics/OpenGLES/PixelFormat.hs view
@@ -2,20 +2,14 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} module Graphics.OpenGLES.PixelFormat where import Data.Proxy-import GHC.TypeLits import Data.Int import Data.Word import Graphics.OpenGLES.Internal import Graphics.OpenGLES.Base-import Linear.Vect---import Linear+import Linear  -- Texture Only Sized Internal Formats data R8snorm@@ -85,20 +79,20 @@   class InternalFormat a b | b -> a where-	ifmt :: p (a, b) -> (GLenum,GLenum,GLenum)+	ifmt :: p (a, b) -> (GLenum, GLenum, GLenum)  class ExternalFormat a b where-	efmt :: p (a, b) -> (GLenum,GLenum,GLenum)+	efmt :: p (a, b) -> (GLenum, GLenum, GLenum)  class InternalFormat a b => ES2Format a b where-	es2fmt :: p (a, b) -> (GLenum,GLenum,GLenum)+	es2fmt :: p (a, b) -> (GLenum, GLenum, GLenum) 	es2fmt x = case ifmt x of 		(format, typ, _) -> (format, typ, format)  #define PixelFormat(_dim, _type, _tag, _format, _internal_fmt) \ instance InternalFormat (_dim _type) _tag where \ 	{-# INLINE ifmt #-}; \-	ifmt _ = (_format,glType ([] :: [_type]),_internal_fmt) \+	ifmt _ = (_format, glType ([] :: [_type]), _internal_fmt) \  PixelFormat(, Int8, R8snorm, r, 0x8F94) PixelFormat(V2, Int8, Rg8snorm, rg, 0x8F95)@@ -168,7 +162,7 @@ #define PixelFormat2(_dim, _type, _tag, _format, _internal_fmt) \ instance ExternalFormat (_dim _type) _tag where \ 	{-# INLINE efmt #-}; \-	efmt _ = (_format,glType ([] :: [_type]),_internal_fmt) \+	efmt _ = (_format, glType (Proxy :: Proxy _type), _internal_fmt) \  PixelFormat2(V4, Word8, Rgb5a1, rgba, 0x8057) -- RGBA W8 PixelFormat2(V4, Word8, Rgba4, rgba, 0x8056) -- RGBA W8@@ -234,50 +228,4 @@ instance StencilRenderable Depth24Stencil8 instance StencilRenderable Depth32fStencil8 instance StencilRenderable Stencil8 -- optional--type family SizeOf (f :: *) :: Nat-type instance SizeOf Float = 4-type instance SizeOf HalfFloat = 2---type instance SizeOf FixedFloat = 4-type instance SizeOf Word8 = 1-type instance SizeOf Word16 = 2-type instance SizeOf Word32 = 4-type instance SizeOf Int8 = 1-type instance SizeOf Int16 = 2-type instance SizeOf Int32 = 4-type instance SizeOf Int2_10x3 = 4-type instance SizeOf Word2_10x3 = 4-type instance SizeOf Word4444 = 2-type instance SizeOf Word5551 = 2-type instance SizeOf Word10f11f11f = 4-type instance SizeOf Word5999 = 4-type instance SizeOf Word24_8 = 4-type instance SizeOf FloatWord24_8 = 8-type instance SizeOf (V2 a) = Aligned (2 * SizeOf a)-type instance SizeOf (V3 a) = Aligned (3 * SizeOf a)-type instance SizeOf (V4 a) = Aligned (4 * SizeOf a)----type family Sum (l :: [Nat]) :: Nat---type instance Sum '[] = 0---type instance Sum (x ': xs) = x + Sum xs----type family Map (f :: * -> *) (xs :: [*]) :: [*]---type instance Map f '[] = '[]---type instance Map f (x ': xs) = f x ': Map f xs--type family Stride (l :: [*]) :: Nat-type instance Stride '[] = 0-type instance Stride (x ': xs) = SizeOf x + Stride xs--type family Aligned (x :: Nat) :: Nat-type instance Aligned x = If (x <=? 3) 4 x--type family If (p :: Bool) (t :: Nat) (f :: Nat) :: Nat-type instance If True x y = x-type instance If False x y = y----type family ImageOf---type instance ImageOf Rgba8 = V4 Word8---type instance ImageOf Rgba4 = Word16---type instance ImageOf Rgba4FromRgba8 = Word16
Graphics/OpenGLES/Texture.hs view
@@ -37,12 +37,10 @@ import Graphics.OpenGLES.Base import Graphics.OpenGLES.Env import Graphics.OpenGLES.Internal-import Graphics.OpenGLES.PixelFormat+--import Graphics.OpenGLES.PixelFormat import Graphics.TextureContainer.KTX import Foreign.Ptr (castPtr) --- glo, target, ktx-data Texture a = Texture GLenum (IORef Ktx) GLO -- XXX Texture DoubleBufferring  newtype Texture3D a = Texture3D (Texture a)@@ -203,13 +201,6 @@ 	| max (max ktxPixelDepth ktxPixelHeight) ktxPixelDepth < 2^(ktxNumMipLevels-1) 	= Left "checkKtx: Can't have more mip levels than 1 + log2(max(width, height, depth))" needsGenMipmap _ = Right False--texture_2d = 0x0DE1-texture_cube_map = 0x8513-texture_2d_array = 0x8C1A-texture_3d = 0x806F--texture_cube_map_positive_x = 0x8515   -- ** Sampler
Graphics/OpenGLES/Types.hs view
@@ -1,61 +1,145 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverlappingInstances #-} {-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+ module Graphics.OpenGLES.Types (+   -- * Shading Language Base Types+  M23, M24, M32, M34, M42,   Vec2, Vec3, Vec4,-  BVec2, BVec3, BVec4,+  -- BVec2, BVec3, BVec4,   IVec2, IVec3, IVec4,   UVec2, UVec3, UVec4,   Mat2, Mat3, Mat4,   Mat2x3, Mat2x4, Mat3x2,   Mat3x4, Mat4x2, Mat4x3,+  +  -- * Vertex Attribute Array Source Datatypes+  HalfFloat(..), FixedFloat(..),+  Int2_10x3(..), Word2_10x3(..), +  -- * Texture Pixel Formats+  Word4444(..), Word5551(..), Word565(..),+  Word10f11f11f(..), Word5999(..), Word24_8(..),+  FloatWord24_8(..),++  -- * Type-Level Utilities+  SizeOf, Aligned, Stride, castGL,+   -- * Uniform Variable   Uniform, UnifVal,      -- * Vertex Attribute-  Attrib, ShaderAttribute, AttrStruct,-  -  -- * Vertex Attribute Array Source Datatypes-  HalfFloat(..), FixedFloat(..),-  Int2_10x3(..), Word2_10x3(..)+  Attrib, VertexAttribute,+  AttrElement, Vectorize, VDim,+  VertexAttributeArray, AttrStruct,++  GLStorable(..)   ) where++import Control.Applicative+import Control.Lens.Indexed (FoldableWithIndex, iforM_)+import Control.Lens.Getter ((^.)) import Control.Monad (when)+import Data.Distributive+import Data.Proxy import Foreign-import Linear.Class (Transpose, transpose)-import Linear.Vect-import Linear.Mat+import GHC.TypeLits import Graphics.OpenGLES.Base import Graphics.OpenGLES.Internal-+import Linear+import Unsafe.Coerce +type M23 a = V2 (V3 a)+type M24 a = V2 (V4 a)+type M32 a = V3 (V2 a)+type M34 a = V3 (V4 a)+type M42 a = V4 (V2 a) type Vec2 = V2 Float type Vec3 = V3 Float type Vec4 = V4 Float-type BVec2 = V2 Bool-type BVec3 = V3 Bool-type BVec4 = V4 Bool+--type BVec2 = V2 Bool+--type BVec3 = V3 Bool+--type BVec4 = V4 Bool type IVec2 = V2 Int32 type IVec3 = V3 Int32 type IVec4 = V4 Int32 type UVec2 = V2 Word32 type UVec3 = V3 Word32 type UVec4 = V4 Word32-type Mat2 = M2 Float-type Mat3 = M3 Float-type Mat4 = M4 Float-type Mat2x3 = M2x3 Float-type Mat2x4 = M2x4 Float-type Mat3x2 = M3x2 Float-type Mat3x4 = M3x4 Float-type Mat4x2 = M4x2 Float-type Mat4x3 = M4x3 Float+type Mat2 = M22 Float+type Mat3 = M33 Float+type Mat4 = M44 Float+type Mat2x3 = M23 Float+type Mat2x4 = M24 Float+type Mat3x2 = M32 Float+type Mat3x4 = M34 Float+type Mat4x2 = M42 Float+type Mat4x3 = M43 Float +type family SizeOf (f :: *) :: Nat where+	SizeOf Float = 4+	SizeOf HalfFloat = 2+	SizeOf FixedFloat = 4+	SizeOf Word8 = 1+	SizeOf Word16 = 2+	SizeOf Word32 = 4+	SizeOf Int8 = 1+	SizeOf Int16 = 2+	SizeOf Int32 = 4+	SizeOf Int2_10x3 = 4+	SizeOf Word2_10x3 = 4+	SizeOf Word4444 = 2+	SizeOf Word5551 = 2+	SizeOf Word10f11f11f = 4+	SizeOf Word5999 = 4+	SizeOf Word24_8 = 4+	SizeOf FloatWord24_8 = 8+	SizeOf (V2 a) = 2 * SizeOf a+	SizeOf (V3 a) = 3 * SizeOf a+	SizeOf (V4 a) = 4 * SizeOf a +type family Aligned (x :: Nat) :: Nat where+	Aligned 0 = 0+	Aligned 1 = 4+	Aligned 2 = 4+	Aligned 3 = 4+	Aligned x = 4 + Aligned (x - 4)++type family Stride (list :: [*]) :: Nat where+	Stride '[] = 0+	Stride (x ': xs) = Aligned (SizeOf x) + Stride xs++castGL ::+	CmpNat (Aligned (SizeOf x)) (Aligned (SizeOf y)) ~ EQ+	=> p x -> p y+castGL = unsafeCoerce++--type family If (p :: Bool) (t :: Nat) (f :: Nat) :: Nat where+--	If True x y = x+--	If False x y = y++--type family Sum (l :: [Nat]) :: Nat+--type instance Sum '[] = 0+--type instance Sum (x ': xs) = x + Sum xs++--type family Map (f :: * -> *) (xs :: [*]) :: [*]+--type instance Map f '[] = '[]+--type instance Map f (x ': xs) = f x ': Map f xs++--type family ImageOf+--type instance ImageOf Rgba8 = V4 Word8+--type instance ImageOf Rgba4 = Word16+--type instance ImageOf Rgba4FromRgba8 = Word16++ --instance UnifVal Float where --	glUniform (loc, _, _) x = glUniform1f loc x @@ -76,18 +160,12 @@ Uniform(UVec3,(V3 x y z),3ui,x y z) Uniform(UVec4,(V4 x y z w),4ui,x y z w) ---instance UnifVal [Float] where---	glUniform (loc, len, ptr) values = do---		let len' = fromIntegral len---		pokeArray (castPtr ptr :: Ptr Float) (take len' values)---		glUniform1fv loc len (castPtr ptr)-+{-# NOINLINE pokeUniformArray #-} pokeUniformArray 	:: Storable b => (GLint -> GLsizei -> Ptr a -> GL ()) 	-> (GLint, GLsizei, Ptr ()) -> [b] -> GL () pokeUniformArray glUniformV (loc, len, ptr) values = do-	let len' = fromIntegral len-	pokeArray (castPtr ptr :: Ptr b) (take len' values)+	pokeArray (castPtr ptr) (take (fromIntegral len) values) 	glUniformV loc len (castPtr ptr)  instance UnifVal [Float] where glUniform = pokeUniformArray glUniform1fv@@ -103,185 +181,76 @@ instance UnifVal [UVec3] where glUniform = pokeUniformArray glUniform3uiv instance UnifVal [UVec4] where glUniform = pokeUniformArray glUniform4uiv --- 'transpose' argument must be GL_FALSE in GL ES 2.0-pokeMatrix :: (Transpose a b, Storable b)-	=> (GLint -> GLsizei -> GLboolean -> Ptr GLfloat -> GL ())-	-> (GLint, GLsizei, Ptr ()) -> a -> GL ()-pokeMatrix glUniformMatrixV (loc, 1, ptr) matrix = do-	poke (castPtr ptr :: Ptr b) (transpose matrix)-	glUniformMatrixV loc 1 0 (castPtr ptr)-pokeMatrix _ _ _ = return () -- poke to nullPtr---instance UnifVal Mat2 where glUniform = pokeMatrix glUniformMatrix2fv-instance UnifVal Mat3 where glUniform = pokeMatrix glUniformMatrix3fv-instance UnifVal Mat4 where glUniform = pokeMatrix glUniformMatrix4fv---- GL ES 3.0+ supports transpose-pokeMatrixT :: Storable a-	=> (GLint -> GLsizei -> GLboolean -> Ptr GLfloat -> GL ())-	-> (GLint, GLsizei, Ptr ()) -> a -> GL ()-pokeMatrixT glUniformMatrixV (loc, 1, ptr) matrix = do-	poke (castPtr ptr :: Ptr a) matrix-	glUniformMatrixV loc 1 1 (castPtr ptr)-pokeMatrixT _ _ _ = return ()---- http://delphigl.de/glcapsviewer/gles_extensions.php -instance UnifVal Mat2x3 where glUniform = pokeMatrixT glUniformMatrix2x3fv-instance UnifVal Mat2x4 where glUniform = pokeMatrixT glUniformMatrix2x4fv-instance UnifVal Mat3x2 where glUniform = pokeMatrixT glUniformMatrix3x2fv-instance UnifVal Mat3x4 where glUniform = pokeMatrixT glUniformMatrix3x4fv-instance UnifVal Mat4x2 where glUniform = pokeMatrixT glUniformMatrix4x2fv-instance UnifVal Mat4x3 where glUniform = pokeMatrixT glUniformMatrix4x3fv---- 'transpose' argument must be GL_FALSE in GL ES 2.0-pokeMatrices :: (Transpose a b, Storable b)-	=> (GLint -> GLsizei -> GLboolean -> Ptr GLfloat -> GL ())-	-> (GLint, GLsizei, Ptr ()) -> [a] -> GL ()-pokeMatrices glUniformMatrixV (loc, len, ptr) matrices = do-	let len' = fromIntegral len-	pokeArray (castPtr ptr :: Ptr b)-		(map transpose $ take len' matrices) -- maybe slow-	glUniformMatrixV loc len 0 (castPtr ptr)--instance UnifVal [Mat2] where glUniform = pokeMatrices glUniformMatrix2fv-instance UnifVal [Mat3] where glUniform = pokeMatrices glUniformMatrix3fv-instance UnifVal [Mat4] where glUniform = pokeMatrices glUniformMatrix4fv+class UnifMat a where+	glUnifMat :: GLint -> GLsizei -> GLboolean -> Ptr a -> GL ()+castMat a b c d e = a b c d (castPtr e) --- GL ES 3.0+ supports transpose-pokeMatricesT :: Storable a-	=> (GLint -> GLsizei -> GLboolean -> Ptr GLfloat -> GL ())-	-> (GLint, GLsizei, Ptr ()) -> [a] -> GL ()-pokeMatricesT glUniformMatrixV (loc, len, ptr) matrices = do-	let len' = fromIntegral len-	pokeArray (castPtr ptr :: Ptr a) (take len' matrices)-	glUniformMatrixV loc len 1 (castPtr ptr)+instance UnifMat Mat2 where glUnifMat = castMat glUniformMatrix2fv+instance UnifMat Mat3 where glUnifMat = castMat glUniformMatrix3fv+instance UnifMat Mat4 where glUnifMat = castMat glUniformMatrix4fv+-- /GL_NV_non_square_matrices/ seems ignorable for now.+-- http://delphigl.de/glcapsviewer/gles_extensions.php+instance UnifMat Mat2x3 where glUnifMat = castMat glUniformMatrix2x3fv+instance UnifMat Mat2x4 where glUnifMat = castMat glUniformMatrix2x4fv+instance UnifMat Mat3x2 where glUnifMat = castMat glUniformMatrix3x2fv+instance UnifMat Mat3x4 where glUnifMat = castMat glUniformMatrix3x4fv+instance UnifMat Mat4x2 where glUnifMat = castMat glUniformMatrix4x2fv+instance UnifMat Mat4x3 where glUnifMat = castMat glUniformMatrix4x3fv -instance UnifVal [Mat2x3] where glUniform = pokeMatricesT glUniformMatrix2x3fv-instance UnifVal [Mat2x4] where glUniform = pokeMatricesT glUniformMatrix2x4fv-instance UnifVal [Mat3x2] where glUniform = pokeMatricesT glUniformMatrix3x2fv-instance UnifVal [Mat3x4] where glUniform = pokeMatricesT glUniformMatrix3x4fv-instance UnifVal [Mat4x2] where glUniform = pokeMatricesT glUniformMatrix4x2fv-instance UnifVal [Mat4x3] where glUniform = pokeMatricesT glUniformMatrix4x3fv+-- | Matrix __Not tested!!!__+instance (Distributive g, Functor f, UnifMat (f (g a)), Storable (g (f a))) =>+		UnifVal (f (g a)) where+		glUniform (loc, _, ptr) val = glUniform (loc, 1, ptr) [val]+-- | Array of matrix __Not tested!!!__+instance (Distributive g, Functor f, UnifMat (f (g a)), Storable (g (f a))) =>+		UnifVal [f (g a)] where+	-- 'transpose' argument must be GL_FALSE in GL ES 2.0.+	-- GL ES 3.0+ supports transpose.+	glUniform (loc, len, ptr) matrices = do+		pokeArray (castPtr ptr) $ map distribute $ take (fromIntegral len) matrices+		glUnifMat loc len 0 (castPtr ptr :: Ptr (f (g a)))  --- Array of attributes is not supported in GLSL ES+-- Arrays of attribute is not allowed in GLSL ES -instance GenericVertexAttribute a => ShaderAttribute a where-	glVertexAttrib idx x =-		with (V4 x 0 0 1) $ glVertexAttrib4v idx-instance GenericVertexAttribute a => ShaderAttribute (V2 a) where-	glVertexAttrib idx (V2 x y) =-		with (V4 x y 0 1) $ glVertexAttrib4v idx-instance GenericVertexAttribute a => ShaderAttribute (V3 a) where-	glVertexAttrib idx (V3 x y z) =-		with (V4 x y z 1) $ glVertexAttrib4v idx-instance GenericVertexAttribute a => ShaderAttribute (V4 a) where-	glVertexAttrib idx v4 =-		with v4 $ glVertexAttrib4v idx-instance ShaderAttribute Mat2 where-	glVertexAttrib idx (M2 (V2 a b) (V2 c d)) = do-		with (V4 a c 0 1) $ glVertexAttrib4v idx-		with (V4 b d 0 1) $ glVertexAttrib4v (idx + 1)-instance ShaderAttribute Mat3 where-	glVertexAttrib idx (M3 (V3 a b c) (V3 d e f) (V3 g h i)) = do-		with (V4 a d g 1) $ glVertexAttrib4v idx-		with (V4 b e h 1) $ glVertexAttrib4v (idx + 1)-		with (V4 c f i 1)  $ glVertexAttrib4v (idx + 2)-instance ShaderAttribute Mat4 where-	glVertexAttrib idx (M4 (V4 a b c d) (V4 e f g h) (V4 i j k l) (V4 m n o p)) = do-		with (V4 a e i m) $ glVertexAttrib4v idx-		with (V4 b f j n) $ glVertexAttrib4v (idx + 1)-		with (V4 c g k o) $ glVertexAttrib4v (idx + 2)-		with (V4 d h l p) $ glVertexAttrib4v (idx + 3)--- XXX I'm not sure below types are actually supported by the GL-instance ShaderAttribute Mat3x2 where-	glVertexAttrib idx (M3x2 a b  c d  e f) = do-		with (V4 a c e 1) $ glVertexAttrib4v idx-		with (V4 b d f 1) $ glVertexAttrib4v (idx + 1)-instance ShaderAttribute Mat4x2 where-	glVertexAttrib idx (M4x2 a b  c d  e f  g h) = do-		with (V4 a c e g) $ glVertexAttrib4v idx-		with (V4 b d f h) $ glVertexAttrib4v (idx + 1)-instance ShaderAttribute Mat2x3 where-	glVertexAttrib idx (M2x3 a b c  d e f) = do-		with (V4 a d 0 1) $ glVertexAttrib4v idx-		with (V4 b e 0 1) $ glVertexAttrib4v (idx + 1)-		with (V4 c f 0 1) $ glVertexAttrib4v (idx + 2)-instance ShaderAttribute Mat4x3 where-	glVertexAttrib idx (M4x3 a b c  d e f  g h i  j k l) = do-		with (V4 a d g j) $ glVertexAttrib4v idx-		with (V4 b e h k) $ glVertexAttrib4v (idx + 1)-		with (V4 c f i l) $ glVertexAttrib4v (idx + 2)-instance ShaderAttribute Mat2x4 where-	glVertexAttrib idx (M2x4 a b c d  e f g h) = do-		with (V4 a e 0 1) $ glVertexAttrib4v idx-		with (V4 b f 0 1) $ glVertexAttrib4v (idx + 1)-		with (V4 c g 0 1) $ glVertexAttrib4v (idx + 2)-		with (V4 d h 0 1) $ glVertexAttrib4v (idx + 3)-instance ShaderAttribute Mat3x4 where-	glVertexAttrib idx (M3x4 a b c d  e f g h  i j k l) = do-		with (V4 a e i 1) $ glVertexAttrib4v idx-		with (V4 b f j 1) $ glVertexAttrib4v (idx + 1)-		with (V4 c g k 1) $ glVertexAttrib4v (idx + 2)-		with (V4 d h l 1) $ glVertexAttrib4v (idx + 3)+instance VertexAttribute Float where+	glVertexAttrib ix x = glVertexAttrib1f ix x+instance VertexAttribute Vec2 where+	glVertexAttrib ix (V2 x y) = glVertexAttrib2f ix x y+instance VertexAttribute Vec3 where+	glVertexAttrib ix (V3 x y z) = glVertexAttrib3f ix x y z+instance VertexAttribute Vec4 where+	glVertexAttrib ix (V4 x y z w) = glVertexAttrib4f ix x y z w+instance VertexAttribute Int32 where+	glVertexAttrib ix x = glVertexAttribI4i ix x 0 0 1+instance VertexAttribute IVec2 where+	glVertexAttrib ix (V2 x y) = glVertexAttribI4i ix x y 0 1+instance VertexAttribute IVec3 where+	glVertexAttrib ix (V3 x y z) = glVertexAttribI4i ix x y z 1+instance VertexAttribute IVec4 where+	glVertexAttrib ix (V4 x y z w) = glVertexAttribI4i ix x y z w+instance VertexAttribute Word32 where+	glVertexAttrib ix x = glVertexAttribI4ui ix x 0 0 1+instance VertexAttribute UVec2 where+	glVertexAttrib ix (V2 x y) = glVertexAttribI4ui ix x y 0 1+instance VertexAttribute UVec3 where+	glVertexAttrib ix (V3 x y z) = glVertexAttribI4ui ix x y z 1+instance VertexAttribute UVec4 where+	glVertexAttrib ix (V4 x y z w) = glVertexAttribI4ui ix x y z w+instance VertexAttribute a => VertexAttribute (V1 a) where+	glVertexAttrib ix (V1 x) = glVertexAttrib ix x --- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!--- XXX Not completed, please add instances here---(GLuint indx, GLint size, GLenum type, GLboolean normalized, GLsizei stride, const GLvoid* ptr)-instance AttrStruct Float (Attrib p Float) p where-	glVertexAttribPtr (Attrib (idx, 1{-size-}, normalized, divisor)) buf = do-		glEnableVertexAttribArray idx-		when (divisor /= 0) $-			glVertexAttribDivisor idx divisor-		-- XXX 3.1 spec says normalize is ignored for floating-point types, really?-		glVertexAttribPointer idx 1 (glType buf) normalized 0 nullPtr-	glVertexAttribPtr attr buf = glLog $ "Ignoring attirb: " ++ show attr-instance AttrStruct Vec2 (Attrib p Vec2) p where-	glVertexAttribPtr (Attrib (idx, 1{-size-}, normalized, divisor)) buf = do-		glEnableVertexAttribArray idx-		when (divisor /= 0) $ glVertexAttribDivisor idx divisor-		glVertexAttribPointer idx 2 (glType ([] :: [Float])) normalized 0 nullPtr-	glVertexAttribPtr attr buf = glLog $ "Ignoring attirb: " ++ show attr-instance AttrStruct Vec3 (Attrib p Vec3) p where-	glVertexAttribPtr (Attrib (idx, 1{-size-}, normalized, divisor)) buf = do-		glEnableVertexAttribArray idx-		when (divisor /= 0) $ glVertexAttribDivisor idx divisor-		glVertexAttribPointer idx 3 (glType ([] :: [Float])) normalized 0 nullPtr-	glVertexAttribPtr attr buf = glLog $ "Ignoring attirb: " ++ show attr-instance AttrStruct Vec4 (Attrib p Vec4) p where-	glVertexAttribPtr (Attrib (idx, 1{-size-}, normalized, divisor)) buf = do-		glEnableVertexAttribArray idx-		when (divisor /= 0) $ glVertexAttribDivisor idx divisor-		glVertexAttribPointer idx 4 (glType ([] :: [Float])) normalized 0 nullPtr-	glVertexAttribPtr attr buf = glLog $ "Ignoring attirb: " ++ show attr-instance AttrStruct Word8 (Attrib p Float) p where-	glVertexAttribPtr (Attrib (idx, 1{-size-}, normalized, divisor)) buf = do-		glEnableVertexAttribArray idx-		when (divisor /= 0) $ glVertexAttribDivisor idx divisor-		glVertexAttribPointer idx 1 (glType ([] :: [Word8])) normalized 0 nullPtr-	glVertexAttribPtr attr buf = glLog $ "Ignoring attirb: " ++ show attr-instance AttrStruct (V2 Word8) (Attrib p Vec2) p where-	glVertexAttribPtr (Attrib (idx, 1{-size-}, normalized, divisor)) buf = do-		glEnableVertexAttribArray idx-		when (divisor /= 0) $ glVertexAttribDivisor idx divisor-		glVertexAttribPointer idx 2 (glType ([] :: [Word8])) normalized 4 nullPtr-	glVertexAttribPtr attr buf = glLog $ "Ignoring attirb: " ++ show attr-instance AttrStruct (V3 Word8) (Attrib p Vec3) p where-	glVertexAttribPtr (Attrib (idx, 1{-size-}, normalized, divisor)) buf = do-		glEnableVertexAttribArray idx-		when (divisor /= 0) $ glVertexAttribDivisor idx divisor-		glVertexAttribPointer idx 2 (glType ([] :: [Word8])) normalized 4 nullPtr-	glVertexAttribPtr attr buf = glLog $ "Ignoring attirb: " ++ show attr-instance AttrStruct (V4 Word8) (Attrib p Vec4) p where-	glVertexAttribPtr (Attrib (idx, 1{-size-}, normalized, divisor)) buf = do-		glEnableVertexAttribArray idx-		when (divisor /= 0) $ glVertexAttribDivisor idx divisor-		glVertexAttribPointer idx 2 (glType ([] :: [Word8])) normalized 0 nullPtr-	glVertexAttribPtr attr buf = glLog $ "Ignoring attirb: " ++ show attr+-- | Matrices __Not tested!!!__+instance (Functor f, VertexAttribute (f Float), FoldableWithIndex (E V4) g,+		Distributive g) => VertexAttribute (f (g Float)) where+	glVertexAttrib ix m = iforM_ (distribute m) $+		\(E i) v -> do+			let index = ix + (V4 0 1 2 3)^.i+			glDisableVertexAttribArray index+			glVertexAttrib index v -{--class (Storable a, Num a) => AttrElement a where+-- | The 3rd argument of glVertexAttribI?Pointer+class GLType a => AttrElement a where instance AttrElement Word8 instance AttrElement Word16 instance AttrElement Word32@@ -291,65 +260,91 @@ instance AttrElement Float instance AttrElement HalfFloat instance AttrElement FixedFloat+instance AttrElement Int2_10x3+instance AttrElement Word2_10x3 -case splitTyConApp values of-getrepl (con, args)-	| con == float = [(1, 4, flo)]-	| con == t2 = [(2, 2*size, typ)] where [(_,size,typ)] = getrepl $ head args-	| con == m2 = [(2, 2*size, typ), (2, 2*size, typ)] where [(_,size,typ)] = getrepl . head $ args-	| con == Int10x3_2 = [(4,4,Int10x3_2)]-	| otherwise = concatMap getrepl args-Float--> [(1, 4, flo)]-Vec2--> [(2, 8, flo)]-Mat2--> [(2, 8, flo), (2, 8, flo)]-((,) Word8 Word8)--> [(1, 4, word8), (1, 4, word8)]-((,) (M2 Float) (M2 Word8))--> [(2, 8, flo), (2, 8, flo), (2, 2, word8), (2, 2, word8)]-Int10x3_2--> [(4, 4, Int10x3_2)]-stride = sum $ map snd3 types-foldl (\offset (size, align, typ)-> glVertexAttribPointer ...>> return offset+align) 0 types-data = Spl | Mat-word8 = typeRep (Proxy :: Proxy Word8)-word16 = typeRep (Proxy :: Proxy Word16)-word32 = typeRep (Proxy :: Proxy Word32)-int8 = typeRep (Proxy :: Proxy Int8)-int16 = typeRep (Proxy :: Proxy Int16)-int32 = typeRep (Proxy :: Proxy Int32)-float = typeRep (Proxy :: Proxy Float)+-- | Temporarily gives a vector representation for type comparison+type family Vectorize a :: * where+	Vectorize Int2_10x3 = V4 Int2_10x3+	Vectorize Word2_10x3 = V4 Word2_10x3+	Vectorize (f Int2_10x3) = f (V4 Int2_10x3)+	Vectorize (f Word2_10x3) = f (V4 Word2_10x3)+	Vectorize (f a) = f a+	Vectorize a = V1 a+	-- Float -> (1, GL_GLOAT), Vec2 -> (2, GL_FLOAT) -class Storable a => AttrVal a where--- scalar-instance AttrElement a => AttrVal a--- vector-instance AttrElement a => AttrVal (V2 a)-instance AttrElement a => AttrVal (V3 a)-instance AttrElement a => AttrVal (V4 a)-instance AttrVal Int10x3_2-instance AttrVal Word10x3_2--- matrix-instance AttrElement a => AttrVal (M2 a)-instance AttrElement a => AttrVal (M3 a)-instance AttrElement a => AttrVal (M4 a)-instance AttrElement a => AttrVal (M2x3 a)-instance AttrElement a => AttrVal (M2x4 a)-instance AttrElement a => AttrVal (M3x2 a)-instance AttrElement a => AttrVal (M3x4 a)-instance AttrElement a => AttrVal (M4x2 a)-instance AttrElement a => AttrVal (M4x3 a)-{-- matrix (colomn major)-instance AttrVal (T2 Int10x3_2)-instance AttrVal (T3 Int10x3_2)-instance AttrVal (T4 Int10x3_2)-instance AttrVal (T2 Word10x3_2)-instance AttrVal (T3 Word10x3_2)-instance AttrVal (T4 Word10x3_2)--}+type family VDim v :: Nat where+	VDim V1 = 1+	VDim V2 = 2+	VDim V3 = 3+	VDim V4 = 4 +class VertexAttributeArray attr src where+	glVertexAttribPtr :: GLuint -> GLint -> GLenum -> GLboolean -> GLsizei -> Ptr (attr, src) -> GL ()++instance VertexAttributeArray Float a where+	glVertexAttribPtr i d t n s p = glVertexAttribPointer i d t n s (castPtr p)++-- | a = Int/Word32, b = Int/Word 8/16/32+instance (Integral a, Integral b) => VertexAttributeArray a b where+	glVertexAttribPtr i d t _ s p = glVertexAttribIPointer i d t s (castPtr p)++instance forall p a b v a' b'.+	( VertexAttribute a+	, Vectorize a ~ v a'+	, Vectorize b ~ v b'+	, KnownNat (VDim v)+	--, KnownNat (Aligned (SizeOf b))+	, AttrElement b'+	, VertexAttributeArray a' b' )+	=> AttrStruct (Attrib p a) p b where++	-- 'length' must be 1 (array of atrribute is not allowed.)+	-- 3.1 spec says 'normalize' is ignored for floating-point types+	-- such as GL_FIXED+	-- 'stride' == 0 means 'tightly packed'+	glVertexBuffer (Attrib (ix, length, normalize, divisor)) buf = do+		glEnableVertexAttribArray ix+		when (divisor /= 0) $ glVertexAttribDivisor ix divisor+		glVertexAttribPointer ix dim typ normalize stride nullPtr+		where dim = fromIntegral $ natVal (Proxy :: Proxy (VDim v))+		      typ = glType (Proxy :: Proxy b')+		      stride = 0 --fromIntegral $ natVal (Proxy :: Proxy (SizeOf b))++-- XXX (V4 Int2_10x3) (V3 Word2_10x3) cannot match here+instance+	( VertexAttribute (f (g Float))+	, Applicative g+	, FoldableWithIndex (E V4) g+	, KnownNat (VDim f)+	, KnownNat (SizeOf (f a))+	, KnownNat (SizeOf (f (g a))) -- (Aligned (SizeOf (f (g a))))+	, AttrElement a )+	=> AttrStruct (Attrib p (f (g Float))) p (f (g a)) where++	glVertexBuffer (Attrib (index, length, normalize, divisor)) buf = do+		iforM_ (pure () :: g ()) $ \(E e) _ -> do+			let i = (V4 0 1 2 3)^.e+			let ix = index + fromIntegral i+			glEnableVertexAttribArray ix+			when (divisor /= 0) $ glVertexAttribDivisor ix divisor+			glVertexAttribPointer ix dim typ normalize stride (plusPtr nullPtr (i * size))+		where dim = fromIntegral $ natVal (Proxy :: Proxy (VDim f))+		      typ = glType (Proxy :: Proxy a)+		      size = fromIntegral $ natVal (Proxy :: Proxy (SizeOf (f a)))+		      stride = fromIntegral $ natVal (Proxy :: Proxy (SizeOf (f (g a)))) -- (Aligned (SizeOf (f (g a))))+++-- XXX 4byte alignment+-- | Transpose matrices+class Storable a => GLStorable a where+	pokeArrayGL :: Ptr a -> [a] -> GL ()+instance (Storable (f (g a)), Storable (g (f a)), VertexAttribute (f (g Float)), Functor f, Distributive g)+	=> GLStorable (f (g a)) where+	pokeArrayGL ptr xs = pokeArray (castPtr ptr) (map distribute xs)+instance Storable a => GLStorable a where+	pokeArrayGL = pokeArray+ --class AttrStruct a where --	pokeAll :: Ptr () -> a -> IO () @@ -372,23 +367,4 @@ --instance (AttrVal a, AttrVal b, AttrVal c, AttrVal d, AttrVal e, AttrVal f, AttrVal g, AttrVal h) => AttrStruct (a, b, c, d, e, f, g, h) --instance (AttrVal a, AttrVal b, AttrVal c, AttrVal d, AttrVal e, AttrVal f, AttrVal g, AttrVal h, AttrVal i) => AttrStruct (a, b, c, d, e, f, g, h, i) --instance (AttrVal a, AttrVal b, AttrVal c, AttrVal d, AttrVal e, AttrVal f, AttrVal g, AttrVal h, AttrVal i, AttrVal j) => AttrStruct (a, b, c, d, e, f, g, h, i, j)----instance Storable FixedFloat where---	sizeOf _ = 4; alignment _ = 4; peek = undefined---	poke p (FixedFloat x) = poke (castPtr p) x----instance Storable Int10x3_2 where---	sizeOf _ = 4; alignment _ = 4; peek = undefined---	poke p (Int10x3_2 x) = poke (castPtr p) x----instance Storable Word10x3_2 where---	sizeOf _ = 4; alignment _ = 4; peek = undefined---	poke p (Word10x3_2 x) = poke (castPtr p) x----instance Storable HalfFloat where---	sizeOf _ = 2; alignment _ = 4; peek = undefined---	poke p (HalfFloat x) = poke (castPtr p) x--}--
Graphics/TextureContainer/KTX.hs view
@@ -66,7 +66,7 @@  	return $ ktx kvp imgs -+ktxFromFile :: FilePath -> IO Ktx ktxFromFile path = B.readFile path >>= return . readKtx path  readKtx :: FilePath -> B.ByteString -> Ktx
Graphics/TextureContainer/PKM.hs view
@@ -2,8 +2,6 @@ -- | Ericsson's ETC1\/ETC2\/EAC Texture Container Format module Graphics.TextureContainer.PKM where import Control.Applicative-import Control.Exception-import Control.Monad import qualified Data.ByteString as B import Data.Packer import Data.Word@@ -66,6 +64,7 @@ 		fromPkmType 12848 7 = undefined 		fromPkmType 12848 8 = undefined +fromPkmFile :: FilePath -> IO Pkm fromPkmFile path = B.readFile path >>= return . readPkm path  readPkm :: FilePath -> B.ByteString -> Pkm
+ Linear/Graphics.hs view
@@ -0,0 +1,68 @@+module Linear.Graphics where+import Linear.V2+import Linear.V3+import Linear.V4+import Linear.Matrix++ortho :: Fractional a+	=> (a, a) -- ^ (left, right)+	-> (a, a) -- ^ (bottom, top)+	-> (a, a) -- ^ (near, far)+	-> M44 a+ortho (l,r) (b,t) (n,f) =+	V4 (V4 (2/(r-l)) 0 0 0)+	   (V4 0 (2/(t-b)) 0 0)+	   (V4 0 0 (-2/(f-n)) 0)+	   (V4 (-(r+l)/(r-l)) (-(t+b)/(t-b)) (-(f+n)/(f-n)) 1)++-- | 'ortho' with a different parametrization.+ortho' :: Fractional a+	=> V3 a -- ^ (left, top, near)+	-> V3 a -- ^ (right, bottom, far)+	-> M44 a+ortho' (V3 l t n) (V3 r b f) = ortho (l,r) (b,t) (n,f)++-- | \"Perspective projecton\" matrix+frustum :: Fractional a+	=> (a, a) -- ^ (left, right)+	-> (a, a) -- ^ (bottom, top)+	-> (a, a) -- ^ (near, far)+	-> M44 a+frustum (l,r) (b,t) (n,f) =+	V4 (V4 (2*n/(r-l)) 0 0 0)+	   (V4 0 (2*n/(t-b)) 0 0)+	   (V4 ((r+l)/(r-l)) ((t+b)/(t-b)) (-(f+n)/(f-n)) (-1))+	   (V4 0 0 (-2*f*n/(f-n)) 0)++-- | 'frustum' with a different parametrization.+frustum' :: Fractional a+	=> V3 a -- ^ (left, top, near)+	-> V3 a -- ^ (right, bottom, far)+	-> M44 a+frustum' (V3 l t n) (V3 r b f) = frustum (l,r) (b,t) (n,f)++-- | Inverse of 'frustum'+frustumInv :: Fractional a+	=> (a, a) -- ^ (left, right)+	-> (a, a) -- ^ (bottom, top)+	-> (a, a) -- ^ (near, far)+	-> M44 a+frustumInv (l,r) (b,t) (n,f) =+	V4 (V4 (0.5*(r-l)/n) 0 0 0)+	   (V4 0 (0.5*(t-b)/n) 0 0)+	   (V4 0 0 0 (0.5*(n-f)/(f*n)))+	   (V4 (0.5*(r+l)/n) (0.5*(t+b)/n) (-1) (0.5*(f+n)/(f*n)))++-- sequence [($ cos (x/100)) | x <- [0..100]] (\x -> V3 0 x 0)+-- [V2 x $ sin (x/50) | x <- [0..100]]++circle2d :: (Ord a, Enum a, Floating a) => a -> [V2 a]+circle2d n | n > 1 = [V2 (cos t) (sin t) | t <- [0,2*pi/n..2*pi]]++rectangle :: Num a => a -> a -> a -> a -> [V2 a]+rectangle x y w h = [V2 x y, V2 (x+w) y, V2 (x+w) (y+h), V2 x (y+h)]++yEqual f from to = [V2 x (f x) | x <- [from..to]]++xEqual g from to = [V2 (g y) y | y <- [from..to]]+
+ examples/billboard.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE RecordWildCards, DeriveDataTypeable #-}+module Main where+import Control.Applicative+import Control.Monad+import Graphics.OpenGLES+import qualified Data.ByteString.Char8 as B+import qualified Graphics.UI.GLFW as GLFW+import Control.Concurrent++-- ghc examples/billboard.hs -lEGL -lGLESv2 -threaded && examples/billboard+main = do+	GLFW.init+	Just win <- GLFW.createWindow 600 480 "The Billboard" Nothing Nothing+	forkGL+		(GLFW.makeContextCurrent (Just win) >> return False)+		(GLFW.makeContextCurrent Nothing)+		(GLFW.swapBuffers win)+	forkIO $ mapM_ (putStrLn.("# "++)) =<< glLogContents+	future <- withGL $ mkBillboard >>= mkSomeObj+	let loop c = do+		withGL $ runAction $ draw <$> future+		endFrameGL+		putStrLn . show $ c+		GLFW.pollEvents+		closing <- GLFW.windowShouldClose win+		when (not closing) $ loop (c+1)+	loop 0++data Billboard = Billboard+	{ billboard :: Program Billboard+	, mvpMatrix :: Uniform Billboard Mat3+	, pos :: Attrib Billboard Vec2+	, uv :: Attrib Billboard Vec2+	} deriving Typeable++mkBillboard :: GL Billboard+mkBillboard = do+	Finished p <- glCompile NoFeedback+		[ vertexShader "bb.vs" vsSrc+		, fragmentShader "bb.fs" fsSrc ]+		$ \prog step msg bin ->+			putStrLn $ "> step " ++ show step ++ ", " ++ msg+	Billboard p <$> uniform "mvpMatrix"+		<*> attrib "pos" <*> attrib "uv"++vsSrc3 = B.pack $+	"#version 300 es\n\+	\ in mat4 ttt;in mat4 sss;\+	\ void main(){gl_Position = vec4(1) * ttt * sss;}"++fsSrc3 = B.pack $+	"#version 300 es\n\+	\precision mediump float;\+	\ out vec4 var;\+	\ void main(){var = vec4(1);}"++vsSrc = B.pack $+	"#version 100\n" +++	"uniform mat3 mvpMatrix;\n" +++	"attribute vec2 pos;\n" +++	"attribute vec2 uv;\n" +++	"uniform struct qqq { vec2 w[2]; };uniform struct aww { vec4 wew; vec3 www[3]; ivec2 oo[10]; qqq s[10];} ogg[20];uniform vec4 uuuuu[63];" +++	"varying vec4 vColor;\n" +++	"void main() {\n" +++	"    gl_Position = vec4(mvpMatrix*vec3(pos, -1.0), 1.0);\n" +++	"    vColor = vec4(uv, 0.5, 1.0)/*+uuuuu[10]+ogg[19].wew*/;\n" +++	"}\n"++fsSrc = B.pack $+	"#version 100\n" +++	"precision mediump float;\n" +++	"varying vec4 vColor;\n" +++	"void main() {\n" +++	"    gl_FragColor = vColor;\n" +++	"}\n"++data SomeObj = SomeObj+	{ prog :: Billboard+	, vao :: VertexArray Billboard+	, posBuf :: Buffer Vec2+	, uvBuf :: Buffer (V2 Word8)+	}++mkSomeObj :: Billboard -> GL SomeObj+mkSomeObj prog@Billboard{..} = do+	posBuf <- glLoad app2gl (posData,4::Int)+	uvBuf <- glLoad app2gl uvData+	vao <- glVA [ pos &= posBuf, uv &= uvBuf]+	return SomeObj {..}++posData = [V2 (-1) (-1), V2 1 (-1), V2 (-1) 1, V2 1 1]+uvData = [V2 0 0, V2 0 1, V2 1 0, V2 1 1]++draw :: SomeObj -> GL ()+draw SomeObj{..} = do+	let Billboard{..} = prog+	updateSomeObj posBuf uvBuf+	r <- glDraw triangleStrip billboard+		[ begin culling, cullFace hideBack]+		[ mvpMatrix $= eye3]+		vao $ takeFrom 0 4+	putStrLn . show $ r+updateSomeObj _ _ = return ()
+ examples/billboard2.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE RecordWildCards, DeriveDataTypeable #-}+module Main where+import Control.Applicative+import Control.Monad+import Graphics.OpenGLES+import qualified Data.ByteString.Char8 as B+import qualified Graphics.UI.GLFW as GLFW+import Control.Concurrent++-- ghc examples/billboard2.hs -lEGL -lGLESv2 -threaded && examples/billboard2+main = do+	GLFW.init+	Just win <- GLFW.createWindow 534 600 "The Billboard" Nothing Nothing+	GLFW.setFramebufferSizeCallback win $ Just (const framesize)+	forkGL+		(GLFW.makeContextCurrent (Just win) >> return False)+		(GLFW.makeContextCurrent Nothing)+		(GLFW.swapBuffers win)+	forkIO $ mapM_ (putStrLn.("# "++)) =<< glLogContents+	future <- withGL $ mkBillboard >>= mkSomeObj+	let loop c = do+		withGL $ runAction $ draw <$> future+		endFrameGL+		putStrLn . show $ c+		GLFW.pollEvents+		closing <- GLFW.windowShouldClose win+		when (not closing) $ loop (c+1)+	loop 0++data Billboard = Billboard+	{ billboard :: Program Billboard+	, mvpMatrix :: Uniform Billboard Mat4+	, tex :: Uniform Billboard Int32+	, pos :: Attrib Billboard Vec2+	, uv :: Attrib Billboard Vec2+	} deriving Typeable++mkBillboard :: GL Billboard+mkBillboard = do+	Finished p <- glCompile NoFeedback+		[ vertexShader "bb.vs" vsSrc+		, fragmentShader "bb.fs" fsSrc ]+		$ \prog step msg bin ->+			putStrLn $ "> step " ++ show step ++ ", " ++ msg+	Billboard p <$> uniform "mvpMatrix" <*> uniform "tex_unit"+		<*> attrib "pos" <*> attrib "uv"++vsSrc = B.pack $+	"#version 100\n" +++	"uniform mat4 mvpMatrix;\n" +++	"attribute vec2 pos;\n" +++	"attribute vec2 uv;\n" +++	"varying vec4 color;\n" +++	"varying vec2 tex_coord;\n" +++	"void main() {\n" +++	"    gl_Position = mvpMatrix*vec4(pos, 0.0, 1.0);\n" +++	"    color = vec4(1.0-uv.x, 1.0-uv.y, 1.0, 1.0);\n" +++	"    tex_coord = uv;\n" +++	"}\n"++fsSrc = B.pack $+	"#version 100\n" +++	"precision mediump float;\n" +++	"uniform sampler2D tex_unit;\n" +++	"varying vec4 color;\n" +++	"varying vec2 tex_coord;\n" +++	"void main() {\n" +++	"    gl_FragColor = color * texture2D(tex_unit, tex_coord);\n" +++	"}\n"++data SomeObj = SomeObj+	{ prog :: Billboard+	, vao :: VertexArray Billboard+	, posBuf :: Buffer Vec2+	, uvBuf :: Buffer (V2 Word8)+	, ixBuf :: Buffer Word8+	, tex0 :: Texture ()+	}++mkSomeObj :: Billboard -> GL SomeObj+mkSomeObj prog@Billboard{..} = do+	posBuf <- glLoad app2gl posData+	uvBuf <- glLoad app2gl uvData+	vao <- glVA [ pos &= posBuf, uv &= uvBuf]+	tex0 <- glLoadKtxFile "white_fox.ktx" -- replace with your favorite one+	setSampler tex0 (Sampler (tiledRepeat,tiledRepeat,Nothing) 16.0 (magLinear,minLinear))+	ixBuf <- glLoad app2gl [0,1,2, 3,2,1]+	return SomeObj {..}++posData = [V2 (-1) 1, V2 1 1, V2 (-1) (-1), V2 1 (-1)]+uvData = [V2 0 0, V2 1 0, V2 0 1, V2 1 1]++draw :: SomeObj -> GL ()+draw SomeObj{..} = do+	clear [] colorBuffer+	let Billboard{..} = prog+	r <- glDraw drawTriangles billboard+		[texSlot 0 tex0] --[ begin culling, cullFace hideBack]+		[ mvpMatrix $= eye4, tex $= 0 ]+		vao $ byIndex ixBuf 0 6+	putStrLn . show $ r
+ examples/glsl-sandbox-player.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE DeriveDataTypeable, RecordWildCards #-}+module Main where+import Control.Applicative+import Control.Concurrent+import Control.Monad+import qualified Data.ByteString.Char8 as B+import Data.Time.Clock+import Graphics.OpenGLES+import qualified Graphics.UI.GLFW as GLFW++-- ghc examples/glsl-sandbox-player.hs -lEGL -lGLESv2 -threaded && examples/glsl-sandbox-player < examples/glsl-17617.fs+main :: IO ()+main = do+	putStrLn "Usage: Paste any pixel shader from https://glsl.heroku.com/ and press Ctrl-D\n(In other words, read from stdin.)"+	shaderSource <- getContents+	putStrLn shaderSource+	isOk <- GLFW.init+	if not isOk then (fail "Initialization Failed!") else return ()+	(win, w, h) <- initFullscreen "GLSL Sandbox Player"+	--(win, w, h) <- initWindow 600 480 "Window Title"+	forkGL (GLFW.makeContextCurrent (Just win) >> return False)+		(GLFW.makeContextCurrent Nothing)+		(GLFW.swapBuffers win)+	--GLFW.swapInterval 1+	forkIO $ mapM_ (putStrLn.("# "++)) =<< glLogContents+	future <- withGL $ mkPlayer (B.pack shaderSource) >>= mkPlayerObj+	t0 <- getCurrentTime+	let loop c = do+		withGL $ runAction $ draw win t0 (realToFrac w) (realToFrac h) <$> future+		endFrameGL+		putStrLn . show $ c+		GLFW.pollEvents+		closing <- GLFW.windowShouldClose win+		when (not closing && c < 1000) $ loop (c+1)+	loop 0+	GLFW.destroyWindow win+	GLFW.terminate+	--(w, h) <- GLFW.getFramebufferSize win -- XXX returns smaller size++initWindow w h title = do+	GLFW.windowHint $ GLFW.WindowHint'Resizable True+	win <- GLFW.createWindow w h title Nothing Nothing+		>>= maybe (fail "Failed to create a Window") return+	return (win, w, h)++initFullscreen title = do+	Just monitor <- GLFW.getPrimaryMonitor+	Just (GLFW.VideoMode w h _ _ _ _) <- GLFW.getVideoMode monitor+	--(w, h) <- GLFW.getMonitorPhysicalSize monitor -- XXX returns (0,0)+	win <- GLFW.createWindow w h title (Just monitor) Nothing+	       >>= maybe (fail "Failed to create a Window") return+	return (win, w, h)++data Player = Player+	{ player :: Program Player+	, p_time :: Uniform Player Float+	, p_mouse :: Uniform Player Vec2+	, p_resolution :: Uniform Player Vec2+	, p_backbuffer :: Uniform Player Int32+	, p_surfaceSize :: Uniform Player Vec2+	, p_pos :: Attrib Player Vec2+	} deriving Typeable++mkPlayer :: B.ByteString -> GL Player+mkPlayer fsSrc = do+	Finished p <- glCompile NoFeedback+		[ vertexShader "glsl-sandbox.vs" vsSrc+		, fragmentShader "custom-fragment-shader" fsSrc ]+		$ \prog step msg bin ->+			putStrLn $ "> step " ++ show step ++ ", " ++ msg+	Player p <$> uniform "time" <*> uniform "mouse"+		<*> uniform "resolution" <*> uniform "backbuffer"+		<*> uniform "surfaceSize" <*> attrib "pos"++vsSrc = B.pack $+	"attribute vec2 pos;\n" +++	"varying vec2 surfacePosition;\n" +++	"void main() {\n" +++	"    surfacePosition = vec2(0, 0);\n" +++	"    gl_Position = vec4(pos, 0, 1);\n" +++	"}\n"++data PlayerObj = PlayerObj+	{ prog :: Player+	, vao :: VertexArray Player+	, posBuf :: Buffer Vec2+	}++mkPlayerObj :: Player -> GL PlayerObj+mkPlayerObj prog@Player{..} = do+	posBuf <- glLoad app2gl posData+	vao <- glVA [ p_pos &= posBuf ]+	return PlayerObj {..}++posData = [V2 (-1) 1, V2 1 1, V2 (-1) (-1), V2 1 (-1)]++draw :: GLFW.Window -> UTCTime -> Float -> Float -> PlayerObj -> GL ()+draw win t0 w h PlayerObj{..} = do+	clear [{-clearColor 0.2 0.2 0.3 1.0-}] colorBuffer+	t <- getCurrentTime+	let time = realToFrac $ diffUTCTime t t0+	(x, y) <- GLFW.getCursorPos win+	let Player{..} = prog+	result <- glDraw triangleStrip player+		[  ] --[ begin culling, cullFace hideBack]+		[ p_time $= time, p_mouse $= V2 (re x/w) (re y/h), p_resolution $= V2 w h, p_backbuffer $= 0, p_surfaceSize $= V2 w h ]+		vao $ takeFrom 0 4+	putStrLn . show $ result+	where re = realToFrac :: Double -> Float
opengles.cabal view
@@ -1,5 +1,5 @@ name:                opengles-version:             0.5.0+version:             0.6.0 synopsis:            OpenGL ES 2.0 and 3.0 with EGL 1.4 description:         A simplified OpenGL ES core wrapper library.                      The mission statement of this library is three F: Fun, Fast, yet Flexible.@@ -18,6 +18,9 @@   include/EGL/eglext.h   include/EGL/eglplatform.h   include/KHR/khrplatform.h+  examples/billboard.hs+  examples/billboard2.hs+  examples/glsl-sandbox-player.hs stability: experimental cabal-version:       >= 1.18 @@ -42,17 +45,20 @@     Graphics.OpenGLES.Texture,     Graphics.OpenGLES.Types,     Graphics.TextureContainer.KTX,-    Graphics.TextureContainer.PKM+    Graphics.TextureContainer.PKM,+    Linear.Graphics      other-extensions: ForeignFunctionInterface   extra-libraries: EGL, GLESv2   build-depends:     base >= 4.6 && < 5,-    bytestring >= 0.10 && < 1,-    ghc-prim,     array >= 0.5 && < 0.6,+    bytestring >= 0.10 && < 1,+    distributive >= 0.4 && < 0.5,     future-resource >= 0.3,-    linear-vect >= 0.1,+    ghc-prim,+    linear >= 1.10 && < 1.12,+    lens >= 4.4 && < 4.5,     packer >= 0.1 && < 0.2      include-dirs: include