getting nanovg and stuff

This commit is contained in:
nek0 2019-01-31 14:47:18 +01:00
parent 1da8a65028
commit 57674b344d
4 changed files with 72 additions and 10 deletions

View File

@ -22,6 +22,7 @@ executable ibis
-- other-extensions: -- other-extensions:
default-extensions: OverloadedStrings default-extensions: OverloadedStrings
build-depends: base >=4.11 build-depends: base >=4.11
, containers
, optparse-applicative , optparse-applicative
, poppler , poppler
, sdl2 , sdl2
@ -29,5 +30,8 @@ executable ibis
, monad-loops , monad-loops
, OpenGL , OpenGL
, text , text
, nanovg
, magic
, split
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010

View File

@ -1,3 +1,4 @@
{-# LANGUAGE BangPatterns #-}
module Main where module Main where
import qualified SDL import qualified SDL
@ -6,6 +7,8 @@ import qualified SDL.Raw.Enum as SDL
import qualified Graphics.Rendering.OpenGL as GL (clear, flush, ClearBuffer(..)) import qualified Graphics.Rendering.OpenGL as GL (clear, flush, ClearBuffer(..))
import qualified NanoVG as NVG
import Linear import Linear
import Options.Applicative import Options.Applicative
@ -17,6 +20,16 @@ import Control.Concurrent.MVar
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Set as S
import Data.List.Split (splitOn)
import Data.Maybe
import System.Exit (exitFailure)
import Magic
-- internal imports -- internal imports
import Util import Util
@ -29,35 +42,60 @@ main = do
( fullDesc ( fullDesc
<> progDesc "A simple PDF presenter written in Haskell using poppler and SDL2" <> progDesc "A simple PDF presenter written in Haskell using poppler and SDL2"
) )
magic <- magicOpen [MagicMime]
magicLoadDefault magic
mime <- head <$> splitOn ";" <$> magicFile magic (T.unpack $ optFile opts)
-- when (mime /= "application/pdf") $ do
-- verb opts ("Not a PDF file: " ++ T.unpack (optFile opts))
-- exitFailure
SDL.initializeAll SDL.initializeAll
SDL.screenSaverEnabled SDL.$= False SDL.screenSaverEnabled SDL.$= False
disps <- SDL.getDisplays disps <- SDL.getDisplays
putStrLn ("Number of displays detected: " ++ show (length disps)) verb opts ("Number of displays detected: " ++ show (length disps))
putStrLn ("Passed command line options: " ++ show opts) verb opts ("Passed command line options: " ++ show opts)
-- set Render quality -- set Render quality
SDL.HintRenderScaleQuality SDL.$= SDL.ScaleLinear SDL.HintRenderScaleQuality SDL.$= SDL.ScaleLinear
-- check render quality -- check render quality
renderQuality <- SDL.get SDL.HintRenderScaleQuality renderQuality <- SDL.get SDL.HintRenderScaleQuality
when (renderQuality /= SDL.ScaleLinear) $ when (renderQuality /= SDL.ScaleLinear) $
putErrLn "Linear texture filtering not enabled!" putErrLn "Linear texture filtering not enabled!"
putStrLn "Creating window(s)" verb opts "Creating window configuration(s)"
let !confs = map makeWindowConfig disps
verb opts "Creating window(s)"
wins <- zip ([0 .. ] :: [Word]) <$> mapM (uncurry SDL.createWindow) ( wins <- zip ([0 .. ] :: [Word]) <$> mapM (uncurry SDL.createWindow) (
zip zip
[ "Ibis - " <> optFile opts ( if length disps == 1
, "Ibis - " <> optFile opts <> " - Notes" then
] [ "Ibis - " <> optFile opts ]
(map makeWindowConfig disps) else
[ "Ibis - " <> optFile opts <> " - Notes"
, "Ibis - " <> optFile opts
]
)
confs
) )
when (optFullscreen opts) $ when (optFullscreen opts) $
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)"
contexts <- zip (map fst wins) <$> mapM (SDL.glCreateContext . snd) wins contexts <- zip (map fst wins) <$> mapM (SDL.glCreateContext . snd) wins
verb opts "Creating NanoVG context"
_ <- glewInit
nano <- NVG.createGL3 (S.fromList [NVG.Antialias, NVG.StencilStrokes])
verb opts "Creating windows"
mapM_ (SDL.showWindow . snd) wins mapM_ (SDL.showWindow . snd) wins
verb opts "Entering Loop"
run <- newMVar True run <- newMVar True
whileM_ (readMVar run) (do whileM_ (readMVar run) (do
GL.clear [GL.ColorBuffer, GL.DepthBuffer, GL.StencilBuffer] mapM_ (\(ident, context) -> do
GL.flush let win = fromJust (lookup ident wins)
mapM_ (SDL.glSwapWindow . snd) wins SDL.glMakeCurrent win context
GL.clear [GL.ColorBuffer, GL.DepthBuffer, GL.StencilBuffer]
GL.flush
SDL.glSwapWindow win
) contexts
) )
verb opts "Deleting context(s)"
mapM_ (SDL.glDeleteContext . snd) contexts mapM_ (SDL.glDeleteContext . snd) contexts
verb opts "Destroying window(s)"
mapM_ (SDL.destroyWindow . snd) wins mapM_ (SDL.destroyWindow . snd) wins

View File

@ -5,6 +5,7 @@ import qualified Data.Text as T
data Options = Options data Options = Options
{ optFullscreen :: Bool { optFullscreen :: Bool
, optFlipScreens :: Bool , optFlipScreens :: Bool
, optVerbose :: Bool
, optFile :: T.Text , optFile :: T.Text
} }
deriving (Show) deriving (Show)

View File

@ -1,15 +1,23 @@
{-# LANGUAGE ForeignFunctionInterface #-}
module Util where module Util where
import qualified SDL import qualified SDL
import Options.Applicative import Options.Applicative
import Control.Monad (when)
import System.IO import System.IO
import Foreign.C.Types (CInt(..))
-- internal imports -- internal imports
import Types import Types
foreign import ccall unsafe "glewInit"
glewInit :: IO CInt
glWindowConfig :: SDL.WindowConfig glWindowConfig :: SDL.WindowConfig
glWindowConfig = SDL.defaultWindow glWindowConfig = SDL.defaultWindow
{ SDL.windowOpenGL = Just SDL.defaultOpenGL { SDL.windowOpenGL = Just SDL.defaultOpenGL
@ -34,6 +42,12 @@ options = Options
<> help "Flip screens" <> help "Flip screens"
<> showDefault <> showDefault
) )
<*> switch
( long "verbose"
<> short 'v'
<> help "Show verbose console output"
<> showDefault
)
<*> argument str <*> argument str
( help "Input file" ( help "Input file"
<> metavar "FILE" <> metavar "FILE"
@ -44,3 +58,8 @@ makeWindowConfig d =
glWindowConfig glWindowConfig
{ SDL.windowPosition = SDL.Absolute (SDL.displayBoundsPosition d) { SDL.windowPosition = SDL.Absolute (SDL.displayBoundsPosition d)
} }
verb :: Options -> String -> IO ()
verb opts str = do
when (optVerbose opts) $
putStrLn str