ibis/src/Main.hs

162 lines
4.2 KiB
Haskell

{-# LANGUAGE BangPatterns #-}
module Main where
import qualified SDL
import qualified SDL.Raw.Video as SDL (glSetAttribute)
import qualified SDL.Raw.Enum as SDL
import qualified SDL.Raw.Basic as SDL
import qualified Graphics.Rendering.OpenGL as GL (clear, flush, ClearBuffer(..))
import qualified Graphics.GLUtil as GU
import Graphics.UI.Gtk.Poppler.Page
import Graphics.UI.Gtk.Poppler.Document
-- import qualified NanoVG as NVG
import Linear
import Options.Applicative
import Control.Monad
import Control.Monad.Loops
import Control.Concurrent (threadDelay)
import Control.Concurrent.MVar
import qualified Data.Text as T
import qualified Data.Set as S
import Data.List.Split (splitOn)
import Data.Maybe
import Data.Time.Clock
import Data.Word (Word32(..))
import System.Exit (exitFailure)
import Foreign.C.String
import Magic
-- internal imports
import Events
import Draw
import Util
import Types
main :: IO ()
main = do
opts <- execParser $ info (options <**> helper)
( fullDesc
<> progDesc "A simple PDF presenter written in Haskell using poppler and SDL2"
)
checkMagic opts
disps <- sdlInit
verb opts ("Number of displays detected: " ++ show (length disps))
verb opts ("Passed command line options: " ++ show opts)
mdoc <- documentNewFromFile (T.unpack $ "file://" <> optFile opts) Nothing
document <- case mdoc of
Just d -> return d
Nothing -> do
putErrLn ("Could not open file: " ++ T.unpack (optFile opts))
exitFailure
aspect <- fmap (\(w, h) -> w / h) (pageGetSize =<< documentGetPage document 0)
npag <- documentGetNPages document
verb opts "Creating window configuration(s)"
let !confs = map makeWindowConfig disps
verb opts "Creating window(s)"
wins <- zip ([0 .. ] :: [Word]) <$> mapM (uncurry SDL.createWindow) (
zip
( if length disps == 1
then
[ "Ibis - " <> optFile opts ]
else
[ "Ibis - " <> optFile opts <> " - Notes"
, "Ibis - " <> optFile opts
]
)
confs
)
when (optFullscreen opts) $
mapM_ (flip SDL.setWindowMode SDL.FullscreenDesktop . snd) wins
verb opts "Creating OpenGL context(s)"
context <- (SDL.glCreateContext . snd) (last wins)
verb opts "Initializing rendering pipeline"
initVAO
vebo <- initGL
program <- GU.simpleShaderProgramBS vertexShader fragmentShader
verb opts "Initializing state"
time <- SDL.ticks
state <- newMVar (
State
0
(fromIntegral $ npag - 1)
aspect
(optFile opts)
(last $ map fst wins)
time
time
wins
program
vebo
)
verb opts "Displaying window(s)"
mapM_ (SDL.showWindow . snd) wins
verb opts "Entering Loop"
run <- newMVar True
whileM_ (readMVar run) (do
mapM_ (\(ident, window) -> do
SDL.glMakeCurrent window context
mapM_ (eventHandler run state) =<< SDL.pollEvents
GL.clear [GL.ColorBuffer, GL.DepthBuffer, GL.StencilBuffer]
draw state ident
SDL.glSwapWindow window
) wins
st <- readMVar state
now <- SDL.ticks
-- let dt = now - (stLastTime st)
-- verb opts ("dt: " ++ show dt)
-- threadDelay (fromIntegral $ (max 0 ((1000 `div` 30) - dt)))
modifyMVar_ state (\st -> return st { stLastTime = now })
)
verb opts "Deleting context"
SDL.glDeleteContext context
verb opts "Destroying window(s)"
mapM_ (SDL.destroyWindow . snd) wins
checkMagic :: Options -> IO ()
checkMagic opts = do
magic <- magicOpen [MagicMime]
magicLoadDefault magic
mime <- head <$> splitOn ";" <$> magicFile magic (T.unpack $ optFile opts)
when (mime /= "application/pdf") $ do
putErrLn ("Not a PDF file: " ++ T.unpack (optFile opts))
exitFailure
sdlInit :: IO [SDL.Display]
sdlInit = do
SDL.initializeAll
SDL.screenSaverEnabled SDL.$= False
SDL.cursorVisible SDL.$= False
disps <- SDL.getDisplays
-- set Render quality
SDL.HintRenderScaleQuality SDL.$= SDL.ScaleLinear
-- check render quality
renderQuality <- SDL.get SDL.HintRenderScaleQuality
when (renderQuality /= SDL.ScaleLinear) $
putErrLn "Linear texture filtering not enabled!"
uncurry SDL.setHint =<< (,)
<$> newCString "SDL_VIDEO_MINIMIZE_ON_FOCUS_LOSS"
<*> newCString "0"
void $ SDL.glSetAttribute SDL.SDL_GL_SHARE_WITH_CURRENT_CONTEXT 1
return disps