meow

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

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;
       };

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);"
+  , "}"
+  ]

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

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
+  }