roguestar-gl 0.4.0.1 → 0.4.0.2
raw patch · 4 files changed
+169/−149 lines, 4 filesdep ~rsagl
Dependency ranges changed: rsagl
Files
- roguestar-gl.cabal +4/−4
- src/Config.hs +22/−0
- src/Main.hs +0/−145
- src/MainGLUT.hs +143/−0
roguestar-gl.cabal view
@@ -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 <lane@downstairspeople.org>@@ -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
+ src/Config.hs view
@@ -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+
− src/Main.hs
@@ -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-
+ src/MainGLUT.hs view
@@ -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+