diff --git a/ibis.cabal b/ibis.cabal index 9ea0f84..45b3cff 100644 --- a/ibis.cabal +++ b/ibis.cabal @@ -20,6 +20,7 @@ executable ibis other-modules: Events , Util , Types + , Draw -- other-extensions: default-extensions: OverloadedStrings build-depends: base >=4.11 @@ -30,9 +31,11 @@ executable ibis , linear , monad-loops , OpenGL + , GLUtil , text , magic , split , time + , bytestring hs-source-dirs: src default-language: Haskell2010 diff --git a/shell.nix b/shell.nix index 40feffb..07afc4e 100644 --- a/shell.nix +++ b/shell.nix @@ -28,8 +28,8 @@ let inherit (nixpkgs) pkgs; - f = { mkDerivation, base, containers, linear, magic, monad-loops, - optparse-applicative, OpenGL, poppler, split, stdenv, text, time + f = { mkDerivation, base, bytestring, containers, linear, magic, monad-loops, + optparse-applicative, OpenGL, GLUtil, poppler, split, stdenv, text, time }: mkDerivation { pname = "ibis"; @@ -37,8 +37,10 @@ let src = ./.; isLibrary = false; isExecutable = true; - executableHaskellDepends = [ base containers linear sdl2 magic - monad-loops OpenGL optparse-applicative poppler split text time ]; + executableHaskellDepends = [ base bytestring containers linear sdl2 magic + monad-loops OpenGL GLUtil optparse-applicative poppler split text + time + ]; description = "A pdf presenter"; license = stdenv.lib.licenses.gpl3; }; diff --git a/src/.Draw.hs.swp b/src/.Draw.hs.swp new file mode 100644 index 0000000..30c95fe Binary files /dev/null and b/src/.Draw.hs.swp differ diff --git a/src/.Main.hs.swp b/src/.Main.hs.swp new file mode 100644 index 0000000..a9c7c1a Binary files /dev/null and b/src/.Main.hs.swp differ diff --git a/src/.Types.hs.swp b/src/.Types.hs.swp new file mode 100644 index 0000000..aa83020 Binary files /dev/null and b/src/.Types.hs.swp differ diff --git a/src/Draw.hs b/src/Draw.hs index 118e7d3..e2ae6d9 100644 --- a/src/Draw.hs +++ b/src/Draw.hs @@ -1,11 +1,113 @@ module Draw where +import SDL (($=), get) + +import qualified Graphics.Rendering.OpenGL as GL + +import qualified Graphics.GLUtil as GU + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BC + +import Data.Maybe (fromJust) + import Control.Concurrent.MVar +import Linear + +import Foreign + -- internal imports import Types +quadCoord :: [Float] +quadCoord = + [ 1 , 1 , 0 + , 1 , (-1), 0 + , (-1), (-1), 0 + , (-1), 1 , 0 + ] + +quadIndices :: [Word] +quadIndices = + [ 0, 1, 3 + , 1, 2, 3 + ] + +initGL :: IO GLvebo +initGL = do + GL.depthFunc $= Just GL.Less + + vertexBufferObject <- GL.genObjectName + withArray quadCoord $ \ptr -> + GL.bufferData GL.ArrayBuffer $= + ( fromIntegral $ length quadCoord * sizeOf (0 :: Float) + , ptr + , GL.StaticDraw + ) + + elementBufferObject <- GL.genObjectName + GL.bindBuffer GL.ElementArrayBuffer $= Just elementBufferObject + + withArray quadIndices $ \ptr -> + GL.bufferData GL.ElementArrayBuffer $= + ( fromIntegral $ length quadIndices * sizeOf (0 :: Word) + , ptr + , GL.StaticDraw + ) + + GL.vertexAttribPointer (GL.AttribLocation 0) $= + ( GL.ToFloat + , GL.VertexArrayDescriptor 3 GL.Float 0 nullPtr + ) + + GL.drawElements GL.Triangles 6 GL.UnsignedInt nullPtr + + GL.clearColor $= (GL.Color4 0 0 1 1 :: GL.Color4 Float) + + return GLvebo + { giVBO = vertexBufferObject + , giEBO = elementBufferObject + } + +initVAO :: Word -> IO (Word, GL.VertexArrayObject) +initVAO ident = do + vertexArrayObject <- GL.genObjectName + GL.bindVertexArrayObject $= Just vertexArrayObject + return (ident, vertexArrayObject) + draw :: MVar State -> Word -> IO () draw state ident = do + st <- readMVar state + GL.currentProgram $= (Just . GU.program $ fromJust $ lookup ident $ + stPrograms st) + -- let proj = ortho (-1) 1 (-1) (1) (-1) 1 + -- model = mkTransformation (Quaternion 1 (V3 0 0 0)) (V3 0 0 0) + -- view = lookAt (V3 0 0 0) (V3 0 0 0) (V3 0 0 0) + -- pvm = proj !*! view !*! model + GL.bindVertexArrayObject $= lookup ident (stVAOs st) + GL.drawArrays GL.Triangles 0 (fromIntegral $ length quadCoord) return () + +vertexShader :: BS.ByteString +vertexShader = foldl (\acc a -> acc `BS.append` "\n" `BS.append` a) BS.empty + [ "#version 330 core" + , "" + , "layout (location = 0) in vec3 pos;" + , "" + , "void main() {" + , " gl_Position = vec4(pos.x, pos.y, pos.z, 1.0);" + , "}" + ] + +fragmentShader :: Word -> BS.ByteString +fragmentShader ident = foldl (\acc a -> acc `BS.append` "\n" `BS.append` a) BS.empty + [ "#version 330 core" + , "" + -- , "out vec4 gl_FragColor;" + , "" + , "void main() {" + , " gl_FragColor = vec4(" `BS.append` BC.pack (show (fromIntegral ident * (1 :: Float))) `BS.append` ", 0.5, 0.2, 1.0);" + , "}" + ] diff --git a/src/Main.hs b/src/Main.hs index a7ec4d7..470771f 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -8,6 +8,8 @@ import qualified SDL.Raw.Basic as SDL import qualified Graphics.Rendering.OpenGL as GL (clear, flush, ClearBuffer(..)) +import qualified Graphics.GLUtil as GU + -- import qualified NanoVG as NVG import Linear @@ -39,6 +41,8 @@ import Magic import Events +import Draw + import Util import Types @@ -88,33 +92,44 @@ main = do mapM_ (flip SDL.setWindowMode SDL.FullscreenDesktop . snd) wins void $ SDL.glSetAttribute SDL.SDL_GL_SHARE_WITH_CURRENT_CONTEXT 1 verb opts "Creating OpenGL context(s)" - contexts <- zip (map fst wins) <$> mapM (SDL.glCreateContext . snd) wins + context <- (SDL.glCreateContext . snd) (head wins) -- verb opts "Creating NanoVG context" -- _ <- glewInit -- nano <- NVG.createGL3 (S.fromList [NVG.Antialias, NVG.StencilStrokes]) - verb opts "Initializing state" - state <- newMVar <$> ( - State <$> - pure 1 <*> - pure (last $ map fst wins) <*> - getCurrentTime + verb opts "Initializing rendering pipeline" + glInits <- mapM (initVAO . fst) wins + vebo <- initGL + programs <- mapM (\(ident, _) -> do + ret <- GU.simpleShaderProgramBS vertexShader (fragmentShader ident) + return (ident, ret) ) + wins + verb opts "Initializing state" + time <- getCurrentTime + state <- newMVar ( + State + 1 + (last $ map fst wins) + time + glInits + programs + vebo + ) verb opts "Displaying window(s)" mapM_ (SDL.showWindow . snd) wins verb opts "Entering Loop" run <- newMVar True whileM_ (readMVar run) (do - mapM_ (\(ident, context) -> do - let win = fromJust (lookup ident wins) - SDL.glMakeCurrent win context + mapM_ (\(ident, window) -> do + SDL.glMakeCurrent window context mapM_ (eventHandler run) =<< SDL.pollEvents GL.clear [GL.ColorBuffer, GL.DepthBuffer, GL.StencilBuffer] - draw state + draw state ident GL.flush - SDL.glSwapWindow win - ) contexts + SDL.glSwapWindow window + ) wins ) - verb opts "Deleting context(s)" - mapM_ (SDL.glDeleteContext . snd) contexts + verb opts "Deleting context" + SDL.glDeleteContext context verb opts "Destroying window(s)" mapM_ (SDL.destroyWindow . snd) wins diff --git a/src/Types.hs b/src/Types.hs index 1c87915..222b7fb 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -1,5 +1,9 @@ module Types where +import qualified Graphics.Rendering.OpenGL as GL + +import qualified Graphics.GLUtil as GU + import qualified Data.Text as T import Data.Time.Clock @@ -16,4 +20,12 @@ data State = State { stCurrentPage :: Word , stPresentationWindow :: Word , stStartTime :: UTCTime - } deriving (Show) + , stVAOs :: [(Word, GL.VertexArrayObject)] + , stPrograms :: [(Word, GU.ShaderProgram)] + , stVEBO :: GLvebo + } + +data GLvebo = GLvebo + { giVBO :: GL.BufferObject + , giEBO :: GL.BufferObject + }