aboutsummaryrefslogtreecommitdiff
path: root/Graphics
diff options
context:
space:
mode:
Diffstat (limited to 'Graphics')
-rw-r--r--Graphics/Glyph/ArrayGenerator.hs12
-rw-r--r--Graphics/Glyph/BufferBuilder.hs13
-rw-r--r--Graphics/Glyph/ExtendedGL/Base.hs34
-rw-r--r--Graphics/Glyph/ExtendedGL/Framebuffers.hs26
-rw-r--r--Graphics/Glyph/GeometryBuilder.hs44
-rw-r--r--Graphics/Glyph/GlyphObject.hs57
-rw-r--r--Graphics/Glyph/Mat4.hs12
-rw-r--r--Graphics/Glyph/ObjLoader.hs4
-rw-r--r--Graphics/Glyph/Textures.hs9
-rw-r--r--Graphics/Glyph/Util.hs11
-rw-r--r--Graphics/Rendering/HelpGL.hs1
-rw-r--r--Graphics/SDL/SDLHelp.hs93
12 files changed, 203 insertions, 113 deletions
diff --git a/Graphics/Glyph/ArrayGenerator.hs b/Graphics/Glyph/ArrayGenerator.hs
index 1e9e5a3..16fe41f 100644
--- a/Graphics/Glyph/ArrayGenerator.hs
+++ b/Graphics/Glyph/ArrayGenerator.hs
@@ -7,6 +7,18 @@ import Data.Array
import Data.Maybe
data ArrayTransaction ix val b = ArrayBuilderM_ (M.Map ix val) b
+
+instance (Ord ix) => Functor (ArrayTransaction ix a) where
+ fmap f bb = bb >>= (return . f)
+
+instance (Ord ix) => Applicative (ArrayTransaction ix a) where
+ (<*>) afn aa = do
+ fn <- afn
+ a <- aa
+ return (fn a)
+
+ pure = return
+
instance (Ord ix) => Monad (ArrayTransaction ix a) where
return = ArrayBuilderM_ M.empty
(ArrayBuilderM_ map1 val) >>= f =
diff --git a/Graphics/Glyph/BufferBuilder.hs b/Graphics/Glyph/BufferBuilder.hs
index 9dae0aa..b23f6ba 100644
--- a/Graphics/Glyph/BufferBuilder.hs
+++ b/Graphics/Glyph/BufferBuilder.hs
@@ -104,7 +104,17 @@ instance Show (CompiledBuild x) where
show (CompiledBuild stride enabled n ptr nbytes) =
"[CompiledBuild stride="++!stride++" enabled"++!enabled++" n="++!n++" ptr="++!ptr++" nbytes="++!nbytes++"]"
-instance (Num t) => Monad (BuilderM t) where
+instance Functor (BuilderM t) where
+ fmap f b = b >>= (return . f)
+
+instance Applicative (BuilderM t) where
+ pure = return
+ (<*>) afn aa = do
+ fn <- afn
+ a <- aa
+ return (fn a)
+
+instance Monad (BuilderM t) where
(BuilderM !builder1 _) >> (BuilderM !builder2 ret) =
BuilderM (builder1 ><> builder2) ret
where
@@ -118,7 +128,6 @@ instance (Num t) => Monad (BuilderM t) where
b1@(BuilderM _ ret) >>= func = b1 >> func ret
return = BuilderM (LeafBuilder Seq.empty)
- fail = undefined
instance Functor Builder where
fmap f (Builder b1 b2) = (Builder (fmap f b1) (fmap f b2))
diff --git a/Graphics/Glyph/ExtendedGL/Base.hs b/Graphics/Glyph/ExtendedGL/Base.hs
index 48f61a5..88566f4 100644
--- a/Graphics/Glyph/ExtendedGL/Base.hs
+++ b/Graphics/Glyph/ExtendedGL/Base.hs
@@ -5,8 +5,8 @@
module Graphics.Glyph.ExtendedGL.Base where
import qualified Graphics.Rendering.OpenGL as GL
-import Graphics.Rendering.OpenGL.Raw.Core31
-import Graphics.Rendering.OpenGL.Raw.ARB
+import Graphics.GL.Core43
+import Graphics.GL.Compatibility30
import Foreign.Marshal.Alloc
import Foreign.Ptr
@@ -18,6 +18,7 @@ import Control.Monad
import Data.StateVar
import Unsafe.Coerce
+import Data.Proxy
data ExPrimitiveMode = Points | Triangles | Lines | Patches deriving (Show,Enum)
@@ -40,8 +41,8 @@ class HasParamOfType b t a where
class IsPrimitiveModeMarshallable a where
marshalPrimitiveMode :: a -> GLuint
-castPrimitive :: forall a b t. (IsWrappedPrimitive t a, IsWrappedPrimitive t b) => a -> b
-castPrimitive x = wrap unw
+castPrimitive :: forall a b t. (IsWrappedPrimitive t a, IsWrappedPrimitive t b) => Proxy t -> a -> b
+castPrimitive _ x = wrap unw
where
unw :: t
unw = unwrap x
@@ -54,10 +55,10 @@ instance (IsWrappedPrimitive GLenum a) => IsGLEnumMarshallable a where
instance IsPrimitiveModeMarshallable ExPrimitiveMode where
marshalPrimitiveMode x = case x of
- Points -> gl_POINTS
- Triangles -> gl_TRIANGLES
- Lines -> gl_LINES
- Patches -> gl_PATCHES
+ Points -> GL_POINTS
+ Triangles -> GL_TRIANGLES
+ Lines -> GL_LINES
+ Patches -> GL_PATCHES
instance IsPrimitiveModeMarshallable GL.PrimitiveMode where
marshalPrimitiveMode x = case x of
@@ -75,13 +76,6 @@ instance IsPrimitiveModeMarshallable GL.PrimitiveMode where
instance IsPrimitiveModeMarshallable GLuint where
marshalPrimitiveMode = id
-drawArraysInstanced ::
- (IsPrimitiveModeMarshallable a) =>
- a -> GL.ArrayIndex ->
- GL.NumArrayIndices ->
- GLsizei -> IO ()
-drawArraysInstanced = glDrawArraysInstanced . marshalPrimitiveMode
-
vertexAttributeDivisor :: GL.AttribLocation -> SettableStateVar GLuint
vertexAttributeDivisor (GL.AttribLocation loc) =
makeSettableStateVar $ \val ->
@@ -92,15 +86,15 @@ vertexAttributeDivisor (GL.AttribLocation loc) =
patchVertices :: (Integral a) => SettableStateVar a
patchVertices =
makeSettableStateVar $ \val ->
- glPatchParameteri gl_PATCH_VERTICES $ fromIntegral val
+ glPatchParameteri GL_PATCH_VERTICES $ fromIntegral val
{- Returns the maximum number of patches
- for a tessilation shader -}
maxPatchVertices :: IO CInt
maxPatchVertices =
alloca $ \ptr -> do
- glGetIntegerv gl_MAX_PATCH_VERTICES ptr
- peek ptr
+ glGetIntegerv GL_MAX_PATCH_VERTICES ptr
+ fromIntegral <$> peek ptr
getGLVersion :: IO String
getGLVersion =
@@ -108,8 +102,8 @@ getGLVersion =
x <- a ; y <- b ; return (x,y)
in
alloca $ \ptr1 -> alloca $ \ptr2 -> do
- glGetIntegerv gl_MAJOR_VERSION ptr1
- glGetIntegerv gl_MINOR_VERSION ptr2
+ glGetIntegerv GL_MAJOR_VERSION ptr1
+ glGetIntegerv GL_MINOR_VERSION ptr2
(v1,v2) <- lift2 (peek ptr1, peek ptr2)
return ("OpenGL " ++ show v1 ++ "." ++ show v2)
diff --git a/Graphics/Glyph/ExtendedGL/Framebuffers.hs b/Graphics/Glyph/ExtendedGL/Framebuffers.hs
index abe9756..a6c2891 100644
--- a/Graphics/Glyph/ExtendedGL/Framebuffers.hs
+++ b/Graphics/Glyph/ExtendedGL/Framebuffers.hs
@@ -6,8 +6,8 @@
module Graphics.Glyph.ExtendedGL.Framebuffers where
-import Graphics.Rendering.OpenGL.Raw.ARB
-import Graphics.Rendering.OpenGL.Raw.Core31
+import Graphics.GL.Compatibility30
+import Graphics.GL.Core43
import qualified Graphics.Rendering.OpenGL as GL
import Graphics.Glyph.ExtendedGL.Base
@@ -46,12 +46,12 @@ instance IsGenerable Renderbuffer where
glGenRenderbuffers 1 ptr
liftM Renderbuffer $ peek ptr
instance IsBindable Renderbuffer where
- bind = glBindRenderbuffer gl_RENDERBUFFER . unwrap
+ bind = glBindRenderbuffer GL_RENDERBUFFER . unwrap
data RenderbufferArgument =
DepthAttachment
instance IsWrappedPrimitive GLenum RenderbufferArgument where
- unwrap DepthAttachment = gl_DEPTH_ATTACHMENT
+ unwrap DepthAttachment = GL_DEPTH_ATTACHMENT
renderBufferStorageRaw :: (IsGLEnumMarshallable a, IsGLEnumMarshallable b) => a -> b -> Int -> Int -> IO ()
renderBufferStorageRaw typ enum w h = glRenderbufferStorage (toGLEnum typ)
@@ -59,7 +59,7 @@ renderBufferStorageRaw typ enum w h = glRenderbufferStorage (toGLEnum typ)
renderBufferStorage :: (IsGLEnumMarshallable a) => Renderbuffer -> SettableStateVar (a,Int,Int)
renderBufferStorage buffer = makeSettableStateVar $ \(en,w,h) -> do
bind buffer
- renderBufferStorageRaw gl_RENDERBUFFER en w h
+ renderBufferStorageRaw GL_RENDERBUFFER en w h
frameBufferRenderBuffer :: forall a b. (IsFramebuffer a,IsGLEnumMarshallable b) => Renderbuffer -> b -> IO a
frameBufferRenderBuffer rb e = do
@@ -68,7 +68,7 @@ frameBufferRenderBuffer rb e = do
unw :: GLuint
unw = unwrap rb
bind rb
- glFramebufferRenderbuffer enum (toGLEnum e) gl_RENDERBUFFER (unwrap rb)
+ glFramebufferRenderbuffer enum (toGLEnum e) GL_RENDERBUFFER (unwrap rb)
return $ wrap unw
where
test :: a
@@ -79,14 +79,14 @@ data FramebufferParameter = DefaultWidth | DefaultHeight
instance IsWrappedPrimitive GLenum FramebufferParameter where
unwrap p = case p of
- DefaultWidth -> gl_FRAMEBUFFER_DEFAULT_WIDTH
- DefaultHeight -> gl_FRAMEBUFFER_DEFAULT_HEIGHT
- wrap x | x == gl_FRAMEBUFFER_DEFAULT_WIDTH = DefaultWidth
- | x == gl_FRAMEBUFFER_DEFAULT_HEIGHT = DefaultHeight
+ DefaultWidth -> GL_FRAMEBUFFER_DEFAULT_WIDTH
+ DefaultHeight -> GL_FRAMEBUFFER_DEFAULT_HEIGHT
+ wrap x | x == GL_FRAMEBUFFER_DEFAULT_WIDTH = DefaultWidth
+ | x == GL_FRAMEBUFFER_DEFAULT_HEIGHT = DefaultHeight
| otherwise = undefined
instance HasIntegerParam GLenum DrawFramebuffer where
- parami p fb = framebufferBasicParameteri gl_DRAW_FRAMEBUFFER fb p
+ parami p fb = framebufferBasicParameteri GL_DRAW_FRAMEBUFFER fb p
{- Has parameters of type GLuint which are acessable by the data FramebufferParameter for
- the type DrawFramebuffer -}
@@ -99,11 +99,11 @@ instance IsGenerable DrawFramebuffer where
liftM DrawFramebuffer $ peek ptr
instance IsBindable DrawFramebuffer where
- bind (DrawFramebuffer fb) = glBindFramebuffer gl_DRAW_FRAMEBUFFER fb
+ bind (DrawFramebuffer fb) = glBindFramebuffer GL_DRAW_FRAMEBUFFER fb
instance IsWrappedPrimitive GLuint DrawFramebuffer where
unwrap (DrawFramebuffer fb) = fb
wrap = DrawFramebuffer
instance IsFramebuffer DrawFramebuffer where
- getType _ = gl_DRAW_FRAMEBUFFER
+ getType _ = GL_DRAW_FRAMEBUFFER
diff --git a/Graphics/Glyph/GeometryBuilder.hs b/Graphics/Glyph/GeometryBuilder.hs
index 31be715..53c6681 100644
--- a/Graphics/Glyph/GeometryBuilder.hs
+++ b/Graphics/Glyph/GeometryBuilder.hs
@@ -3,7 +3,6 @@
module Graphics.Glyph.GeometryBuilder where
import Data.Sequence as Seq
-import Data.Setters
import Data.Maybe
import Graphics.Glyph.Util
@@ -95,10 +94,8 @@ data GeometryBuilder a = GeometryBuilder {
gRet :: a
}
-$(declareSetters ''GeometryBuilder)
-
generating :: OutType -> GeometryBuilder () -> GeometryBuilder ()
-generating TriangleStrip builder = setGOutType (Just TriangleStrip) $ builder
+generating TriangleStrip builder = builder { gOutType = Just TriangleStrip }
generating Triangles builder = do
let (nSeq,_) =
Fold.foldl' (\(tSeq,cnt) datum ->
@@ -109,45 +106,57 @@ generating Triangles builder = do
_ -> (tSeq |> datum,cnt)
) (Seq.empty, 0) (gList builder)
- setGOutType (Just Triangles) $
- setGList nSeq builder
+ builder {
+ gOutType = Just Triangles,
+ gList = nSeq
+ }
projectionMatrixUniform :: String -> GeometryBuilder ()
-projectionMatrixUniform str = setPjMatrixUniform (Just str) $ return ()
+projectionMatrixUniform str = (return ()) { pjMatrixUniform = (Just str) }
modelViewMatrixUniform :: String -> GeometryBuilder ()
-modelViewMatrixUniform str = setMvMatrixUniform (Just str) $ return ()
+modelViewMatrixUniform str = (return ()) { mvMatrixUniform = (Just str) }
maxVerticies :: Int -> GeometryBuilder ()
-maxVerticies i = setMaxVerts (Just i) $ return ()
+maxVerticies i = (return ()) { maxVerts = (Just i) }
textureOutput :: String -> GeometryBuilder ()
-textureOutput str = setTextureOut (Just str) $ return ()
+textureOutput str = (return ()) { textureOut = (Just str) }
normalOutput :: String -> GeometryBuilder ()
-normalOutput str = setNormalOut (Just str) $ return ()
+normalOutput str = (return ()) { normalOut = (Just str) }
positionOutput :: String -> GeometryBuilder ()
-positionOutput str = setPositionOut (Just str) $ return ()
+positionOutput str = (return ()) { positionOut = (Just str) }
gVertex4 :: Float -> Float -> Float -> Float -> GeometryBuilder ()
-gVertex4 x y z w = setGList (Seq.singleton $ Vertex x y z w) $ return ()
+gVertex4 x y z w = (return ()) { gList = Seq.singleton $ Vertex x y z w }
gNormal3 :: Float -> Float -> Float -> GeometryBuilder ()
-gNormal3 x y z = setGList (Seq.singleton $ Normal x y z) $ return ()
+gNormal3 x y z = (return ()) { gList = (Seq.singleton $ Normal x y z) }
gTexture2 :: Float -> Float -> GeometryBuilder ()
-gTexture2 x y = setGList (Seq.singleton $ Texture x y) $ return ()
+gTexture2 x y = (return ()) { gList = (Seq.singleton $ Texture x y) }
gEmitVertex :: GeometryBuilder ()
-gEmitVertex = setGList (Seq.singleton $ EmitVertex) $ return ()
+gEmitVertex = (return ()) { gList = (Seq.singleton $ EmitVertex) }
gEndPrimitive :: GeometryBuilder ()
-gEndPrimitive = setGList (Seq.singleton $ EndPrimitive) $ return ()
+gEndPrimitive = (return ()) { gList = Seq.singleton $ EndPrimitive }
gVertex4E :: Float -> Float -> Float -> Float -> GeometryBuilder ()
gVertex4E x y z w = gVertex4 x y z w >> gEmitVertex
+instance Functor GeometryBuilder where
+ fmap f bb = bb >>= (return . f)
+
+instance Applicative GeometryBuilder where
+ (<*>) afn aa = do
+ fn <- afn
+ a <- aa
+ return (fn a)
+
+ pure = return
instance Monad GeometryBuilder where
aB >> bB = GeometryBuilder
@@ -171,7 +180,6 @@ instance Monad GeometryBuilder where
Nothing
Nothing
Nothing
- fail = error
instance IsModelBuilder Float GeometryBuilder where
diff --git a/Graphics/Glyph/GlyphObject.hs b/Graphics/Glyph/GlyphObject.hs
index 29d25bb..db7b47c 100644
--- a/Graphics/Glyph/GlyphObject.hs
+++ b/Graphics/Glyph/GlyphObject.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE TemplateHaskell #-}
-
module Graphics.Glyph.GlyphObject (
GlyphObject,
getBufferObject,
@@ -32,9 +30,8 @@ module Graphics.Glyph.GlyphObject (
import Graphics.Glyph.BufferBuilder
import Graphics.Glyph.Util
-import Graphics.Rendering.OpenGL
+import Graphics.Rendering.OpenGL as GL
import Graphics.Glyph.ExtendedGL as Ex
-import Data.Setters
import Control.Monad
import Control.Applicative
@@ -59,7 +56,6 @@ data GlyphObject a = GlyphObject {
numInstances :: Int
}
-$(declareSetters ''GlyphObject)
getBufferObject :: GlyphObject a -> BufferObject
getBufferObject = bufferObject
@@ -90,6 +86,43 @@ getTeardownRoutine = teardownRoutine
getPrimitiveMode :: GlyphObject a -> ExPrimitiveMode
getPrimitiveMode = primitiveMode
+setBufferObject :: GlyphObject a -> BufferObject -> GlyphObject a
+setBufferObject o a = o {bufferObject = a}
+
+setCompiledData :: GlyphObject a -> (CompiledBuild GLfloat) -> GlyphObject a
+setCompiledData o a = o {compiledData = a}
+
+setVertexAttribute :: GlyphObject a -> AttribLocation -> GlyphObject a
+setVertexAttribute o a = o {vertexAttribute = a}
+
+setNormalAttribute :: GlyphObject a -> (Maybe AttribLocation) -> GlyphObject a
+setNormalAttribute o a = o {normalAttribute = a}
+
+setColorAttribute :: GlyphObject a -> (Maybe AttribLocation) -> GlyphObject a
+setColorAttribute o a = o {colorAttribute = a}
+
+setTextureAttribute :: GlyphObject a -> (Maybe AttribLocation) -> GlyphObject a
+setTextureAttribute o a = o {textureAttribute = a}
+
+setResources :: GlyphObject a -> a -> GlyphObject a
+setResources o a = o {resources = a}
+
+setSetupRoutine :: GlyphObject a -> (Maybe (GlyphObject a -> IO ())) -> GlyphObject a
+setSetupRoutine o a = o {setupRoutine = a}
+
+setSetupRoutine2 :: GlyphObject a -> (Maybe (GlyphObject a -> IO ())) -> GlyphObject a
+setSetupRoutine2 o a = o {setupRoutine2 = a}
+
+setTeardownRoutine :: GlyphObject a -> (Maybe (GlyphObject a -> IO ())) -> GlyphObject a
+setTeardownRoutine o a = o {teardownRoutine = a}
+
+setPrimitiveMode :: GlyphObject a -> ExPrimitiveMode -> GlyphObject a
+setPrimitiveMode o a = o {primitiveMode = a}
+
+setNumInstances :: GlyphObject a -> Int -> GlyphObject a
+setNumInstances o a = o {numInstances = a}
+
+
newGlyphObject :: BuilderM GLfloat x ->
AttribLocation ->
Maybe AttribLocation ->
@@ -107,13 +140,13 @@ newGlyphObject builder vertAttr normAttr colorAttr textureAttr res setup tear mo
return $ GlyphObject buffer compiled vertAttr normAttr colorAttr textureAttr res setup Nothing tear mode 1
prepare :: GlyphObject a -> (GlyphObject a -> IO()) -> GlyphObject a
-prepare a b = setSetupRoutine2 (Just b) a
+prepare a b = setSetupRoutine2 a (Just b)
startClosure :: GlyphObject a -> (GlyphObject a -> IO()) -> GlyphObject a
-startClosure a b = setSetupRoutine (Just b) a
+startClosure a b = setSetupRoutine a (Just b)
teardown :: GlyphObject a -> (GlyphObject a -> IO()) -> GlyphObject a
-teardown a b = setTeardownRoutine (Just b) a
+teardown a b = setTeardownRoutine a (Just b)
instance Drawable (GlyphObject a) where
draw = drawInstances <..> numInstances
@@ -139,7 +172,13 @@ drawInstances n obj@(GlyphObject bo co vAttr nAttr cAttr tAttr _ setup1 setup2 t
vertexAttribPointer attr $= (ToFloat, ad)
vertexAttribArray attr $= Enabled
- drawArraysInstanced p 0 (bufferLength co) $ fromIntegral n
+ let p' = case p of
+ Ex.Points -> GL.Points
+ Ex.Lines -> GL.Lines
+ Ex.Triangles -> GL.Triangles
+ Ex.Patches -> GL.Patches
+
+ drawArraysInstanced p' 0 (bufferLength co) $ fromIntegral n
forM_ enabled $ \(attr, _) -> do
vertexAttribArray attr $= Disabled
diff --git a/Graphics/Glyph/Mat4.hs b/Graphics/Glyph/Mat4.hs
index c1ae485..7d54b05 100644
--- a/Graphics/Glyph/Mat4.hs
+++ b/Graphics/Glyph/Mat4.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts #-}
module Graphics.Glyph.Mat4 where
import Control.Monad
@@ -9,8 +9,9 @@ import Foreign.Ptr
import Foreign.Storable
import Graphics.Rendering.OpenGL (Uniform(..),uniform,UniformLocation(..),makeStateVar)
-import Graphics.Rendering.OpenGL.Raw.Core31
+import Graphics.GL.Core43
+{- ORMOLU_DISABLE -};
data Mat4 a = Matrix4 (a,a,a,a,
a,a,a,a,
a,a,a,a,
@@ -19,6 +20,7 @@ data Mat4 a = Matrix4 (a,a,a,a,
data Mat3 a = Matrix3 ( a,a,a,
a,a,a,
a,a,a ) | IdentityMatrix3
+{- ORMOLU_ENABLE -};
class StorableMatrix t a where
fromList :: [t] -> a t
@@ -85,7 +87,7 @@ instance (Storable t) => StorableMatrix t Mat3 where
instance Uniform (Mat4 GLfloat) where
uniform (UniformLocation loc) = makeStateVar getter setter
where setter mat = toPtr mat $ \ptr ->
- glUniformMatrix4fv loc 1 (fromIntegral gl_FALSE) ptr
+ glUniformMatrix4fv loc 1 (fromIntegral GL_FALSE) ptr
getter :: IO (Mat4 GLfloat)
getter = do
pid <- liftM fromIntegral getCurrentProgram
@@ -97,7 +99,7 @@ instance Uniform (Mat4 GLfloat) where
instance Uniform (Mat3 GLfloat) where
uniform (UniformLocation loc) = makeStateVar getter setter
where setter mat = toPtr mat $ \ptr ->
- glUniformMatrix3fv loc 1 (fromIntegral gl_FALSE) ptr
+ glUniformMatrix3fv loc 1 (fromIntegral GL_FALSE) ptr
getter :: IO (Mat3 GLfloat)
getter = do
pid <- liftM fromIntegral getCurrentProgram
@@ -107,7 +109,7 @@ instance Uniform (Mat3 GLfloat) where
uniformv _ = undefined
getCurrentProgram :: IO GLint
-getCurrentProgram = alloca $ glGetIntegerv gl_CURRENT_PROGRAM >> peek
+getCurrentProgram = alloca $ \ptr -> glGetIntegerv GL_CURRENT_PROGRAM ptr >> peek ptr
instance (Show a) => Show (Mat4 a) where
show IdentityMatrix =
diff --git a/Graphics/Glyph/ObjLoader.hs b/Graphics/Glyph/ObjLoader.hs
index 78f010a..b392a26 100644
--- a/Graphics/Glyph/ObjLoader.hs
+++ b/Graphics/Glyph/ObjLoader.hs
@@ -4,9 +4,9 @@ import Graphics.Glyph.BufferBuilder
import Graphics.Glyph.Util
import Debug.Trace
+import Data.List.Split
import Control.Monad
import Data.Either
-import Data.String.Utils
import Data.Array
import System.IO
import qualified Data.Map as M
@@ -82,7 +82,7 @@ loadObjFromBytestring _contents =
"" -> -1
_ -> read str in
- let s2t s = case split "/" s of
+ let s2t s = case splitOn "/" s of
[a,b,c] -> Just (mapT3 mys2n (a,b,c))
[a,b] -> Just (mapT3 mys2n (a,b,""))
[a] -> Just (mapT3 mys2n (a,"",""))
diff --git a/Graphics/Glyph/Textures.hs b/Graphics/Glyph/Textures.hs
index 7e86d2a..ec3e12f 100644
--- a/Graphics/Glyph/Textures.hs
+++ b/Graphics/Glyph/Textures.hs
@@ -1,11 +1,10 @@
module Graphics.Glyph.Textures where
+import Control.Monad
import Data.Array.Storable
import Data.Word
-
-import Graphics.Rendering.OpenGL.Raw.Core31
+import Graphics.GL.Compatibility30
import Graphics.Rendering.OpenGL
-import Control.Monad
data Pixels =
PixelsRGB (Int,Int) (StorableArray Int Word8) |
@@ -32,8 +31,8 @@ attachPixelsToTexture pixels tex =
withStorableArray (pixelsArray pixels) $ \ptr -> do
textureBinding Texture2D $= Just tex
case pixels of
- PixelsRGB (w,h) _ -> glTexImage2D gl_TEXTURE_2D 0 3 (f w) (f h) 0 gl_RGB gl_UNSIGNED_BYTE ptr
- PixelsRGBA (w,h) _ -> glTexImage2D gl_TEXTURE_2D 0 4 (f w) (f h) 0 gl_RGBA gl_UNSIGNED_BYTE ptr
+ PixelsRGB (w,h) _ -> glTexImage2D GL_TEXTURE_2D 0 3 (f w) (f h) 0 GL_RGB GL_UNSIGNED_BYTE ptr
+ PixelsRGBA (w,h) _ -> glTexImage2D GL_TEXTURE_2D 0 4 (f w) (f h) 0 GL_RGBA GL_UNSIGNED_BYTE ptr
where f = fromIntegral
diff --git a/Graphics/Glyph/Util.hs b/Graphics/Glyph/Util.hs
index e8a5974..1c1269d 100644
--- a/Graphics/Glyph/Util.hs
+++ b/Graphics/Glyph/Util.hs
@@ -286,11 +286,20 @@ plusM a = MonadPlusBuilder a ()
runMonadPlusBuilder :: MonadPlusBuilder a b -> a
runMonadPlusBuilder (MonadPlusBuilder !a _) = a
+instance (MonadPlus a) => Functor (MonadPlusBuilder (a b)) where
+ fmap f b = b >>= return . f
+
+instance (MonadPlus a) => Applicative (MonadPlusBuilder (a b)) where
+ (<*>) afn aa = do
+ fn <- afn
+ fn <$> aa
+
+ pure = return
+
instance (MonadPlus a) => Monad (MonadPlusBuilder (a b)) where
return = MonadPlusBuilder mzero
MonadPlusBuilder a1 _ >> MonadPlusBuilder a2 b = MonadPlusBuilder (a1 `mplus` a2) b
builder@(MonadPlusBuilder _ b) >>= f = builder >> f b
- fail = undefined
untilM2 :: (Monad m) => (a -> m Bool) -> a -> (a -> m a) -> m a
untilM2 cond ini bod = do
diff --git a/Graphics/Rendering/HelpGL.hs b/Graphics/Rendering/HelpGL.hs
index 3ea66eb..938147e 100644
--- a/Graphics/Rendering/HelpGL.hs
+++ b/Graphics/Rendering/HelpGL.hs
@@ -3,7 +3,6 @@ module Graphics.Rendering.HelpGL
where
import Graphics.Rendering.OpenGL as GL
-import Graphics.Rendering.OpenGL.Raw.Core31
import Foreign.Ptr
import Foreign.Marshal.Array
diff --git a/Graphics/SDL/SDLHelp.hs b/Graphics/SDL/SDLHelp.hs
index 75806b2..62bb640 100644
--- a/Graphics/SDL/SDLHelp.hs
+++ b/Graphics/SDL/SDLHelp.hs
@@ -1,13 +1,15 @@
+{-# LANGUAGE OverloadedStrings, LambdaCase, ViewPatterns, RankNTypes #-}
module Graphics.SDL.SDLHelp where
-import Graphics.UI.SDL.Image as SDLImg
-import Graphics.UI.SDL as SDL
import Data.Word
import Control.Monad
import Graphics.Glyph.Util
+import SDL as SDL
+import SDL.Video.Renderer (SurfacePixelFormat(..))
+
+import Graphics.GL.Compatibility30
import Graphics.Rendering.OpenGL as GL
-import Graphics.Rendering.OpenGL.Raw.Core31
import Foreign.Storable
import Foreign.Ptr
@@ -28,22 +30,21 @@ data TextureData3D = TextureData3D {
bindSurfaceToTexture :: SDL.Surface -> TextureObject -> IO TextureData
bindSurfaceToTexture surf to = do
- textureBinding Texture2D $= Just to
- bbp <- liftM fromIntegral (pixelFormatGetBytesPerPixel $ surfaceGetPixelFormat surf)
- putStrLn $ "bpp: " ++! bbp
- ptr <- surfaceGetPixels surf
- glTexImage2D gl_TEXTURE_2D 0 bbp (w surf) (h surf) 0 (if bbp == 3 then gl_RGB else gl_RGBA) gl_UNSIGNED_BYTE ptr
- return $ TextureData (w surf, h surf) to
- where
- w :: (Integral a) => SDL.Surface -> a
- w = fromIntegral . surfaceGetWidth
- h :: (Integral a) => SDL.Surface -> a
- h = fromIntegral . surfaceGetHeight
+ textureBinding Texture2D $= Just to
+ bbp <- return 4 -- liftM fromIntegral (pixelFormatGetBytesPerPixel $ SDL.surfacePixels surf)
+ ptr <- SDL.surfacePixels surf
+ (V2 w h) <- SDL.surfaceDimensions surf
+
+ glTexImage2D GL_TEXTURE_2D 0 bbp (fi w) (fi h) 0 (if bbp == 3 then GL_RGB else GL_RGBA) GL_UNSIGNED_BYTE ptr
+ return $ TextureData (fi w, fi h) to
+ where
+ fi :: (Integral a, Integral b) => a -> b
+ fi = fromIntegral
textureFromPointer3D :: Ptr Word8 -> (Int,Int,Int) -> TextureObject -> IO TextureData3D
textureFromPointer3D ptr (w,h,d) to = do
textureBinding Texture3D $= Just to
- glTexImage3D gl_TEXTURE_3D 0 3 (f w) (f h) (f d) 0 gl_RGB gl_UNSIGNED_BYTE ptr
+ glTexImage3D GL_TEXTURE_3D 0 3 (f w) (f h) (f d) 0 GL_RGB GL_UNSIGNED_BYTE ptr
return $ TextureData3D (w,h,d) to
where f = fromIntegral
@@ -66,9 +67,10 @@ makeTexture = do
getPixel :: Int -> Int -> SDL.Surface -> IO Word32
getPixel x y surf = do
- bpp <- liftM fromIntegral (pixelFormatGetBytesPerPixel $ surfaceGetPixelFormat surf)
- ptr <- (surfaceGetPixels surf >>= return.castPtr) :: IO (Ptr Word8)
- let newPtr = ptr `plusPtr` (y * (fromIntegral $ surfaceGetPitch surf)) `plusPtr` (x * bpp)
+ bpp <- return 3 -- liftM fromIntegral (pixelFormatGetBytesPerPixel $ surfaceGetPixelFormat surf)
+ ptr <- (surfacePixels surf >>= return.castPtr) :: IO (Ptr Word8)
+ (V2 w h) <- SDL.surfaceDimensions surf
+ let newPtr = ptr `plusPtr` (y * bpp * fromIntegral w) `plusPtr` (x * bpp)
ret <- case bpp of
-- bytes = R G B A
@@ -105,37 +107,54 @@ wordToPixel word =
getRGBA :: SDL.Surface -> Int -> Int -> IO (Color4 Word8)
getRGBA surf x y = liftM wordToPixel $ getPixel x y surf
-simpleStartup :: String -> (Int,Int) -> IO Surface
+simpleStartup :: String -> (Int,Int) -> IO SDL.Window
simpleStartup name' (w,h) = do
- SDL.init [SDL.InitEverything]
- SDL.setVideoMode w h 32 [SDL.OpenGL, SDL.Resizable, SDL.DoubleBuf]
- SDL.setCaption name' name'
- SDL.getVideoSurface
+ SDL.initialize [SDL.InitVideo]
+ SDL.HintRenderScaleQuality $= SDL.ScaleLinear
+ renderQuality <- SDL.get SDL.HintRenderScaleQuality
+ when (renderQuality /= SDL.ScaleLinear) $
+ putStrLn "Warning: Linear texture filtering not enabled!"
+
+ window <-
+ SDL.createWindow
+ "SDL / OpenGL Example"
+ SDL.defaultWindow
+ { SDL.windowInitialSize = V2 1920 1080,
+ SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL
+ }
+ SDL.showWindow window
+
+ _ <- SDL.glCreateContext window
+ return window
defaultReshape :: Int -> Int -> a -> IO a
defaultReshape w h ret = do
let size = Size (fromIntegral w) (fromIntegral h)
viewport $=(Position 0 0, size)
- _ <- SDL.setVideoMode w h 32 [SDL.OpenGL, SDL.Resizable, SDL.DoubleBuf]
+ -- _ <- SDL.setVideoMode w h 32 [SDL.OpenGL, SDL.Resizable, SDL.DoubleBuf]
return ret
-startPipeline :: (Int -> Int -> a -> IO a) -> (Event -> a -> IO a) -> (a -> IO a) -> (a -> IO a) -> a -> IO ()
+startPipeline :: forall a. (Int -> Int -> a -> IO a) -> (SDL.EventPayload -> a -> IO a) -> (a -> IO a) -> (a -> IO a) -> a -> IO ()
startPipeline reshapeH eventH displayH updateH ini = do
+
let pumpEvents' res = do
- ev <- SDL.pollEvent
- case ev of
- Quit -> do
- putStrLn "Exit event."
- exitSuccess
- SDL.NoEvent -> return res
- VideoResize w h -> reshapeH w h res >>= pumpEvents'
- _ -> eventH ev res >>= pumpEvents'
- let runPipeline val = do
+ evs <- SDL.pollEvents
+ foldM (\res (SDL.eventPayload -> ev) -> case ev of
+ SDL.QuitEvent -> exitSuccess >> return res
+ _ -> eventH ev res) res evs
+ -- case ev of
+ -- Quit -> do
+ -- putStrLn "Exit event."
+ -- exitSuccess
+ -- SDL.NoEvent -> return res
+ -- VideoResize w h -> reshapeH w h res >>= pumpEvents'
+ -- _ -> eventH ev res >>= pumpEvents'
+ runPipeline val = do
res <- pumpEvents' val >>= displayH
- SDL.glSwapBuffers `seq` (updateH res) >>= runPipeline
+ updateH res >>= runPipeline
- -- TODO unhardcode this
- reshapeH 640 480 ini >>= runPipeline
+ -- -- TODO unhardcode this
+ reshapeH 1920 1080 ini >>= runPipeline
setupTexturing :: TextureData -> UniformLocation -> Int -> IO ()
setupTexturing (TextureData _ to) tu unit = do
generated by cgit (git 2.34.1) at 2025-07-17 02:49:37 +0000