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
, 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

View File

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

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

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.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 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"
state <- newMVar <$> (
State <$>
pure 1 <*>
pure (last $ map fst wins) <*>
getCurrentTime
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

View File

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