diff --git a/roguestar-gl.cabal b/roguestar-gl.cabal --- a/roguestar-gl.cabal +++ b/roguestar-gl.cabal @@ -1,5 +1,5 @@ name: roguestar-gl -version: 0.4.0.1 +version: 0.4.0.2 license: OtherLicense license-file: LICENSE author: Christopher Lane Hinson @@ -15,7 +15,7 @@ homepage: http://roguestar.downstairspeople.org/ build-depends: base>=4&&<5, - rsagl==0.4.0.1, + rsagl==0.4.0.2, containers>=0.3.0.0 && < 0.4, arrows>=0.4.1.2 && < 0.5, mtl>=1.1.0.2 && < 1.2, @@ -33,7 +33,7 @@ tested-with: GHC==6.12.1 executable: roguestar-gl -main-is: Main.hs +main-is: MainGLUT.hs hs-source-dirs: src other-modules: Quality, ProtocolTypes, VisibleObject, Strings, WordGenerator, Driver, @@ -49,7 +49,7 @@ Models.EnergySwords, Models.EnergyThings, Models.CyborgType4, AnimationEvents, AnimationMenus, AnimationTerrain, AnimationTools, AnimationExtras, AnimationCreatures, AnimationBuildings, MaybeArrow, - EventUtils, Sky + EventUtils, Sky, Config ghc-options: -threaded -fno-warn-type-defaults -fexcess-precision ghc-prof-options: -prof -auto-all diff --git a/src/Config.hs b/src/Config.hs new file mode 100644 --- /dev/null +++ b/src/Config.hs @@ -0,0 +1,22 @@ +module Config + (short_version_string, + version_string, + window_name) + where + +import Paths_roguestar_gl +import Data.List +import Data.Version + +short_version_string :: String +short_version_string = + (concat $ intersperse "." $ map show $ versionBranch version) + +version_string :: String +version_string = short_version_string ++ if null (versionTags version) + then "" else "[" ++ unwords tags_str ++ "]" + where tags_str = intersperse ", " $ map show $ versionTags version + +window_name :: String +window_name = "Roguestar-GL " ++ version_string + diff --git a/src/Main.hs b/src/Main.hs deleted file mode 100644 --- a/src/Main.hs +++ /dev/null @@ -1,145 +0,0 @@ -{-# LANGUAGE Arrows #-} - -module Main - (main) - where - -import System.IO -import PrintText -import Data.Maybe -import Graphics.UI.GLUT -import Control.Monad -import Actions -import Keymaps.Keymaps -import CommandLine -import Keymaps.BuiltinKeymaps -import RenderingControl -import Driver -import Animation -import RSAGL.Scene -import Models.Library -import System.Timeout -import System.Exit -import Globals -import Control.Concurrent.STM -import Control.Concurrent -import Statistics - -roguestar_client_version :: String -roguestar_client_version = "0.3" - -default_window_size :: Size -default_window_size = Size 800 600 - -display_mode :: [DisplayMode] -display_mode = [RGBAMode, - WithDepthBuffer, - DoubleBuffered] - -timer_callback_millis :: Int -timer_callback_millis = 30 - -main :: IO () -main = - do (_, command_line) <- getArgsAndInitialize - let command_line_options = parseCommandLine command_line - let keymap = findKeymapOrDefault $ keymap_name command_line_options - scene_var <- newTVarIO Nothing - globals <- defaultGlobals - driver_object <- newDriverObject - print_text_object <- newPrintTextObject - animation_object <- newRoguestarAnimationObject mainAnimationLoop - lib <- newLibrary - initialWindowSize $= default_window_size - initialDisplayMode $= display_mode - window <- createWindow $ "RogueStar GL " ++ roguestar_client_version - reshapeCallback $= Just roguestarReshapeCallback - display_statistics <- newStatistics "rendering" - displayCallback $= roguestarDisplayCallback display_statistics scene_var print_text_object - perWindowKeyRepeat $= PerWindowKeyRepeatOff - keyboardMouseCallback $= (Just $ keyCallback print_text_object) - addTimerCallback timer_callback_millis (roguestarTimerCallback scene_var globals driver_object print_text_object keymap window) - scene_statistics <- newStatistics "scene" - sceneLoop scene_statistics scene_var lib globals driver_object print_text_object animation_object - mainLoop - -watchQuit :: Globals -> IO () -watchQuit g = - do q <- atomically $ readTVar $ global_should_quit g - when q $ exitWith ExitSuccess - -sceneLoop :: Statistics -> TVar (Maybe Scene) -> Library -> Globals -> DriverObject -> PrintTextObject -> RoguestarAnimationObject -> IO () -sceneLoop stats scene_var lib globals driver_object print_text_object animation_object = liftM (const ()) $ forkIO $ forever $ - do atomically $ - do b <- liftM isJust $ readTVar scene_var - when b retry - result <- timeout 20000000 $ - do scene <- runStatistics stats $ runRoguestarAnimationObject lib globals driver_object print_text_object animation_object - atomically $ writeTVar scene_var $ Just scene - if isNothing result - then do hPutStrLn stderr "roguestar-gl: aborting due to stalled simulation run (timed out after 20 seconds)" - exitWith $ ExitFailure 1 - else return () - -roguestarReshapeCallback :: Size -> IO () -roguestarReshapeCallback (Size width height) = - do matrixMode $= Projection - loadIdentity - viewport $= (Position 0 0,Size width height) - -roguestarDisplayCallback :: Statistics -> TVar (Maybe Scene) -> PrintTextObject -> IO () -roguestarDisplayCallback stats scene_var print_text_object = - do scene <- atomically $ - do result <- maybe retry return =<< readTVar scene_var - writeTVar scene_var Nothing - return result - result <- timeout 20000000 $ - do color (Color4 0 0 0 0 :: Color4 GLfloat) - clear [ColorBuffer] - (Size width height) <- get windowSize - runStatistics stats $ - do sceneToOpenGL (fromIntegral width / fromIntegral height) (0.1,80.0) scene - renderText print_text_object - swapBuffers - if isNothing result - then do hPutStrLn stderr "roguestar-gl: aborting due to stalled display callback (timed out after 20 seconds)" - exitWith $ ExitFailure 1 - else return () - -roguestarTimerCallback :: TVar (Maybe Scene) -> Globals -> DriverObject -> PrintTextObject -> Keymap -> Window -> IO () -roguestarTimerCallback scene_var globals driver_object print_text_object keymap window = - do watchQuit globals - result <- timeout 20000000 $ - do addTimerCallback timer_callback_millis $ roguestarTimerCallback scene_var globals driver_object print_text_object keymap window - postRedisplay $ Just window - maybeExecuteKeymappedAction globals driver_object print_text_object keymap - if isNothing result - then do hPutStrLn stderr "roguestar-gl: aborting due to stalled timer callback (timed out after 20 seconds)" - exitWith $ ExitFailure 1 - else return () - -maybeExecuteKeymappedAction :: Globals -> - DriverObject -> - PrintTextObject -> - Keymap -> - IO () -maybeExecuteKeymappedAction globals driver_object print_text_object keymap = - do let action_input = ActionInput globals - driver_object - print_text_object - pullInputBuffer print_text_object - buffer_contents <- getInputBuffer print_text_object - (id =<<) $ atomically $ - do synced_with_engine <- liftM (not . null) $ - getValidActions action_input Nothing - worked <- if synced_with_engine - then takeUserInputAction action_input =<< - keysToActionNames action_input keymap buffer_contents - else return False - filtered <- filterKeySequence action_input - keymap - buffer_contents - return $ if worked - then clearInputBuffer print_text_object - else setInputBuffer print_text_object filtered - diff --git a/src/MainGLUT.hs b/src/MainGLUT.hs new file mode 100644 --- /dev/null +++ b/src/MainGLUT.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE Arrows #-} + +module Main + (main) + where + +import System.IO +import PrintText +import Data.Maybe +import Graphics.UI.GLUT +import Control.Monad +import Actions +import Keymaps.Keymaps +import CommandLine +import Keymaps.BuiltinKeymaps +import RenderingControl +import Driver +import Animation +import RSAGL.Scene +import Models.Library +import System.Timeout +import System.Exit +import Globals +import Control.Concurrent.STM +import Control.Concurrent +import Statistics +import Config + +default_window_size :: Size +default_window_size = Size 800 600 + +display_mode :: [DisplayMode] +display_mode = [RGBAMode, + WithDepthBuffer, + DoubleBuffered] + +timer_callback_millis :: Int +timer_callback_millis = 30 + +main :: IO () +main = + do (_, command_line) <- getArgsAndInitialize + let command_line_options = parseCommandLine command_line + let keymap = findKeymapOrDefault $ keymap_name command_line_options + scene_var <- newTVarIO Nothing + globals <- defaultGlobals + driver_object <- newDriverObject + print_text_object <- newPrintTextObject + animation_object <- newRoguestarAnimationObject mainAnimationLoop + lib <- newLibrary + initialWindowSize $= default_window_size + initialDisplayMode $= display_mode + window <- createWindow window_name + reshapeCallback $= Just roguestarReshapeCallback + display_statistics <- newStatistics "rendering" + displayCallback $= roguestarDisplayCallback display_statistics scene_var print_text_object + perWindowKeyRepeat $= PerWindowKeyRepeatOff + keyboardMouseCallback $= (Just $ keyCallback print_text_object) + addTimerCallback timer_callback_millis (roguestarTimerCallback scene_var globals driver_object print_text_object keymap window) + scene_statistics <- newStatistics "scene" + sceneLoop scene_statistics scene_var lib globals driver_object print_text_object animation_object + mainLoop + +watchQuit :: Globals -> IO () +watchQuit g = + do q <- atomically $ readTVar $ global_should_quit g + when q $ exitWith ExitSuccess + +sceneLoop :: Statistics -> TVar (Maybe Scene) -> Library -> Globals -> DriverObject -> PrintTextObject -> RoguestarAnimationObject -> IO () +sceneLoop stats scene_var lib globals driver_object print_text_object animation_object = liftM (const ()) $ forkIO $ forever $ + do atomically $ + do b <- liftM isJust $ readTVar scene_var + when b retry + result <- timeout 20000000 $ + do scene <- runStatistics stats $ runRoguestarAnimationObject lib globals driver_object print_text_object animation_object + atomically $ writeTVar scene_var $ Just scene + if isNothing result + then do hPutStrLn stderr "roguestar-gl: aborting due to stalled simulation run (timed out after 20 seconds)" + exitWith $ ExitFailure 1 + else return () + +roguestarReshapeCallback :: Size -> IO () +roguestarReshapeCallback (Size width height) = + do matrixMode $= Projection + loadIdentity + viewport $= (Position 0 0,Size width height) + +roguestarDisplayCallback :: Statistics -> TVar (Maybe Scene) -> PrintTextObject -> IO () +roguestarDisplayCallback stats scene_var print_text_object = + do scene <- atomically $ + do result <- maybe retry return =<< readTVar scene_var + writeTVar scene_var Nothing + return result + result <- timeout 20000000 $ + do color (Color4 0 0 0 0 :: Color4 GLfloat) + clear [ColorBuffer] + (Size width height) <- get windowSize + runStatistics stats $ + do sceneToOpenGL (fromIntegral width / fromIntegral height) (0.1,80.0) scene + renderText print_text_object + swapBuffers + if isNothing result + then do hPutStrLn stderr "roguestar-gl: aborting due to stalled display callback (timed out after 20 seconds)" + exitWith $ ExitFailure 1 + else return () + +roguestarTimerCallback :: TVar (Maybe Scene) -> Globals -> DriverObject -> PrintTextObject -> Keymap -> Window -> IO () +roguestarTimerCallback scene_var globals driver_object print_text_object keymap window = + do watchQuit globals + result <- timeout 20000000 $ + do addTimerCallback timer_callback_millis $ roguestarTimerCallback scene_var globals driver_object print_text_object keymap window + postRedisplay $ Just window + maybeExecuteKeymappedAction globals driver_object print_text_object keymap + if isNothing result + then do hPutStrLn stderr "roguestar-gl: aborting due to stalled timer callback (timed out after 20 seconds)" + exitWith $ ExitFailure 1 + else return () + +maybeExecuteKeymappedAction :: Globals -> + DriverObject -> + PrintTextObject -> + Keymap -> + IO () +maybeExecuteKeymappedAction globals driver_object print_text_object keymap = + do let action_input = ActionInput globals + driver_object + print_text_object + pullInputBuffer print_text_object + buffer_contents <- getInputBuffer print_text_object + (id =<<) $ atomically $ + do synced_with_engine <- liftM (not . null) $ + getValidActions action_input Nothing + worked <- if synced_with_engine + then takeUserInputAction action_input =<< + keysToActionNames action_input keymap buffer_contents + else return False + filtered <- filterKeySequence action_input + keymap + buffer_contents + return $ if worked + then clearInputBuffer print_text_object + else setInputBuffer print_text_object filtered +