This commit is contained in:
nek0 2019-02-02 22:45:57 +01:00
parent 01e7f7120d
commit 481a919763
8 changed files with 154 additions and 20 deletions

View File

@ -20,6 +20,7 @@ executable ibis
other-modules: Events other-modules: Events
, Util , Util
, Types , Types
, Draw
-- other-extensions: -- other-extensions:
default-extensions: OverloadedStrings default-extensions: OverloadedStrings
build-depends: base >=4.11 build-depends: base >=4.11
@ -30,9 +31,11 @@ executable ibis
, linear , linear
, monad-loops , monad-loops
, OpenGL , OpenGL
, GLUtil
, text , text
, magic , magic
, split , split
, time , time
, bytestring
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010

View File

@ -28,8 +28,8 @@ let
inherit (nixpkgs) pkgs; inherit (nixpkgs) pkgs;
f = { mkDerivation, base, containers, linear, magic, monad-loops, f = { mkDerivation, base, bytestring, containers, linear, magic, monad-loops,
optparse-applicative, OpenGL, poppler, split, stdenv, text, time optparse-applicative, OpenGL, GLUtil, poppler, split, stdenv, text, time
}: }:
mkDerivation { mkDerivation {
pname = "ibis"; pname = "ibis";
@ -37,8 +37,10 @@ let
src = ./.; src = ./.;
isLibrary = false; isLibrary = false;
isExecutable = true; isExecutable = true;
executableHaskellDepends = [ base containers linear sdl2 magic executableHaskellDepends = [ base bytestring containers linear sdl2 magic
monad-loops OpenGL optparse-applicative poppler split text time ]; monad-loops OpenGL GLUtil optparse-applicative poppler split text
time
];
description = "A pdf presenter"; description = "A pdf presenter";
license = stdenv.lib.licenses.gpl3; license = stdenv.lib.licenses.gpl3;
}; };

BIN
src/.Draw.hs.swp Normal file

Binary file not shown.

BIN
src/.Main.hs.swp Normal file

Binary file not shown.

BIN
src/.Types.hs.swp Normal file

Binary file not shown.

View File

@ -1,11 +1,113 @@
module Draw where 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 Control.Concurrent.MVar
import Linear
import Foreign
-- internal imports -- internal imports
import Types 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 :: MVar State -> Word -> IO ()
draw state ident = do 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 () 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);"
, "}"
]

View File

@ -8,6 +8,8 @@ import qualified SDL.Raw.Basic as SDL
import qualified Graphics.Rendering.OpenGL as GL (clear, flush, ClearBuffer(..)) import qualified Graphics.Rendering.OpenGL as GL (clear, flush, ClearBuffer(..))
import qualified Graphics.GLUtil as GU
-- import qualified NanoVG as NVG -- import qualified NanoVG as NVG
import Linear import Linear
@ -39,6 +41,8 @@ import Magic
import Events import Events
import Draw
import Util import Util
import Types import Types
@ -88,33 +92,44 @@ main = do
mapM_ (flip SDL.setWindowMode SDL.FullscreenDesktop . snd) wins mapM_ (flip SDL.setWindowMode SDL.FullscreenDesktop . snd) wins
void $ SDL.glSetAttribute SDL.SDL_GL_SHARE_WITH_CURRENT_CONTEXT 1 void $ SDL.glSetAttribute SDL.SDL_GL_SHARE_WITH_CURRENT_CONTEXT 1
verb opts "Creating OpenGL context(s)" 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" -- verb opts "Creating NanoVG context"
-- _ <- glewInit -- _ <- glewInit
-- nano <- NVG.createGL3 (S.fromList [NVG.Antialias, NVG.StencilStrokes]) -- nano <- NVG.createGL3 (S.fromList [NVG.Antialias, NVG.StencilStrokes])
verb opts "Initializing state" verb opts "Initializing rendering pipeline"
state <- newMVar <$> ( glInits <- mapM (initVAO . fst) wins
State <$> vebo <- initGL
pure 1 <*> programs <- mapM (\(ident, _) -> do
pure (last $ map fst wins) <*> ret <- GU.simpleShaderProgramBS vertexShader (fragmentShader ident)
getCurrentTime 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)" verb opts "Displaying window(s)"
mapM_ (SDL.showWindow . snd) wins mapM_ (SDL.showWindow . snd) wins
verb opts "Entering Loop" verb opts "Entering Loop"
run <- newMVar True run <- newMVar True
whileM_ (readMVar run) (do whileM_ (readMVar run) (do
mapM_ (\(ident, context) -> do mapM_ (\(ident, window) -> do
let win = fromJust (lookup ident wins) SDL.glMakeCurrent window context
SDL.glMakeCurrent win context
mapM_ (eventHandler run) =<< SDL.pollEvents mapM_ (eventHandler run) =<< SDL.pollEvents
GL.clear [GL.ColorBuffer, GL.DepthBuffer, GL.StencilBuffer] GL.clear [GL.ColorBuffer, GL.DepthBuffer, GL.StencilBuffer]
draw state draw state ident
GL.flush GL.flush
SDL.glSwapWindow win SDL.glSwapWindow window
) contexts ) wins
) )
verb opts "Deleting context(s)" verb opts "Deleting context"
mapM_ (SDL.glDeleteContext . snd) contexts SDL.glDeleteContext context
verb opts "Destroying window(s)" verb opts "Destroying window(s)"
mapM_ (SDL.destroyWindow . snd) wins mapM_ (SDL.destroyWindow . snd) wins

View File

@ -1,5 +1,9 @@
module Types where module Types where
import qualified Graphics.Rendering.OpenGL as GL
import qualified Graphics.GLUtil as GU
import qualified Data.Text as T import qualified Data.Text as T
import Data.Time.Clock import Data.Time.Clock
@ -16,4 +20,12 @@ data State = State
{ stCurrentPage :: Word { stCurrentPage :: Word
, stPresentationWindow :: Word , stPresentationWindow :: Word
, stStartTime :: UTCTime , stStartTime :: UTCTime
} deriving (Show) , stVAOs :: [(Word, GL.VertexArrayObject)]
, stPrograms :: [(Word, GU.ShaderProgram)]
, stVEBO :: GLvebo
}
data GLvebo = GLvebo
{ giVBO :: GL.BufferObject
, giEBO :: GL.BufferObject
}