{-# 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