packages feed

roguestar-gl 0.2.2 → 0.4.0.0

raw patch · 57 files changed

+3246/−2444 lines, 57 filesdep +bytestringdep +old-timedep +priority-syncdep ~GLUTdep ~MonadRandomdep ~arrows

Dependencies added: bytestring, old-time, priority-sync, random, statistics, stm, vector

Dependency ranges changed: GLUT, MonadRandom, arrows, base, containers, filepath, mtl, rsagl

Files

Main.hs view
@@ -1,32 +1,134 @@+{-# LANGUAGE ExistentialQuantification, FlexibleInstances, OverloadedStrings #-}+ module Main (main) where  import System.Process import System.Exit+import System.Console.GetOpt import Control.Concurrent-import System.Environment import System.FilePath import System.IO import Control.Monad import Paths_roguestar_gl+import GHC.Environment+import System.Time+import qualified Data.ByteString as B+import Data.ByteString.Char8 ()+import GHC.Exts (IsString(..)) +data Args = Args {+    arg_echo_protocol :: Bool,+    arg_single_threaded :: Bool,+    arg_verbose :: Bool,+    arg_help :: Bool,+    arg_prefix :: String,+    arg_engine :: [String],+    arg_client :: [String] }++roguestar_options :: [OptDescr (Args -> Args)]+roguestar_options =+    [Option "s1" ["single-threaded"]+            (NoArg $ \a -> a { arg_single_threaded = True })+            "Run the engine and client single-threaded.",+     Option "e" ["echo-protocol"]+            (NoArg $ \a -> a { arg_echo_protocol = True })+            "Echo the client-server protocol (for debugging).",+     Option "h?" ["help"]+            (NoArg $ \a -> a { arg_help = True })+            "Print this help message.",+     Option "v" ["verbose"]+            (NoArg $ \a -> a { arg_verbose = True })+            "Print debugging information.",+     Option "p" ["prefix","path"]+            (ReqArg (\s a -> a { arg_prefix = s }) "PREFIX")+            ("Path to the directory where the roguestar-engine and " +++             "roguestar-gl binaries are kept.  You might need this " +++             "to play roguestar off a remotely mounted file server " +++             "or if something is broken and you know what you're doing.")]++help_text :: String+help_text = usageInfo+            ("Roguestar: A science-fiction role playing game.\n\n" +++             "Roguestar has a client-server architecture (roguestar-gl, " +++             "and roguestar-engine).  This program instantiates both " +++             "on the local host and manages all communication between " +++             "them.\n\n" +++             "Usage: roguestar [OPTIONS]")+            roguestar_options+ main :: IO ()-main = -    do (should_echo_protocol,args) <- -           do args <- getArgs-	      return ("--echo-protocol" `elem` args,-		      filter (/= "--echo-protocol") $ args)-       n <- getNumberOfCPUCores-       bin_dir <- getBinDir-       let n_rts_string = if n == 1 then [] else ["-N" ++ show n]-       let gl_args = ["+RTS", "-G4"] ++ n_rts_string ++ ["-RTS"] ++ args-       let engine_args = ["+RTS"] ++ n_rts_string ++ ["-RTS"] ++ ["version","over","begin"]-       (e_in,e_out,e_err,roguestar_engine) <- runInteractiveProcess (bin_dir `combine` "roguestar-engine") engine_args Nothing Nothing-       (gl_in,gl_out,gl_err,roguestar_gl) <- runInteractiveProcess (bin_dir `combine` "roguestar-gl") gl_args Nothing Nothing-       forkIO $ pump e_out  $ [("",gl_in)] ++ (if should_echo_protocol then [("engine >>> gl *** ",stdout)] else [])-       forkIO $ pump gl_out $ [("",e_in)] ++ (if should_echo_protocol then [("gl <<< engine *** ",stdout)] else [])-       forkIO $ pump e_err  $ [("roguestar-engine *** ",stderr)]-       forkIO $ pump gl_err $ [("roguestar-gl     *** ",stderr)]-       forkIO $+main =+    do bin_dir <- getBinDir+       let default_args = Args {+               arg_echo_protocol = False,+               arg_single_threaded = False,+               arg_help = False,+               arg_prefix = bin_dir,+               arg_verbose = False,+               arg_engine = [],+               arg_client = [] }+       raw_args <- getFullArgs+       let (opts_list,_,errs) = getOpt (ReturnInOrder $ \s args -> args {+                   arg_engine = arg_engine args ++ [s],+                   arg_client = arg_client args ++ [s] })+              roguestar_options+              raw_args+       let args = foldr ($) default_args opts_list+       when (arg_help args) $+           do putStrLn help_text+              exitWith ExitSuccess+       when (not $ null errs) $+           do mapM_ putStrLn errs+              exitWith ExitSuccess+       let n_rts_string = if arg_single_threaded args then [] else ["-N"]+       let gl_args =+               ["+RTS", "-G4"] +++               n_rts_string +++               ["-RTS"] +++               arg_client args+       let engine_args =+               ["+RTS"] +++               n_rts_string +++               ["-RTS"] +++               arg_engine args +++               ["version","over","begin"]+       let roguestar_engine_bin = arg_prefix args `combine` "roguestar-engine"+       let roguestar_gl_bin = arg_prefix args `combine` "roguestar-gl"+       when (arg_verbose args) $+           putStrLn $ "starting process: " +++                      roguestar_engine_bin ++ " " +++                      unwords engine_args+       (e_in,e_out,e_err,roguestar_engine) <-+           runInteractiveProcess roguestar_engine_bin+                                 engine_args+                                 Nothing+                                 Nothing+       when (arg_verbose args) $+           putStrLn $ "starting process: " +++                      roguestar_gl_bin +++                      " " +++                      unwords gl_args+       (gl_in,gl_out,gl_err,roguestar_gl) <-+           runInteractiveProcess roguestar_gl_bin gl_args Nothing Nothing+       stdout_chan <- newChan+       _ <- forkIO $ pump e_out  $+                [("",DHandle gl_in)] +++                (if arg_echo_protocol args+                    then [("engine >>> gl *** ",DChanTime stdout_chan)]+                    else [])+       _ <- forkIO $ pump gl_out $+                [("",DHandle e_in)] +++                (if arg_echo_protocol args+                    then [("engine <<< gl *** ",DChanTime stdout_chan)]+                    else [])+       _ <- forkIO $ pump e_err  $ if arg_verbose args+                then [("roguestar-engine *** ",DChan stdout_chan)]+                else []+       _ <- forkIO $ pump gl_err $ if arg_verbose args+                then [("roguestar-gl     *** ",DChan stdout_chan)]+                else []+       _ <- forkIO $ printChan stdout stdout_chan+       _ <- forkIO $            do roguestar_engine_exit <- waitForProcess roguestar_engine               case roguestar_engine_exit of                   ExitFailure x -> putStrLn $ "roguestar-engine terminated unexpectedly (" ++ show x ++  ")"@@ -37,36 +139,29 @@            ExitFailure x -> putStrLn $ "roguestar-gl terminated unexpectedly (" ++ show x ++ ")"            _ -> return ()        -pump :: Handle -> [(String,Handle)] -> IO ()+data Destination = DHandle Handle | DChan (Chan B.ByteString) | DChanTime (Chan B.ByteString)++send :: Destination -> B.ByteString -> IO ()+send (DHandle h) str = B.hPutStrLn h str >> hFlush h+send (DChan c) str = writeChan c str+send (DChanTime c) str =+    do t <- getClockTime+       writeChan c $ fromString (show t) `B.append` ": " `B.append` str++setup :: Destination -> IO ()+setup (DHandle h) = hSetBuffering h NoBuffering+setup _ = return ()++pump :: Handle -> [(B.ByteString,Destination)] -> IO () pump from tos =-    do mapM_ (flip hSetBuffering NoBuffering . snd) tos-       hSetBuffering from NoBuffering+    do mapM_ (setup . snd) tos        forever $-           do l <- hGetLine from-	      flip mapM_ tos $ \(name,to) -> -	          do hPutStrLn to $ name ++ l-	             hFlush to--getNumberOfCPUCores :: IO Int-getNumberOfCPUCores =-    do m_nop <- readNumberOfProcessors-       m_cpuinfo <- scanCPUInfo-       case (m_nop,m_cpuinfo) of-           (Just n,_) -> do hPutStrLn stderr $ "roguestar: " ++ show n ++ -	                        " CPU core(s) based on windows environment variable NUMBER_OF_PROCESSORS. "-			    return n-           (_,Just n) -> do hPutStrLn stderr $ "roguestar: " ++ show n ++ " CPU core(s) based on /proc/cpuinfo. " -	                    return n-	   _ ->          do hPutStrLn stderr "roguestar: couldn't find number of CPU cores, assuming 1 core"-	                    return 1+           do l <- B.hGetLine from+              flip mapM_ tos $ \(name,to) -> send to $ name `B.append` l -readNumberOfProcessors :: IO (Maybe Int)-readNumberOfProcessors = flip catch (const $ return Nothing) $ liftM Just $-    do n <- getEnv "NUMBER_OF_PROCESSORS"-       return $! read n+printChan :: Handle -> Chan B.ByteString -> IO ()+printChan h c = forever $+    do s <- readChan c+       B.hPutStrLn h s+       hFlush h -scanCPUInfo :: IO (Maybe Int)-scanCPUInfo = catch (liftM (Just . length . filter isProcessorLine . map words . lines) $ readFile "/proc/cpuinfo")-                    (const $ return Nothing)-    where isProcessorLine ["processor",":",_] = True-          isProcessorLine _ = False
roguestar-gl.cabal view
@@ -1,5 +1,5 @@ name:                roguestar-gl-version:             0.2.2+version:             0.4.0.0 license:             OtherLicense license-file:        LICENSE author:              Christopher Lane Hinson <lane@downstairspeople.org>@@ -9,23 +9,31 @@ synopsis:            Sci-fi roguelike (turn-based, chessboard-tiled, role playing) game description:         Roguestar is a science fiction themed roguelike (turn-based,                      chessboard-tiled, role playing) game written in Haskell.  Roguestar uses-                     OpenGL for graphics.  This is still a very early release and several-                     important things don't work.-                     .-                     This initial release allows you to play one of six alien races.  You begin-                     the game stranded on an alien planet, fighting off an endless hoard of-                     hostile robots.+                     OpenGL for graphics.  This is still a very early release.                      .                      The git repository is available at <http://www.downstairspeople.org/git/roguestar-gl.git>. homepage:            http://roguestar.downstairspeople.org/ -build-depends:       base>3, containers, arrows, mtl, MonadRandom, GLUT, rsagl >=0.2.2 && <0.3, filepath >1.1---roguestar-engine==0.3+build-depends:       base>=4&&<5,+                     rsagl==0.4.0.0,+                     containers>=0.3.0.0 && < 0.4,+                     arrows>=0.4.1.2 && < 0.5,+                     mtl>=1.1.0.2 && < 1.2,+                     MonadRandom>=0.1.4 && < 1.2,+                     GLUT>=2.1.2.1 && < 2.2,+                     filepath>=1.1.0.3 && < 1.2,+                     random>=1.0.0.2 && < 1.1,+                     bytestring>=0.9.1.5 && < 0.10,+                     statistics>=0.5.1.0 && < 0.6,+                     vector>=0.6.0.1 && < 0.7,+                     stm>=2.1.1.2 && < 2.2,+                     priority-sync>=0.2.1.0 && < 0.2.2+ build-type:          Simple-tested-with:         GHC==6.8.2+tested-with:         GHC==6.12.1  executable:          roguestar-gl-main-is:             Main.lhs+main-is:             Main.hs hs-source-dirs:      src other-modules:       Quality, ProtocolTypes, VisibleObject,                      Strings, WordGenerator, Driver,@@ -36,11 +44,12 @@                      Models.Library, Models.MachineParts, Models.LibraryData, Models.Caduceator,                      Models.Tree, Models.Encephalon, Models.PhaseWeapons, RenderingControl,                      Keymaps.BuiltinKeymaps, Keymaps.CommonKeymap, Keymaps.NumpadKeymap,-                     Keymaps.Keymaps, Keymaps.VIKeymap-ghc-options:         -Wall -threaded -fno-warn-type-defaults -fexcess-precision+                     Keymaps.Keymaps, Keymaps.VIKeymap, AnimationBuildings, Models.Monolith,+                     Models.Stargate, Statistics+ghc-options:         -threaded -fno-warn-type-defaults -fexcess-precision ghc-prof-options:    -prof -auto-all  executable:          roguestar main-is:             Main.hs-build-depends:       process-ghc-options:         -Wall -threaded+build-depends:       process, old-time, bytestring+ghc-options:         -threaded
+ src/Actions.hs view
@@ -0,0 +1,389 @@+{-# LANGUAGE OverloadedStrings #-}+-- |+-- A set of actions that should be bound to keystrokes.+--+module Actions+    (takeUserInputAction,+     getValidActions,+     ActionInput(..),+     select_race_action_names,+     select_base_class_action_names,+     make_what_action_names,+     executeContinueAction,+     menu_states,+     player_turn_states)+    where++import Control.Monad.Error+import Driver+import Data.List+import PrintText+import Tables+import Data.Maybe+import Globals+import RSAGL.Types+import Control.Concurrent.STM+import Quality+import Data.Char+import qualified Data.ByteString.Char8 as B++-- |+-- Input to an action.+--+data ActionInput = ActionInput {+    action_globals :: Globals,+    action_driver_object :: DriverObject,+    action_print_text_object :: PrintTextObject }++type Action = ActionInput -> ErrorT ActionValidityReason STM (STM ())++data ActionValidity = Go | Hold ActionValidityReason deriving (Read, Show)+data ActionValidityReason = Invalid | Undecided String deriving (Read,Show)++instance Error ActionValidityReason where+    noMsg = strMsg ""+    strMsg = Undecided++invalid :: ErrorT ActionValidityReason STM ()+invalid = throwError Invalid++isUndecided :: ActionValidity -> Bool+isUndecided (Hold (Undecided _)) = True+isUndecided _ = False++isGo :: ActionValidity -> Bool+isGo Go = True+isGo _ = False++{----------------------------------------------------------+ --  Support functions for Actions+ ----------------------------------------------------------}++actionValid :: ActionInput -> Action -> STM ActionValidity+actionValid action_input action = +    do result <- runErrorT $ action action_input+       return $ either Hold (const Go) result++executeAction :: ActionInput -> Action -> STM ()+executeAction action_input action =+    do result <- runErrorT $ action action_input+       either (\failure -> printText+                           (action_print_text_object action_input)+                           UnexpectedEvent+                           ("unable to execute action: " `B.append`+                           B.pack (show failure)))+              (id)+              result+       return ()++executeContinueAction :: ActionInput -> STM ()+executeContinueAction action_input =+    do either (const $ return()) id =<< (runErrorT $ (snd continue_action) action_input)+       return ()++-- |+-- Constructs an action such that the action is valid only if it is listed in+-- a table from the engine.  The first parameter identifies the table column to look up,+-- (table name, table id, header to look under).  The second parameter is the name of the+-- action as it will be send to the engine.  The third parameter is the action_param.+-- The action_param must be listed under the specified header of the specified table,+-- or the action will not be allowed to execute.+--+-- For example: selectTableAction ("people","0","name") "select-person-to-call-state" "call-with-telephone" "carl"+-- +-- \> game query state+-- answer: state select-person-to-call-state+-- \> game query people+-- begin-table people 0 name+-- john+-- wendy+-- carl+-- bob+-- end-table+-- \> game action call-with-telephone Carl+-- +-- In this case the action executes because the state is actually select-person-to-call-state and Carl+-- is actually listed under the "name" header of the "people" table.+--+-- In practice this function is used for things like the race-selection-state and the class-selection-state+-- where we select from a predifined list of possible choices, but the engine further restricts the choices.+-- Each possible choice is it's own action that will only return action_valid if it is listed in the appropriate+-- table from the engine. +--+selectTableAction :: (B.ByteString,B.ByteString,B.ByteString) -> B.ByteString -> B.ByteString -> B.ByteString -> Action+selectTableAction (the_table_name,the_table_id,the_table_header) allowed_state action_name action_param = stateGuard [allowed_state] $+    \action_input ->+        do table <- maybe (fail $ "need table " ++ B.unpack the_table_name) return =<< (lift $ getTable (action_driver_object action_input) the_table_name the_table_id)+           unless ([action_param] `elem` tableSelect table [the_table_header]) invalid+           return $ driverAction (action_driver_object action_input) [action_name, action_param]++-- |+-- Guard an action to only run during specific states.+--+stateGuard :: [B.ByteString] -> Action -> Action+stateGuard allowed_states actionM action_input =+    do is_valid_state <- liftM (maybe False (`elem` allowed_states)) $ lift $ getAnswer (action_driver_object action_input) "state"+       unless is_valid_state invalid+       actionM action_input++-- |+-- A simple action that can run whenever the player state is a member of a given list.+-- The action name is passed directly to the engine.+--+stateLinkedAction :: [B.ByteString] -> B.ByteString -> (B.ByteString,Action)+stateLinkedAction allowed_state action_name = +    (action_name,+     stateGuard allowed_state $ \action_input ->+         return $ driverAction (action_driver_object action_input) [action_name])++-- |+-- An action that can always run, like "quit".+--+alwaysAction :: B.ByteString -> (ActionInput -> STM ()) -> (B.ByteString,Action)+alwaysAction action_name actionSTM =+    (action_name,+     \action_input -> return $ actionSTM action_input)++{----------------------------------------------------------+    Specific Actions+ ----------------------------------------------------------}++player_turn_states :: [B.ByteString]+player_turn_states = ["player-turn","move","attack","fire","jump","turn","clear-terrain"]++menu_states :: [B.ByteString]+menu_states = ["race-selection","class-selection","pickup","drop","wield","make","make-finished","make-what"]++selectable_menu_states :: [B.ByteString]+selectable_menu_states = if all (`elem` menu_states) states then states else error "selectable_menu_states: inconsistent with menu_states"+    where states = ["pickup","drop","wield","make"]++quit_action :: (B.ByteString,Action)+quit_action = alwaysAction "quit" $ \action_input ->+    writeTVar (global_should_quit $ action_globals action_input) True++continue_action :: (B.ByteString,Action)+continue_action = ("continue",\action_input ->+    do is_snapshot <- liftM (== Just "yes") $ lift $ getAnswer (action_driver_object action_input) "snapshot"+       unless is_snapshot invalid+       return $ driverAction (action_driver_object action_input) ["continue"])++direction_actions :: [(B.ByteString,Action)]+direction_actions = map (stateLinkedAction player_turn_states) ["n","ne","e","se","s","sw","w","nw"]++next_action :: (B.ByteString,Action)+next_action = stateLinkedAction selectable_menu_states "next"++prev_action :: (B.ByteString,Action)+prev_action = stateLinkedAction selectable_menu_states "prev"++select_menu_action :: (B.ByteString,Action)+select_menu_action = stateLinkedAction selectable_menu_states "select-menu"++normal_action :: (B.ByteString,Action)+normal_action = ("normal",+    stateGuard (menu_states ++ player_turn_states) $ \action_input -> +        return $ driverAction (action_driver_object action_input) ["normal"])++move_action :: (B.ByteString,Action)+move_action = stateLinkedAction player_turn_states "move"++jump_action :: (B.ByteString,Action)+jump_action = stateLinkedAction player_turn_states "jump"++turn_action :: (B.ByteString,Action)+turn_action = stateLinkedAction player_turn_states "turn"++fire_action :: (B.ByteString,Action)+fire_action = stateLinkedAction player_turn_states "fire"++attack_action :: (B.ByteString,Action)+attack_action = stateLinkedAction player_turn_states "attack"++clear_terrain_action :: (B.ByteString,Action)+clear_terrain_action = stateLinkedAction player_turn_states "clear-terrain"++reroll_action :: (B.ByteString,Action)+reroll_action = stateLinkedAction ["class-selection"] "reroll"++pickup_action :: (B.ByteString,Action)+pickup_action = stateLinkedAction player_turn_states "pickup"++drop_action :: (B.ByteString,Action)+drop_action = stateLinkedAction player_turn_states "drop"++wield_action :: (B.ByteString,Action)+wield_action = stateLinkedAction player_turn_states "wield"++unwield_action :: (B.ByteString,Action)+unwield_action = stateLinkedAction player_turn_states "unwield"++activate_action :: (B.ByteString,Action)+activate_action = stateLinkedAction player_turn_states "activate"++make_begin_action :: (B.ByteString,Action)+make_begin_action = stateLinkedAction player_turn_states "make-begin"++make_what_action_names :: [B.ByteString]+make_what_action_names = ["pistol","carbine","rifle","fleuret","sabre"]++makeWhatAction :: B.ByteString -> (B.ByteString,Action)+makeWhatAction s = (s,+    stateGuard ["make-what","make","make-finished"] $ \action_input ->+        return $ driverAction (action_driver_object action_input) ["make-what",s])++make_what_actions :: [(B.ByteString,Action)]+make_what_actions = map makeWhatAction make_what_action_names++make_end_action :: (B.ByteString,Action)+make_end_action = stateLinkedAction ["make-finished"] "make-end"++selectRaceAction :: B.ByteString -> (B.ByteString,Action)+selectRaceAction s = +    (s,selectTableAction ("player-races","0","name") "race-selection" "select-race" s)++selectBaseClassAction :: B.ByteString -> (B.ByteString,Action)+selectBaseClassAction s = +    (s,selectTableAction ("base-classes","0","class") "class-selection" "select-class" s)++zoomSize :: RSdouble -> RSdouble+zoomSize x | x < 3 = 0.2+zoomSize x | x < 10 = 1.0+zoomSize _ | otherwise = 5.0++zoomIn :: RSdouble -> RSdouble+zoomIn x = x - (zoomSize $ x - zoomSize x)++zoomOut :: RSdouble -> RSdouble+zoomOut x = x + (zoomSize x)++zoom_in_action :: (B.ByteString,Action)+zoom_in_action = alwaysAction "zoom-in" $ \action_input ->+    do writeTVar (global_planar_camera_distance $ action_globals action_input) .+           (max 1.0 . zoomIn) =<< readTVar (global_planar_camera_distance $+                                                action_globals action_input)+       return ()++zoom_out_action :: (B.ByteString,Action)+zoom_out_action = alwaysAction "zoom-out" $ \action_input ->+    do writeTVar (global_planar_camera_distance $ action_globals action_input) .+           (min 25.0 . zoomOut) =<< readTVar (global_planar_camera_distance $+                                                action_globals action_input)+       return ()++sky_on_action :: (B.ByteString,Action)+sky_on_action = alwaysAction "sky-on" $ \action_input ->+    do writeTVar (global_sky_on $ action_globals action_input) True+       return ()++sky_off_action :: (B.ByteString,Action)+sky_off_action = alwaysAction "sky-off" $ \action_input ->+    do writeTVar (global_sky_on $ action_globals action_input) False+       return ()++setQualityAction :: Quality -> (B.ByteString,Action)+setQualityAction q =+    alwaysAction (B.pack $ map toLower $ "quality-" ++ show q) $+           \action_input ->+        do writeTVar (global_quality_setting $ action_globals action_input) q+           return ()++quality_bad :: (B.ByteString,Action)+quality_bad = setQualityAction Bad++quality_poor :: (B.ByteString,Action)+quality_poor = setQualityAction Poor++quality_good :: (B.ByteString,Action)+quality_good = setQualityAction Good++quality_super :: (B.ByteString,Action)+quality_super = setQualityAction Super++{----------------------------------------------------------+    Lists of Known Actions+ ----------------------------------------------------------}++select_race_action_names :: [B.ByteString]+select_race_action_names = [--"anachronid",+			    "androsynth",+			    "ascendant",+			    "caduceator",+			    "encephalon",+			    --"goliath",+			    --"hellion",+			    --"kraken",+			    --"myrmidon",+			    --"perennial",+			    "recreant",+			    "reptilian"]++select_race_actions :: [(B.ByteString,Action)]+select_race_actions = map selectRaceAction select_race_action_names++select_base_class_action_names :: [B.ByteString]+select_base_class_action_names = ["barbarian",+				  "consular",+				  "engineer",+				  "forceadept",+				  "marine",+				  "ninja",+				  "pirate",+				  "scout",+				  "shepherd",+				  "thief",+				  "warrior"]++select_base_class_actions :: [(B.ByteString,Action)]+select_base_class_actions = map selectBaseClassAction select_base_class_action_names++-- | List of every convievable action.+all_actions :: [(B.ByteString,Action)]+all_actions = [continue_action,quit_action,reroll_action,+               pickup_action,drop_action,wield_action,unwield_action,+               next_action,prev_action,normal_action,select_menu_action,+               zoom_in_action,zoom_out_action,sky_on_action,sky_off_action,+               quality_bad,quality_poor,quality_good,quality_super] +++              select_race_actions ++ +	      select_base_class_actions +++              direction_actions +++              make_what_actions +++	      [move_action,turn_action,fire_action,jump_action,attack_action,clear_terrain_action,activate_action,+               make_begin_action,make_end_action]++-- | Find an action with the given name.+lookupAction :: B.ByteString -> (B.ByteString,Action)+lookupAction x = (x,fromMaybe (error $ "tried to operate on an unknown action named " ++ B.unpack x) $ lookup x all_actions)++-- |+-- Answer a complete list of all actions that can be run at this time.+-- Accepts an optional list of action names to choose from; if Nothing,+-- uses all concievable actions as that list.+--+getValidActions :: ActionInput -> Maybe [B.ByteString] -> STM [B.ByteString]+getValidActions action_input actions_list =+    do valid_action_pairs <- mapM (\a -> liftM ((,) a) $ actionValid action_input $ snd a) $ maybe all_actions (map lookupAction) actions_list+       return $ case () of+           () | any (isUndecided . snd) valid_action_pairs -> []+           () | otherwise -> map (fst . fst) $ filter (isGo . snd) valid_action_pairs++-- |+-- Takes a list of action names and executes the first action in the list that is valid+-- in the current context, based on each action's action_valid entry.+-- Returns True if an action was taken, False otherwise.+--+takeUserInputAction :: ActionInput -> [B.ByteString] -> STM Bool+takeUserInputAction _ [] = return False+takeUserInputAction action_input action_names =+    do valid_actions <- getValidActions action_input (Just action_names)+       let action = map lookupAction valid_actions+       case length action of+           0 -> return False+           1 -> do executeAction action_input $ snd $ head action+                   return True+           _ -> do driverSendError (action_driver_object action_input)+                       ("Action bindings warning: multiple valid action for binding: " `B.append`+                       (B.concat $ intersperse ", " $ map fst action))+                   executeAction action_input $ snd $ head action+                   return True+
− src/Actions.lhs 
@@ -1,241 +0,0 @@--\section{Actions}--\begin{code}-module Actions-    (takeUserInputAction,-     getValidActions,-     ActionInput(..),-     select_race_action_names,-     select_base_class_action_names,-     executeContinueAction)-    where--import System.Exit-import Control.Monad.Error-import Driver-import Data.List-import PrintText-import Tables-import Data.Maybe-import System.IO--data ActionInput = ActionInput {-    action_driver_object :: DriverObject,-    action_print_text_object :: PrintTextObject }--type Action = ActionInput -> ErrorT String IO (IO ())--actionValid :: ActionInput -> Action -> IO Bool-actionValid action_input action = -    do result <- runErrorT $ action action_input-       return $ either (const False) (const True) result--executeAction :: ActionInput -> Action -> IO ()-executeAction action_input action =-    do result <- runErrorT $ action action_input-       either (\s -> printText (action_print_text_object action_input) UnexpectedEvent ("unable to execute action: " ++ s))-              (id)-              result-       return ()--executeContinueAction :: ActionInput -> IO ()-executeContinueAction action_input =-    do either (const $ return()) id =<< (runErrorT $ (snd continue_action) action_input)-       return ()--quit_action :: (String,Action)-quit_action = ("quit",-               \_ -> return $ exitWith ExitSuccess)---- |--- Constructs an action such that the action is valid only if it is listed in--- a table from the engine.  The first parameter identifies the table column to look up,--- (table name, table id, header to look under).  The second parameter is the name of the--- action as it will be send to the engine.  The third parameter is the action_param.--- The action_param must be listed under the specified header of the specified table,--- or the action will not be allowed to execute.------ For example: selectTableAction ("people","0","name") "select-person-to-call-state" "call-with-telephone" "carl"--- --- \> game query state--- answer: state select-person-to-call-state--- \> game query people--- begin-table people 0 name--- john--- wendy--- carl--- bob--- end-table--- \> game action call-with-telephone Carl--- --- In this case the action executes because the state is actually select-person-to-call-state and Carl--- is actually listed under the "name" header of the "people" table.------ In practice this function is used for things like the race-selection-state and the class-selection-state--- where we select from a predifined list of possible choices, but the engine further restricts the choices.--- Each possible choice is it's own action that will only return action_valid if it is listed in the appropriate--- table from the engine. ----selectTableAction :: (String,String,String) -> String -> String -> String -> Action-selectTableAction (the_table_name,the_table_id,the_table_header) allowed_state action_name action_param = -    \action_input ->-        do state <- maybe (fail "") return =<< (lift $ driverGetAnswer (action_driver_object action_input) "state")-           guard $ state == allowed_state-           table <- maybe (fail "") return =<< (lift $ driverGetTable (action_driver_object action_input) the_table_name the_table_id)-           guard $ [action_param] `elem` tableSelect table [the_table_header]-           return $ driverAction (action_driver_object action_input) [action_name, action_param]---- |--- An action that depends on the state flag of the game engine and an arbitrary constant parameter.--- For example, actions that operate directionally are parameterized--- on the eight directions (n,s,w,e,nw,ne,sw,se).------ i.e., parameterizedAction "player-turn" "move" "nw" becomes --- ("move-nw",driverAction _ ["move","nw"])----parameterizedAction :: String -> String -> String -> (String,Action)-parameterizedAction allowed_state action_name parameter =-    (action_name ++ "-" ++ parameter,-     stateGuard allowed_state $ \action_input ->-         return $ driverAction (action_driver_object action_input) [action_name,parameter])---- |--- Guard an action to only run during a specific state.----stateGuard :: String -> Action -> Action-stateGuard allowed_state actionM action_input =-    do guard =<< (liftM (== Just allowed_state) $ lift $ driverGetAnswer (action_driver_object action_input) "state")-       actionM action_input---- |--- An action that depends just on the state flag of the game engine.----stateLinkedAction :: String -> String -> (String,Action)-stateLinkedAction allowed_state action_name = -    (action_name,-     stateGuard allowed_state $ \action_input ->-         return $ driverAction (action_driver_object action_input) [action_name])--continue_action :: (String,Action)-continue_action = ("continue",\action_input ->-    do guard =<< (liftM (== Just "yes") $ lift $ driverGetAnswer (action_driver_object action_input) "snapshot")-       return $ driverAction (action_driver_object action_input) ["continue"])--moveAction :: String -> (String,Action)-moveAction = parameterizedAction "player-turn" "move"--turnAction :: String -> (String,Action)-turnAction = parameterizedAction "player-turn" "turn"--fireAction :: String -> (String,Action)-fireAction = parameterizedAction "player-turn" "fire"--reroll_action :: (String,Action)-reroll_action = stateLinkedAction "class-selection" "reroll"--pickup_action :: (String,Action)-pickup_action = stateLinkedAction "player-turn" "pickup"--drop_action :: (String,Action)-drop_action = stateLinkedAction "player-turn" "drop"--wield_action :: (String,Action)-wield_action = stateLinkedAction "player-turn" "wield"--unwield_action :: (String,Action)-unwield_action = stateLinkedAction "player-turn" "unwield"--selectRaceAction :: String -> (String,Action)-selectRaceAction s = -    (s,selectTableAction ("player-races","0","name") "race-selection" "select-race" s)--selectBaseClassAction :: String -> (String,Action)-selectBaseClassAction s = -    (s,selectTableAction ("base-classes","0","class") "class-selection" "select-class" s)--select_race_action_names :: [String]-select_race_action_names = [--"anachronid",-			    "androsynth",-			    "ascendant",-			    "caduceator",-			    "encephalon",-			    --"goliath",-			    --"hellion",-			    --"kraken",-			    --"myrmidon",-			    --"perennial",-			    "recreant",-			    "reptilian"]--select_race_actions :: [(String,Action)]-select_race_actions = map selectRaceAction select_race_action_names--select_base_class_action_names :: [String]-select_base_class_action_names = ["barbarian",-				  "consular",-				  "engineer",-				  "forceadept",-				  "marine",-				  "ninja",-				  "pirate",-				  "scout",-				  "shepherd",-				  "thief",-				  "warrior"]--select_base_class_actions :: [(String,Action)]-select_base_class_actions = map selectBaseClassAction select_base_class_action_names--eight_directions :: [String]-eight_directions = ["n","ne","nw","e","w","se","sw","s"]--move_actions :: [(String,Action)]-move_actions = map moveAction eight_directions--turn_actions :: [(String,Action)]-turn_actions = map turnAction eight_directions--fire_actions :: [(String,Action)]-fire_actions = map fireAction eight_directions--all_actions :: [(String,Action)]-all_actions = [continue_action,quit_action,reroll_action,pickup_action,drop_action,wield_action,unwield_action] ++-              select_race_actions ++ -	      select_base_class_actions ++-	      move_actions ++-              turn_actions ++-	      fire_actions--lookupAction :: String -> (String,Action)-lookupAction x = (x,fromMaybe (error $ "tried to operate on an unknown action named " ++ x) $ lookup x all_actions)---- |--- Answer a complete list of all actions that can be run at this time.--- Accepts an optional list of action names to choose from; if Nothing,--- uses all concievable actions as that list.----getValidActions :: ActionInput -> Maybe [String] -> IO [String]-getValidActions action_input actions_list = -    do valid_action_pairs <- filterM (actionValid action_input . snd) $ -                                 maybe all_actions (map lookupAction) actions_list-       return $ map fst valid_action_pairs---- |--- Takes a list of action names and executes the first action in the list that is valid--- in the current context, based on each action's action_valid entry.--- Returns True if an action was taken, False otherwise.----takeUserInputAction :: ActionInput -> [String] -> IO Bool-takeUserInputAction _ [] = return False-takeUserInputAction action_input action_names =-    do valid_actions <- getValidActions action_input (Just action_names)-       let action = map lookupAction valid_actions-       case length action of-           0 -> return False-	   1 -> do executeAction action_input $ snd $ head action-                   return True-	   _ -> do hPutStrLn stderr ("Action bindings warning: multiple valid action for binding: " ++ (concat $ intersperse ", " $ map fst action))-		   executeAction action_input $ snd $ head action-                   return True-\end{code}
+ src/Animation.hs view
@@ -0,0 +1,274 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE GeneralizedNewtypeDeriving,+             Arrows,+             MultiParamTypeClasses,+             FlexibleInstances,+             TypeFamilies,+             ExistentialQuantification,+             Rank2Types,+             OverloadedStrings,+             UndecidableInstances #-}++module Animation+    (RSwitch,+     AnimationState,+     RoguestarAnimationObject,+     newRoguestarAnimationObject,+     runRoguestarAnimationObject,+     driverGetAnswerA,+     driverGetTableA,+     printTextA,+     printTextOnce,+     debugA,+     debugOnce,+     donesA,+     printMenuItemA,+     printMenuA,+     clearPrintTextA,+     clearPrintTextOnce,+     libraryA,+     libraryPointAtCamera,+     blockContinue,+     requestPrintTextMode,+     readGlobal,+     randomA)+    where++import RSAGL.Math+import RSAGL.FRP+import RSAGL.Scene hiding (std_scene_layer_hud,std_scene_layer_cockpit,std_scene_layer_local,std_scene_layer_infinite)+import RSAGL.Animation+import RSAGL.Auxiliary.RecombinantState+import Control.Monad.State+import Control.Arrow+import Control.Arrow.Operations+import Driver+import Tables+import System.IO+import System.Random+import PrintText+import Models.Library+import Models.LibraryData+import Data.Maybe+import Keymaps.Keymaps+import Keymaps.CommonKeymap+import Actions+import Data.List+import Data.Ord+import Strings+import Globals+import Control.Concurrent.STM+import qualified Data.ByteString as B++data AnimationState = AnimationState {+    animstate_scene_accumulator :: SceneAccumulator IO,+    animstate_globals :: Globals,+    animstate_driver_object :: FrozenDriver,+    animstate_print_text_object :: PrintTextObject,+    animstate_library :: Library,+    animstate_block_continue :: Bool,+    animstate_print_text_mode :: PrintTextMode,+    animstate_suspended_stm_action :: STM () }++instance CoordinateSystemClass AnimationState where+    getCoordinateSystem = getCoordinateSystem . animstate_scene_accumulator+    storeCoordinateSystem cs as = as { +        animstate_scene_accumulator = storeCoordinateSystem cs $ animstate_scene_accumulator as }++instance ScenicAccumulator AnimationState IO where+    accumulateScene sl so as = as { +        animstate_scene_accumulator = accumulateScene sl so $ animstate_scene_accumulator as }++instance RecombinantState AnimationState where+    type SubState AnimationState = AnimationState+    clone old = old { animstate_scene_accumulator = clone $ animstate_scene_accumulator old }+    recombine old new = old { +        animstate_scene_accumulator = recombine (animstate_scene_accumulator old) (animstate_scene_accumulator new),+        animstate_block_continue = animstate_block_continue old || animstate_block_continue new,+        animstate_print_text_mode = animstate_print_text_mode old `mergePrintTextModes` animstate_print_text_mode new }++-- | The RogueStar switch type.+type RSwitch k t i o m = SimpleSwitch k t AnimationState i o m++instance (CoordinateSystemClass csc,StateOf m ~ csc) => AffineTransformable (FRP e m j p) where+    transform m actionA = proc x -> transformA actionA -< (Affine $ transform m,x)++newtype RoguestarAnimationObject = RoguestarAnimationObject (FRPProgram AnimationState () SceneLayerInfo)++newRoguestarAnimationObject :: (forall e. FRP e (FRP1 AnimationState () SceneLayerInfo) () SceneLayerInfo) -> IO RoguestarAnimationObject+newRoguestarAnimationObject rs_anim =+    liftM RoguestarAnimationObject $ newFRP1Program rs_anim++runRoguestarAnimationObject :: Library ->+                               Globals ->+                               DriverObject ->+                               PrintTextObject ->+                               RoguestarAnimationObject ->+                               IO Scene+runRoguestarAnimationObject lib globals driver_object print_text_object+                            (RoguestarAnimationObject rso) =+    do frozen_driver_object <- atomically $ freezeDriver driver_object+       let anim_state = AnimationState {+               animstate_globals = globals,+               animstate_scene_accumulator = null_scene_accumulator,+               animstate_driver_object = frozen_driver_object,+               animstate_print_text_object = print_text_object,+               animstate_library = lib,+               animstate_block_continue = False,+               animstate_print_text_mode = Limited,+               animstate_suspended_stm_action = return () }+       (result_scene_layer_info,result_animstate) <-+           updateFRPProgram Nothing ((),anim_state) rso+       atomically $+           do when (not $ animstate_block_continue result_animstate) $+                  executeContinueAction $+                      ActionInput globals driver_object print_text_object+              setPrintTextMode print_text_object $+                  animstate_print_text_mode result_animstate+              animstate_suspended_stm_action result_animstate+       assembleScene result_scene_layer_info $+           animstate_scene_accumulator result_animstate++-- | Request an answer from the engine.  This will return 'Nothing' until the answer arrives, which may never happen.+driverGetAnswerA :: (StateOf m ~ AnimationState) => FRP e m B.ByteString (Maybe B.ByteString)+driverGetAnswerA = proc query ->+    do driver_object <- arr animstate_driver_object <<< fetch -< ()+       ioAction (\(driver_object_,query_) ->+           atomically $ getAnswer driver_object_ query_) -<+               (driver_object,query)++-- | Request a data table from the engine.  This will return 'Nothing' until the entire table arrives, which may never happen.+driverGetTableA :: (StateOf m ~ AnimationState) => FRP e m (B.ByteString,B.ByteString) (Maybe RoguestarTable)+driverGetTableA = proc query ->+    do driver_object <- arr animstate_driver_object <<< fetch -< ()+       ioAction (\(driver_object_,(the_table_name,the_table_id)) ->+                 atomically $+                     getTable driver_object_ the_table_name the_table_id) -<+                         (driver_object,query)++-- | Store an IO action and run it at the end of the frame.+suspendedSTMAction :: (FRPModel m, StateOf m ~ AnimationState) =>+                     (i -> STM ()) -> FRP e m i ()+suspendedSTMAction action = proc i ->+    do s <- fetch -< ()+       store -< s { animstate_suspended_stm_action =+           animstate_suspended_stm_action s >> action i }++-- | Print a line of text to the game console.  This will print exactly once.+-- Accepts 'Nothing' and prints once immediately when a value is supplied.+printTextOnce :: (FRPModel m, StateOf m ~ AnimationState) => FRP e m (Maybe (TextType,B.ByteString)) ()+printTextOnce = onceA printTextA++printTextA :: (FRPModel m, StateOf m ~ AnimationState) =>+              FRP e m (Maybe (TextType,B.ByteString)) ()+printTextA = proc pt_data ->+    do print_text_object <- arr animstate_print_text_object <<< fetch -< ()+       suspendedSTMAction (\(print_text_object,x) -> case x of+            Nothing -> return ()+            Just (pt_type,pt_string) ->+                printText print_text_object pt_type pt_string)+           -< (print_text_object,pt_data)++-- | Number of dones.  (A done is a message from the engine that an change has occured in the game world.)+donesA :: (StateOf m ~ AnimationState) => FRP e m () Integer+donesA = proc () ->+    do driver_object <- arr animstate_driver_object <<< fetch -< ()+       ioAction (atomically . driverDones) -< driver_object++-- | Print a debugging message to 'stderr'.  This will print on every frame of animation.+debugA :: (StateOf m ~ AnimationState) => FRP e m (Maybe B.ByteString) ()+debugA = ioAction (maybe (return ()) (B.hPutStrLn stderr))++-- | Print a debugging message to 'stderr'.  This will print exactly once.+debugOnce :: (FRPModel m, StateOf m ~ AnimationState) => FRP e m (Maybe B.ByteString) ()+debugOnce = onceA debugA++-- | Get a list of keystrokes that correspond to the specified action, that are valid on the current frame of animation.+-- This can be used to display a menu that correctly indicates what keystroke to press for a given action.+actionNameToKeysA :: (StateOf m ~ AnimationState) => B.ByteString -> FRP e m () [B.ByteString]+actionNameToKeysA action_name = proc () ->+    do animstate <- fetch -< ()+       let action_input = ActionInput (animstate_globals animstate)+                                      (thawDriver $ animstate_driver_object animstate)+                                      (animstate_print_text_object animstate)+       ioAction id -< atomically (actionNameToKeys action_input+                                                   common_keymap+                                                   action_name)++-- | Print a menu using 'printMenuItemA'+printMenuA :: (FRPModel m, StateOf m ~ AnimationState) => [B.ByteString] -> FRP e m () ()+printMenuA = foldr (>>>) (arr id) . map printMenuItemA++-- | Print a single menu item including it's keystroke.+printMenuItemA :: (FRPModel m, StateOf m ~ AnimationState) => B.ByteString -> FRP e m () ()+printMenuItemA action_name = proc () ->+    do keys <- actionNameToKeysA action_name -< ()+       printTextA -< fmap (\s -> (Query,s `B.append` " - " `B.append` hrstring action_name)) $ listToMaybe $ sortBy (comparing B.length) keys++-- | Clear all printed text once.  This begins a new clean segment of printed text.+clearPrintTextOnce :: (FRPModel m, StateOf m ~ AnimationState) => FRP e m () ()+clearPrintTextOnce = onceA clearPrintTextA <<< arr (const $ Just ())++clearPrintTextA :: (FRPModel m, StateOf m ~ AnimationState) => FRP e m (Maybe ()) ()+clearPrintTextA = proc i ->+    do print_text_object <- arr (animstate_print_text_object) <<< fetch -< ()+       suspendedSTMAction id -<+           when (isJust i) $ clearOutputBuffer print_text_object++-- | Do an action exactly once.+onceA :: (FRPModel m) => (forall n. (FRPModel n, StateOf n ~ StateOf m) => FRP e n (Maybe j) p) -> FRP e m (Maybe j) p+onceA actionA = frp1Context onceA_+    where onceA_ = proc j ->+              do p <- actionA -< j+                 switchTerminate -< (if isJust j then (Just $ arr (const p)) else Nothing,p)++-- | Display a library model.+libraryA :: (StateOf m ~ AnimationState,LibraryModelSource lm) =>+            FRP e m (SceneLayer,lm) ()+libraryA = proc (layer,lm) ->+    do q <- readGlobal global_quality_setting -< ()+       lib <- arr animstate_library <<< fetch -< ()+       accumulateSceneA -< (layer,+           sceneObject $ lookupModel lib (toLibraryModel lm) q)++-- | Display a library model that remains oriented toward the camera.+libraryPointAtCamera :: (StateOf m ~ AnimationState,LibraryModelSource lm) =>+                        FRP e m (SceneLayer,lm) ()+libraryPointAtCamera = proc (layer,lm) ->+    do q <- readGlobal global_quality_setting -< ()+       lib <- arr animstate_library <<< fetch -< ()+       pointAtCameraA -< (layer,lookupModel lib (toLibraryModel lm) q)++-- | Prevent the engine from auto-continuing.  When the engine is in a snapshot state, +-- the client will automatically ask it to step forward either to the next snapshot or+-- the player's turn.  This delays the continue action until some animation or+-- text finishes printing.+blockContinue :: (StateOf m ~ AnimationState) => FRP e m Bool ()+blockContinue = proc b ->+    do animstate <- fetch -< ()+       store -< animstate { animstate_block_continue = animstate_block_continue animstate || b }++-- | Change the 'PrintTextMode'.  If multiple calls are made to 'requestPrintTextMode', then+-- 'Disabled' takes precedence over all others, while 'Unlimited' takes precedence over 'Limited'.+requestPrintTextMode :: (StateOf m ~ AnimationState) => FRP e m PrintTextMode ()+requestPrintTextMode = proc s ->+    do animstate <- fetch -< ()+       store -< animstate { animstate_print_text_mode = animstate_print_text_mode animstate `mergePrintTextModes` s }++mergePrintTextModes :: PrintTextMode -> PrintTextMode -> PrintTextMode+mergePrintTextModes _ Disabled = Disabled+mergePrintTextModes Disabled _ = Disabled+mergePrintTextModes Limited Unlimited = Unlimited+mergePrintTextModes Unlimited Limited = Unlimited+mergePrintTextModes m _ = m++-- | Read a global variable.+readGlobal :: (StateOf m ~ AnimationState) => (Globals -> TVar g) -> FRP e m () g+readGlobal f = proc () ->+    do globals <- arr animstate_globals <<< fetch -< ()+       ioAction (\globals_ -> atomically $ readTVar $ f globals_) -< globals++-- | Get a bounded random value, as 'randomRIO'.  A new value is pulled for each frame of animation.+randomA :: (Random a) => FRP e m (a,a) a+randomA = ioAction randomRIO+
− src/Animation.lhs 
@@ -1,199 +0,0 @@-\section{The Roguestar Animation Arrow}--\begin{code}-{-# LANGUAGE GeneralizedNewtypeDeriving, Arrows #-}--module Animation-    (RSAnimA,-     RSAnimA1,-     RSAnimAX,-     RoguestarAnimationObject,-     newRoguestarAnimationObject,-     runRoguestarAnimationObject,-     driverGetAnswerA,-     driverGetTableA,-     printTextA,-     printTextOnce,-     debugA,-     debugOnce,-     printMenuItemA,-     printMenuA,-     clearPrintTextA,-     clearPrintTextOnce,-     libraryA,-     libraryPointAtCamera,-     blockContinue,-     requestPrintTextMode)-    where--import RSAGL.FRP-import RSAGL.CoordinateSystems-import RSAGL.Scene-import RSAGL.AnimationExtras-import Control.Monad.State-import Control.Arrow-import Control.Arrow.Transformer hiding (lift)-import Control.Arrow.Transformer as Arrow-import Control.Arrow.Transformer.State as StateArrow-import Control.Arrow.Operations-import Driver-import Tables-import Control.Concurrent.MVar-import RSAGL.Time-import System.IO-import PrintText-import Models.Library-import Models.LibraryData-import Quality-import Data.Maybe-import Keymaps.Keymaps-import Keymaps.CommonKeymap-import Actions-import Data.List-import Data.Ord-import Strings-import Actions--data AnimationState = AnimationState {-    animstate_scene_accumulator :: SceneAccumulator,-    animstate_driver_object :: DriverObject,-    animstate_print_text_object :: PrintTextObject,-    animstate_library :: Library,-    animstate_block_continue :: Bool,-    animstate_print_text_mode :: PrintTextMode }--instance CoordinateSystemClass AnimationState where-    getCoordinateSystem = getCoordinateSystem . animstate_scene_accumulator-    storeCoordinateSystem cs as = as { -        animstate_scene_accumulator = storeCoordinateSystem cs $ animstate_scene_accumulator as }--instance ScenicAccumulator AnimationState where-    accumulateScene sl so as = as { -        animstate_scene_accumulator = accumulateScene sl so $ animstate_scene_accumulator as }--newtype IOGuard a = IOGuard { runIOGuard :: IO a } deriving (Functor,Monad)--type RSAnimAX k t i o j p = FRPX k t i o (StateArrow AnimationState (Kleisli IOGuard)) j p-type RSAnimA t i o j p = RSAnimAX Threaded t i o j p-type RSAnimA1 i o j p = RSAnimAX () () i o j p--type RSAnimA_ j p = StateArrow AnimationState (Kleisli IOGuard) j p--newtype RoguestarAnimationObject = RoguestarAnimationObject {-    rso_arrow :: MVar (FRPProgram (StateArrow AnimationState (Kleisli IOGuard)) () Camera) }--newRoguestarAnimationObject :: RSAnimA1 () Camera () Camera -> IO RoguestarAnimationObject-newRoguestarAnimationObject rs_anim = -    liftM RoguestarAnimationObject $ newMVar $ newFRP1Program rs_anim--runRoguestarAnimationObject :: Library -> DriverObject -> PrintTextObject -> RoguestarAnimationObject -> IO Scene-runRoguestarAnimationObject lib driver_object print_text_object rso =-    do old_rso_program <- takeMVar $ rso_arrow rso-       t <- getTime-       ((result_camera,new_rso_program),result_animstate) <- runIOGuard $ (runKleisli $ StateArrow.runState $ updateFRPProgram old_rso_program) (((),t),-           AnimationState {-               animstate_scene_accumulator = null_scene_accumulator,-	       animstate_driver_object = driver_object,-	       animstate_print_text_object = print_text_object,-	       animstate_library = lib,-	       animstate_block_continue = False,-	       animstate_print_text_mode = Limited })-       putMVar (rso_arrow rso) new_rso_program-       when (not $ animstate_block_continue result_animstate) $ executeContinueAction $ ActionInput driver_object print_text_object-       setPrintTextMode print_text_object $ animstate_print_text_mode result_animstate-       assembleScene result_camera $ animstate_scene_accumulator result_animstate--ioA :: (j -> IO p) -> RSAnimAX any t i o j p-ioA action = Arrow.lift $ ioA_ action--ioA_ :: (j -> IO p) -> RSAnimA_ j p-ioA_ action = proc j -> Arrow.lift $ Kleisli (\x -> IOGuard $ action x) -< j--driverGetAnswerA :: RSAnimAX any t i o String (Maybe String)-driverGetAnswerA = proc query ->-    do driver_object <- arr animstate_driver_object <<< fetch -< ()-       ioA (\(driver_object_,query_) -> driverGetAnswer driver_object_ query_) -< (driver_object,query)--driverGetTableA :: RSAnimAX any t i o (String,String) (Maybe RoguestarTable)-driverGetTableA = proc query ->-    do driver_object <- arr animstate_driver_object <<< fetch -< ()-       ioA (\(driver_object_,(the_table_name,the_table_id)) -> -           driverGetTable driver_object_ the_table_name the_table_id) -< (driver_object,query)--printTextA :: RSAnimAX any t i o (Maybe (TextType,String)) ()-printTextA = Arrow.lift printTextA_--printTextOnce :: RSAnimAX any t i o (Maybe (TextType,String)) ()-printTextOnce = onceA printTextA_ --printTextA_ :: RSAnimA_ (Maybe (TextType,String)) ()-printTextA_ = proc pt_data ->-    do print_text_object <- arr animstate_print_text_object <<< fetch -< ()-       ioA_ (\(print_text_object,x) -> case x of-            Nothing -> return ()-	    Just (pt_type,pt_string) -> printText print_text_object pt_type pt_string) -< (print_text_object,pt_data)--debugA :: RSAnimAX any t i o (Maybe String) ()-debugA = Arrow.lift debugA_--debugA_ :: RSAnimA_ (Maybe String) ()-debugA_ = Arrow.lift $ Kleisli $ maybe (return ()) (IOGuard . hPutStrLn stderr)--debugOnce :: RSAnimAX any t i o (Maybe String) ()-debugOnce = onceA debugA_--actionNameToKeysA :: String -> RSAnimAX any t i o () [String]-actionNameToKeysA action_name = Arrow.lift $ proc () ->-    do animstate <- fetch -< ()-       let action_input = ActionInput (animstate_driver_object animstate)-                                      (animstate_print_text_object animstate)-       app -< (Arrow.lift $ Kleisli $ const $ IOGuard $ actionNameToKeys action_input common_keymap action_name,())--printMenuA :: [String] -> RSAnimAX any t i o () ()-printMenuA = foldr (>>>) (arr id) . map printMenuItemA--printMenuItemA :: String -> RSAnimAX any t i o () ()-printMenuItemA action_name = proc () ->-    do keys <- actionNameToKeysA action_name -< ()-       printTextA -< fmap (\s -> (Query,s ++ " - " ++ hrstring action_name)) $ listToMaybe $ sortBy (comparing length) keys--clearPrintTextA :: RSAnimAX any t i o () ()-clearPrintTextA = Arrow.lift clearPrintText_ <<< arr (const $ Just ())--clearPrintTextOnce :: RSAnimAX any t i o () ()-clearPrintTextOnce = onceA clearPrintText_ <<< arr (const $ Just ())--clearPrintText_ :: RSAnimA_ (Maybe ()) ()-clearPrintText_ = proc i ->-    do print_text_object <- arr (animstate_print_text_object) <<< fetch -< ()-       app -< maybe (arr $ const (),()) (const (Arrow.lift $ Kleisli $ const $ IOGuard $ clearOutputBuffer print_text_object,())) i--onceA :: StateArrow AnimationState (Kleisli IOGuard) (Maybe j) p -> RSAnimAX any t i o (Maybe j) p-onceA actionA = frp1Context onceA_-    where onceA_ = proc j -> -              do p <- Arrow.lift actionA -< j-	         switchTerminate -< (if isJust j then (Just $ arr (const p)) else Nothing,p)--libraryA :: RSAnimAX any t i o (SceneLayer,LibraryModel) ()-libraryA = proc (layer,lm) ->-    do lib <- arr animstate_library <<< fetch -< ()-       accumulateSceneA -< (layer,sceneObject $ lookupModel lib lm Good)--libraryPointAtCamera :: RSAnimAX any t i o (SceneLayer,LibraryModel) ()-libraryPointAtCamera = proc (layer,lm) ->-    do lib <- arr animstate_library <<< fetch -< ()-       pointAtCameraA -< (layer,lookupModel lib lm Good)--blockContinue :: RSAnimAX any t i o Bool ()-blockContinue = Arrow.lift $ proc b ->-    do animstate <- fetch -< ()-       store -< animstate { animstate_block_continue = animstate_block_continue animstate || b }--requestPrintTextMode :: RSAnimAX any t i o PrintTextMode ()-requestPrintTextMode = Arrow.lift $ proc s ->-    do animstate <- fetch -< ()-       store -< animstate { animstate_print_text_mode = case (animstate_print_text_mode animstate,s) of-	   (_,Disabled) -> Disabled-	   (Limited,Unlimited) -> Unlimited-           (m,_) -> m }-\end{code}
+ src/AnimationBuildings.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE Arrows, OverloadedStrings, TypeFamilies, FlexibleContexts #-}++module AnimationBuildings+    (buildingAvatar)+    where++import RSAGL.FRP+import Animation+import VisibleObject+import Models.LibraryData+import Control.Arrow+import Scene++type BuildingAvatarSwitch m = AvatarSwitch () () m+type BuildingAvatar e m = FRP e (BuildingAvatarSwitch m) () ()++buildingAvatar :: (FRPModel m) => BuildingAvatar e m+buildingAvatar = proc () ->+    do objectTypeGuard (== "building") -< ()+       m_building_type <- objectDetailsLookup ThisObject "building-type" -< ()+       switchContinue -< (fmap switchTo m_building_type,())+       returnA -< ()+  where switchTo "monolith" = simpleBuildingAvatar Monolith+        switchTo "portal" = simpleBuildingAvatar Portal+        switchTo _ = questionMarkAvatar >>> arr (const ())++simpleBuildingAvatar :: (FRPModel m, LibraryModelSource lm) =>+                        lm -> BuildingAvatar e m+simpleBuildingAvatar phase_weapon_model = proc () ->+    do visibleObjectHeader -< ()+       m_orientation <- objectIdealOrientation ThisObject -< ()+       whenJust (transformA libraryA) -< fmap+           (\o -> (o,(scene_layer_local,phase_weapon_model))) m_orientation+       returnA -< ()++
+ src/CommandLine.hs view
@@ -0,0 +1,12 @@+module CommandLine(CommandLineOptions, keymap_name, parseCommandLine) where++import Keymaps.Keymaps++data CommandLineOptions = CommandLineOptions {+	keymap_name :: Maybe KeymapName+}++-- Extremely minimal implementation for now: switch to System.Console.GetOpt or just use a config. file?+parseCommandLine :: [String] -> CommandLineOptions+parseCommandLine [the_keymap_name] = CommandLineOptions $ Just the_keymap_name+parseCommandLine _ = CommandLineOptions Nothing
− src/CommandLine.lhs 
@@ -1,14 +0,0 @@-\begin{code}-module CommandLine(CommandLineOptions, keymap_name, parseCommandLine) where--import Keymaps.Keymaps--data CommandLineOptions = CommandLineOptions {-	keymap_name :: Maybe KeymapName-}---- Extremely minimal implementation for now: switch to System.Console.GetOpt or just use a config. file?-parseCommandLine :: [String] -> CommandLineOptions-parseCommandLine [the_keymap_name] = CommandLineOptions $ Just the_keymap_name-parseCommandLine _ = CommandLineOptions Nothing-\end{code}
+ src/Driver.hs view
@@ -0,0 +1,347 @@+{-# LANGUAGE OverloadedStrings, PatternGuards #-}+-- | Interacts with Protocol module of roguestar-engine.+module Driver+    (DriverObject,RoguestarEngineState,FrozenDriver,+     freezeDriver,thawDriver,+     DriverClass(..),+     driverSendError,+     driverNoop,+     driverDones,+     newDriverObject,+     driverAction)+    where++import Control.Concurrent.STM+import Control.Concurrent+import Data.List as List+import Data.Map as Map+import Data.Set as Set+import Data.Maybe+import System.IO+import Tables+import RSAGL.FRP.Time+import Control.Applicative+import Control.Monad.Reader+import qualified Data.ByteString.Char8 as B++-- | Contains detailed information about ongoing interaction with the engine.+data DriverObject = DriverObject {+        -- | Unparsed incomming information from the engine.  These lines are+        -- stored in reverse order from how they were recieved.+        driver_incomming :: TVar [B.ByteString],+        -- | Unsent outgoing information to the driver.  Either a destructive+        -- action or a lossy query.+        driver_outgoing :: TVar (Either B.ByteString [B.ByteString]),+        -- | Unsent outgoing error messages.  Stored in reverse order.+        driver_errors :: TVar [B.ByteString],+        -- | Lines already sent to the engine.  This is cleared whenever we send+        -- a "game action" line.  We retain this because it's wasteful to repeat+        -- queries when nothing has been committed back to the engine.+        driver_cached_lines :: TVar (Set.Set [B.ByteString]),+        -- | Parsed information about the game state.  This is cleared whenever+        -- we send a "game action" line.+        driver_engine_state :: TVar RoguestarEngineState,+        -- | Count of the number of times we've recieved "done" from the engine.+        driver_dones :: TVar Integer,+        -- | Count of the number of destructive actions we've sent to the+        -- engine.+        driver_actions :: TVar Integer,+        -- | Current time, updated constantly by the read/write/error loops.+        driver_time :: TVar Time }++-- | A frozen 'DriverObject'.  It has a static view of the world as seen at the+-- time that the Driver is fozen, however, the original 'DriverObject' continues+-- to be updated when this 'FrozenDriver' is used.+data FrozenDriver = FrozenDriver {+    _frozen_driver :: DriverObject,+    _frozen_state :: RoguestarEngineState,+    _frozen_actions :: Integer,+    _frozen_dones :: Integer }++-- | Contains all of the information that is known about roguestar-engine at a+-- specific moment in time.+data RoguestarEngineState = RoguestarEngineState {+    -- index by (table_name, table_id)+    restate_tables :: Map (B.ByteString,B.ByteString) RoguestarTable,+    restate_answers :: Map B.ByteString B.ByteString }++-- | Initialize a DriverObject.  Call only once in any given process.+newDriverObject :: IO DriverObject+newDriverObject =+    do driver_object <- initialDriverData+       _ <- forkIO $ forever $ driverReadLoop driver_object+       _ <- forkIO $ forever $ driverWriteLoop driver_object+       _ <- forkIO $ forever $ driverErrorLoop driver_object+       return driver_object++initialDriverData :: IO DriverObject+initialDriverData = DriverObject <$>+    newTVarIO [] <*>+    newTVarIO (Right []) <*>+    newTVarIO [] <*>+    newTVarIO Set.empty <*>+    newTVarIO (RoguestarEngineState Map.empty Map.empty) <*>+    newTVarIO 0 <*>+    newTVarIO 0 <*>+    (newTVarIO =<< getTime)++updateTime :: DriverObject -> Time -> STM ()+updateTime driver_object t =+    do old_time <- readTVar (driver_time driver_object)+       when (t > old_time) $+           writeTVar (driver_time driver_object) t++-- | Just write to the engine.+driverWriteLoop :: DriverObject -> IO ()+driverWriteLoop driver_object =+    do hFlush stdout+       (mapM_ B.putStrLn =<<) $ atomically $+           do writes <- readTVar (driver_outgoing driver_object)+              writeTVar (driver_outgoing driver_object) $ Right []+              case writes of+                  Left destructive ->+                      do writeTVar (driver_cached_lines driver_object) Set.empty+                         writeTVar (driver_actions driver_object) . succ =<<+                             readTVar (driver_actions driver_object)+                         return [destructive]+                  Right queries ->+                      do when (List.null queries) retry+                         return $ reverse queries++driverErrorLoop :: DriverObject -> IO ()+driverErrorLoop driver_object =+    do hFlush stderr+       (mapM_ (B.hPutStrLn stderr) =<<) $ atomically $+           do errs <- readTVar (driver_errors driver_object)+              when (List.null errs) retry+              writeTVar (driver_errors driver_object) []+              return $ reverse errs++-- | Just read from the engine.  Whenever 'driverRead' reads an "over", it+-- automatically fires off 'interpretText' to parse the newly read information.+driverReadLoop :: DriverObject -> IO ()+driverReadLoop driver_object =+    do str <- B.getLine+       t <- getTime+       atomically $+           do updateTime driver_object t+              readses <- readTVar (driver_incomming driver_object)+              writeTVar (driver_incomming driver_object) $ str : readses+              when (str == "over") $ interpretText driver_object++-- | A class for DriverObjects.+class DriverClass a where+    -- | Retrieves an answer from the engine.  An answer is a single string.+    getAnswer :: a -> B.ByteString -> STM (Maybe B.ByteString)+    -- | Retrieves a table from the engine.  These tables make up a kind of+    -- simple relational database.+    getTable :: a -> B.ByteString -> B.ByteString -> STM (Maybe RoguestarTable)++instance DriverClass DriverObject where+    getAnswer driver_object query =+        do driverQuery driver_object [query]+           restate <- readTVar (driver_engine_state driver_object)+           getAnswer restate query+    getTable driver_object the_table_name the_table_id =+        do driverQuery driver_object [the_table_name,the_table_id]+           restate <- readTVar (driver_engine_state driver_object)+           getTable restate the_table_name the_table_id++instance DriverClass RoguestarEngineState where+    getAnswer restate query = return $+        Map.lookup query $ restate_answers restate+    getTable restate the_table_name the_table_id = return $+        (Map.lookup (the_table_name,the_table_id)) $ restate_tables restate++instance DriverClass FrozenDriver where+    getAnswer (FrozenDriver driver_object restate acts _) query =+        do result <- getAnswer restate query+           when (isNothing result) $+               do current_actions <- readTVar (driver_actions driver_object)+                  when (current_actions == acts) $+                      getAnswer driver_object query >> return ()+           return result+    getTable (FrozenDriver driver_object restate acts _)+             the_table_name the_table_id =+        do result <- getTable restate the_table_name the_table_id+           when (isNothing result) $+               do current_actions <- readTVar (driver_actions driver_object)+                  when (current_actions == acts) $+                      getTable driver_object the_table_name the_table_id >>+                          return ()+           return result++-- | Transmits a read-only query against the state of the engine.+driverSendLossy :: DriverObject -> [B.ByteString] -> STM ()+driverSendLossy driver_object query =+    do cached_lines <- readTVar (driver_cached_lines driver_object)+       when (not $ query `Set.member` cached_lines) $+           do writes <- either (const retry) return =<<+                  readTVar (driver_outgoing driver_object)+              writeTVar (driver_outgoing driver_object) $+                  Right $ B.unwords query : writes+              writeTVar (driver_cached_lines driver_object) $+                  Set.insert query cached_lines++-- | Commit a destructive action to the engine.+driverSendDestructive :: DriverObject ->+                     [B.ByteString] ->+                     STM ()+driverSendDestructive driver_object strs =+    do _ <- either (const retry) return =<<+           readTVar (driver_outgoing driver_object)+       writeTVar (driver_engine_state driver_object) $+           RoguestarEngineState Map.empty Map.empty+       writeTVar (driver_outgoing driver_object) $ Left $+           B.unwords strs++-- | Transmits a read-only query against the state of the engine.+driverSendError :: DriverObject -> B.ByteString -> STM ()+driverSendError driver_object err =+    writeTVar (driver_errors driver_object) . (err:) =<<+        readTVar (driver_errors driver_object)++-- | Get an immutable driver.  This driver still echoes requests+-- to it's parent driver.+freezeDriver :: DriverObject -> STM FrozenDriver+freezeDriver driver_object =+    do restate <- readTVar (driver_engine_state driver_object)+       actions <- readTVar (driver_actions driver_object)+       dones <- readTVar (driver_dones driver_object)+       return $ FrozenDriver driver_object restate actions dones++-- | Not strictly necessary, you can use the original.+thawDriver :: FrozenDriver -> DriverObject+thawDriver (FrozenDriver driver_object _ _ _) = driver_object++-- | Number of times 'done' has been received from the engine.+driverDones :: FrozenDriver -> STM Integer+driverDones (FrozenDriver _ _ _ dones) = return dones++-- | Issue a \"driver query\" to the engine.+driverQuery :: DriverObject -> [B.ByteString] -> STM ()+driverQuery driver_object query = driverSendLossy driver_object $+                                      "game":"query":query++-- | Commit a \"driver action\" to the engine.+driverAction :: DriverObject -> [B.ByteString] -> STM ()+driverAction driver_object query = driverSendDestructive driver_object $+                                      "game":"action":query++-- | Issue a no-op to the engine..+driverNoop :: DriverObject -> STM ()+driverNoop driver_object = driverSendDestructive driver_object ["noop"]++{-------------------------------------------------------------------------------+ -  This is the parser.+ - ----------------------------------------------------------------------------}++data DriverInterpretationState = DINeutral+                               | DIScanningTable RoguestarTable+                               | DIError+                               deriving (Eq,Show)++-- | Parse 'driver_engine_input_lines'.+interpretText :: DriverObject -> STM ()+interpretText driver_object =+    do final_state <- foldM (interpretLine driver_object) DINeutral =<<+           liftM reverse (readTVar $ driver_incomming driver_object)+       when (final_state /= DINeutral) $+           do driverSendError driver_object+                  "interpretText concluded in a non-neutral state, which was:"+              driverSendError driver_object $ B.pack $ show final_state+       writeTVar (driver_incomming driver_object) []++-- | 'interpretLine' is a simple line-by-line parser invoked using 'foldM'.+interpretLine :: DriverObject ->+                 DriverInterpretationState ->+                 B.ByteString ->+                 STM DriverInterpretationState+interpretLine _ DIError _ = return DIError++-- Ignore empty lines.+interpretLine _ di_state str | List.null (B.words str) = do return di_state++-- Report errors.  \"protocol-error\" means that engine believes that we screwed+-- up.  \"error\" means that the engine admits it screwed up.+interpretLine driver_object _ str | (head $ B.words str) `elem`+                                    ["protocol-error:", "error:"] =+    do driverSendError driver_object str+       return DIError++-- Engine acknowledges completed database update.+interpretLine driver_object DINeutral "done" =+    do writeTVar (driver_engine_state driver_object) $+           RoguestarEngineState Map.empty Map.empty+       writeTVar (driver_dones driver_object) . succ =<<+           readTVar (driver_dones driver_object)+       return DINeutral++interpretLine driver_object di_state "done" =+    do driverSendError driver_object $+           "Driver raised protocol error: unexpected \"done\" in " `B.append`+               (B.pack $ show di_state) `B.append` " state."+       return DIError++-- Engine is finished answering a query or action.+-- (But it may continue to spew answers to other queries.)+interpretLine _ DINeutral "over" = return DINeutral++interpretLine driver_object (DIScanningTable {}) "over" =+    do driverSendError driver_object $+           "Driver raised protocol error: 'over' issued while reading a data table"+       return DIError++-- Engine is answering a question.+interpretLine driver_object DINeutral str+        | ["answer:",key,value] <- B.words str =+    do engine_state <- readTVar (driver_engine_state driver_object)+       writeTVar (driver_engine_state driver_object) $+           engine_state {+               restate_answers = Map.insert key value+                                 (restate_answers engine_state) }+       return DINeutral++-- Engine is opening a new table.+interpretLine driver_object DINeutral str+        | ("begin-table":tname:tid:theaders) <- B.words str+        , not (List.null theaders) =+    do t <- readTVar (driver_time driver_object)+       return $ DIScanningTable $ RoguestarTable {+           table_created = t,+           table_name = tname,+           table_id = tid,+           table_header = theaders,+           table_data = [] }++interpretLine driver_object _ str | (head $ B.words str) == "begin-table" =+    do driverSendError driver_object+           "Driver raised protocol error: incomplete begin-table header"+       return DIError++-- Engine is closing a table.+interpretLine driver_object (DIScanningTable table) str+        | (head $ B.words str) == "end-table" =+    do engine_state <- readTVar (driver_engine_state driver_object)+       writeTVar (driver_engine_state driver_object) $+           engine_state { restate_tables =+               Map.insert (table_name table, table_id table)+                   (table { table_data = reverse $ table_data table }) $+                       restate_tables engine_state }+       return DINeutral++-- Inside an open table, read a single row of that table.+interpretLine driver_object (DIScanningTable table) str =+    let table_row = B.words str+        in (if length table_row == (length $ table_header table)+        then return $ DIScanningTable (table {+                 table_data = table_row : table_data table })+        else do driverSendError driver_object+                    "Driver raised protocol error: malformed table row"+                return DIError )++-- If we don't know what else to do, just print to stderr.+interpretLine driver_object _ str =+    do driverSendError driver_object str+       return DINeutral+
− src/Driver.lhs 
@@ -1,237 +0,0 @@-\section{Driver}--\begin{code}-module Driver-    (DriverObject,-     driverNoop,-     newDriverObject,-     driverRead,-     driverGetAnswer,-     driverGetTable,-     driverAction)-    where--import Data.Maybe-import Control.Monad-import Data.IORef-import Data.List-import System.IO-import Tables-import RSAGL.Time--data RoguestarEngineState = RoguestarEngineState { -    restate_tables :: [RoguestarTable], -    restate_answers :: [(String,String)] }--data DriverData = DriverData {-	driver_engine_input_lines :: [String],-	driver_engine_input_line_fragment :: String,-	driver_engine_output_lines :: [String],-	driver_engine_state :: RoguestarEngineState,-	driver_dones :: Integer }--newtype DriverObject = DriverObject (IORef DriverData)--newDriverObject :: IO DriverObject-newDriverObject = liftM DriverObject $ newIORef initial_driver_data--initial_driver_data :: DriverData-initial_driver_data = DriverData {-    driver_engine_input_lines = [],-    driver_engine_input_line_fragment = [],-    driver_engine_output_lines = [],-    driver_engine_state = RoguestarEngineState [] [],-    driver_dones = 0 }--driverGet :: DriverObject -> (DriverData -> a) -> IO a-driverGet (DriverObject ioref) f = liftM f $ readIORef ioref--modifyDriver :: DriverObject -> (DriverData -> DriverData) -> IO () -modifyDriver (DriverObject ioref) f = modifyIORef ioref f-\end{code}--\begin{code}-driverNoop :: DriverObject -> IO ()-driverNoop driver_object = driverWrite driver_object "noop\n"-\end{code}--\subsection{Getting Protocol Answers}--\texttt{driverGetAnswer} retrieves an answer from the engine.  An answer is a single string.--\begin{code}-driverGetAnswer :: DriverObject -> String -> IO (Maybe String)-driverGetAnswer driver_object query =-    do driverQuery driver_object [query]-       driverGet driver_object (lookup query . restate_answers . driver_engine_state)-\end{code}--\subsection{Getting Protocol Tables}--\testtt{driverGetTable} retrieves a table from the engine.  These tables make up a kind of simple relational database.--\begin{code}-driverGetTable :: DriverObject -> String -> String -> IO (Maybe RoguestarTable)-driverGetTable driver_object the_table_name the_table_id =-    do driverQuery driver_object [the_table_name,the_table_id]-       driverGet driver_object (find (\x -> table_name x == the_table_name && table_id x == the_table_id) . restate_tables . driver_engine_state)-\end{code}--\texttt{driverQuery} transmits a read-only query against the state of the engine.--\begin{code}-driverQuery :: DriverObject -> [String] -> IO ()-driverQuery driver_object query = driverWrite driver_object $ "game query " ++ unwords query ++ "\n"-\end{code}--\begin{code}-driverAction :: DriverObject -> [String] -> IO ()-driverAction driver_object strs = -    do modifyDriver driver_object $ \driver -> driver { driver_engine_state = RoguestarEngineState [] []}-       driverWrite driver_object $ "game action " ++ unwords strs ++ "\n"-\end{code}--\texttt{driverWrite} writes the specified command to standard output, automatically interleaving calls to read.-\texttt{driverWrite} will never write the same string twice between calls to \texttt{driverReset}.--\begin{code}-driverWrite :: DriverObject -> String -> IO ()-driverWrite driver_object str = -    do already_sent <- driverGet driver_object (elem str . driver_engine_output_lines)-       unless already_sent $-           do modifyDriver driver_object $ \driver -> driver { driver_engine_output_lines=str:driver_engine_output_lines driver }-              driverWrite_ driver_object str-       driverRead driver_object--driverWrite_ :: DriverObject -> String -> IO ()-driverWrite_ driver_object "" = -    do hFlush stdout-       driverRead driver_object-driverWrite_ driver_object str = -    do driverRead driver_object-       putChar $ head str-       --hPutChar stderr $ head str -- uncomment to see everything we write in stderr-       driverWrite_ driver_object $ tail str-\end{code}--\texttt{maybeRead} reads one character if it is available.--\begin{code}-maybeRead :: IO (Maybe Char)-maybeRead = do ready <- hReady stdin-	       case ready of-			  False -> return Nothing-			  True -> do char <- getChar-				     return $ Just char-\end{code}--\texttt{driverRead} reads, parses, and stores data from the engine.--\begin{code}-driverRead :: DriverObject -> IO ()-driverRead driver_object = -    do maybe_next_char <- maybeRead-       case maybe_next_char of-           Nothing -> return ()-           Just '\n' -> do modifyDriver driver_object-                               (\driver -> driver { driver_engine_input_lines= -                                                    (reverse $ driver_engine_input_line_fragment driver) :-                                                    driver_engine_input_lines driver,-                                                    driver_engine_input_line_fragment=""});-                           driverUpdate driver_object-           Just next_char -> modifyDriver driver_object -                                          (\driver -> driver { driver_engine_input_line_fragment=(next_char : -                                                                                                  driver_engine_input_line_fragment driver) })-       when (isJust maybe_next_char) $ do --hPutChar stderr $ fromJust maybe_next_char -- uncomment to see everything we read in stderr-                                          driverRead driver_object-\end{code}--\texttt{driverUpdate} parses stored information in the driver, generating answers and tables.--\begin{code}-driverUpdate :: DriverObject -> IO ()-driverUpdate driver_object =-    do head_line <- driverGet driver_object (head . driver_engine_input_lines)-       when (head_line == "over") $ interpretText driver_object--data DriverInterpretationState = DINeutral-			       | DIScanningTable RoguestarTable-			       | DIError-				 deriving (Eq,Show)--interpretText :: DriverObject -> IO ()-interpretText driver_object = -    do final_state <- foldM (interpretLine driver_object) DINeutral =<< driverGet driver_object (reverse . driver_engine_input_lines)-       when (final_state /= DINeutral) $ do hPutStr stderr "interpretText concluded in a non-neutral state, which was:"-					    hPutStr stderr (show final_state)-					    modifyDriver driver_object $ \driver -> initial_driver_data { -					        driver_dones = driver_dones driver,-						driver_engine_state = driver_engine_state driver }-       modifyDriver driver_object $ \driver -> driver { driver_engine_input_lines = [] }--modifyEngineState :: DriverObject -> (RoguestarEngineState -> RoguestarEngineState) -> IO ()-modifyEngineState driver_object f = modifyDriver driver_object $ \driver -> driver { driver_engine_state = f $ driver_engine_state driver } --interpretLine :: DriverObject -> DriverInterpretationState -> String -> IO DriverInterpretationState-interpretLine _ DIError _ = return DIError--interpretLine _ di_state "" = do return di_state -- ignore empty lines--interpretLine _ _ str | (head $ words str) == "protocol-error:" = -    do hPutStr stderr str-       return DIError--interpretLine _ _ str | (head $ words str) == "error:" = -    do hPutStr stderr str-       return DIError--interpretLine driver_object DINeutral "done" =-    do modifyDriver driver_object $ \driver -> driver { driver_engine_state = RoguestarEngineState [] [],-		   			                driver_engine_output_lines = [],-					                driver_dones = driver_dones driver + 1 }-       return DINeutral--interpretLine _ di_state "done" = -    do hPutStr stderr  ("client-side protocol error: unexpected \"done\" in " ++ (show di_state) ++ " state.")-       return DIError--interpretLine _ DINeutral "over" = return DINeutral--interpretLine _ (DIScanningTable {}) "over" = -    do hPutStr stderr "client-side protocol error: 'over' issued while reading a data table"-       return DIError--interpretLine driver_object DINeutral str | (head $ words str) == "answer:" && (length $ words str) == 3 =-    do modifyEngineState driver_object (\engine_state -> engine_state { restate_answers = (words str !! 1,words str !! 2):restate_answers engine_state })-       return DINeutral--interpretLine _ DINeutral str | (head $ words str) == "begin-table" && (length $ words str) > 3 = -    do t <- getTime-       let table_start_data = words str-       return $ DIScanningTable $ RoguestarTable {-						  table_created = t,-				                  table_name = table_start_data !! 1,-		                                  table_id = table_start_data !! 2,-		                                  table_header = drop 3 table_start_data,-                                                  table_data = []}--interpretLine _ _ str | (head $ words str) == "begin-table" =-    do hPutStr stderr "client-side protocol error: incomplete begin-table header"-       return DIError--interpretLine driver_object (DIScanningTable table) str | (head $ words str) == "end-table" =-  do modifyEngineState driver_object (\engine_state -> engine_state { restate_tables = (table { table_data=reverse $ table_data table}):restate_tables engine_state })-     return DINeutral--interpretLine _ (DIScanningTable table) str = -    let table_row = words str-        in (if length table_row == (length $ table_header table)-	then return $ DIScanningTable (table { table_data = table_row : table_data table })-	else do hPutStr stderr "client-side protocol error: malformed table row"-		return DIError )--interpretLine _ _ str = -    do hPutStr stderr str-       return DINeutral--\end{code}
src/Keymaps/CommonKeymap.hs view
@@ -1,59 +1,42 @@+{-# LANGUAGE OverloadedStrings #-}+ module Keymaps.CommonKeymap-    (commonMovementKeymap,MovementKeymap(..),common_keymap)+    (common_keymap)     where -import Data.Char- import Keymaps.Keymaps -data MovementKeymap = MovementKeymap {-    mk_n, mk_s, mk_e, mk_w, mk_nw, mk_ne, mk_sw, mk_se :: String }--commonMovementKeymap :: MovementKeymap -> Keymap-commonMovementKeymap mk = [- (mk_n mk,"move-n"),- (mk_s mk,"move-s"),- (mk_e mk,"move-e"),- (mk_w mk,"move-w"),- (mk_nw mk,"move-nw"),- (mk_ne mk,"move-ne"),- (mk_sw mk,"move-sw"),- (mk_se mk,"move-se"),- (">t" ++ mk_n mk,"turn-n"),- (">t" ++ mk_s mk,"turn-s"),- (">t" ++ mk_e mk,"turn-e"),- (">t" ++ mk_w mk,"turn-w"),- (">t" ++ mk_nw mk,"turn-nw"),- (">t" ++ mk_ne mk,"turn-ne"),- (">t" ++ mk_sw mk,"turn-sw"),- (">t" ++ mk_se mk,"turn-se"),- (">f" ++ mk_n mk,"fire-n"),- (">f" ++ mk_s mk,"fire-s"),- (">f" ++ mk_e mk,"fire-e"),- (">f" ++ mk_w mk,"fire-w"),- (">f" ++ mk_nw mk,"fire-nw"),- (">f" ++ mk_ne mk,"fire-ne"),- (">f" ++ mk_sw mk,"fire-sw"),- (">f" ++ mk_se mk,"fire-se")]- common_keymap :: Keymap common_keymap = [- (":move-n","move-n"),- (":move-s","move-s"),- (":move-w","move-w"),- (":move-e","move-e"),- (":move-nw","move-nw"),- (":move-ne","move-ne"),- (":move-sw","move-sw"),- (":move-se","move-se"),- (":turn-n","turn-n"),- (":turn-s","turn-s"),- (":turn-w","turn-w"),- (":turn-e","turn-e"),- (":turn-nw","turn-nw"),- (":turn-ne","turn-ne"),- (":turn-sw","turn-sw"),- (":turn-se","turn-se"),+ (":north","n"),+ (":northeast","ne"),+ (":east","e"),+ (":southeast","sw"),+ (":south","s"),+ (":southwest","sw"),+ (":west","w"),+ (":northwest","nw"),+ (":escape","escape"),+ (":next","next"),+ (":prev","prev"),+ ("\n","select-menu"),+ ("\r","select-menu"),+ (">:::KeyDown","next"),+ (">:::KeyUp","prev"),+ ("\ESC","normal"),+ (":move","move"),+ ("t","turn"),+ (":turn","turn"),+ ("J","jump"),+ (":jump","jump"),+ ("F","attack"),+ (":attack","attack"),+ ("f","fire"),+ (":fire","fire"),+ ("c","clear-terrain"),+ (":clear-terrain","clear-terrain"),+ ("a","activate"),+ (":activate","activate"),  ("x","anachronid"),  (":anachronid","anachronid"),  ("a","androsynth"),@@ -102,7 +85,26 @@  (":thief","thief"),  ("w","warrior"),  (":warrior","warrior"),+ ("m","make-begin"),+ ("p","pistol"),+ (":pistol","pistol"),+ ("c","carbine"),+ (":carbine","carbine"),+ ("r","rifle"),+ (":rifle","rifle"),+ ("f","fleuret"),+ (":fleuret","fleuret"),+ ("s","sabre"),+ (":sabre","sabre"),+ ("\n","make-end"),+ ("\r","make-end"),  ("#quit","quit"),+ ("#sky-on","sky-on"),+ ("#sky-off","sky-off"),+ ("#quality-1","quality-bad"),+ ("#quality-2","quality-poor"),+ ("#quality-3","quality-good"),+ ("#quality-4","quality-super"),  (",","pickup"),  (":pickup","pickup"),  ("d","drop"),@@ -111,12 +113,8 @@  (":wield","wield"),  ("-","unwield"),  (":unwield","unwield"),- (":fire-n","fire-n"),- (":fire-s","fire-s"),- (":fire-w","fire-w"),- (":fire-e","fire-e"),- (":fire-new","fire-nw"),- (":fire-ne","fire-ne"),- (":fire-sw","fire-sw"),- (":fire-se","fire-sw"),- (":continue","continue")]+ (":continue","continue"),+ ("]","zoom-in"),+ (":zoom-in","zoom-in"),+ ("[","zoom-out"),+ (":zoom-out","zoom-out")]
+ src/Keymaps/Keymaps.hs view
@@ -0,0 +1,89 @@+-- | 'Keymap's are simple mappings from a sequence of keystrokes to the+-- names of various commands.+{-# LANGUAGE OverloadedStrings #-}++module Keymaps.Keymaps+    (Keymap,+     KeymapName,+     fixKeymap,+     filterKeySequence,+     keysToActionNames,+     actionNameToKeys)+    where++import Actions+import Data.List+import Control.Monad+import Control.Concurrent.STM+import qualified Data.ByteString.Char8 as B++type Keymap = [(B.ByteString,B.ByteString)]+type KeymapName = String++-- 'fixKeymap' processes a keymap to make it usable, by:+-- * removing erroneous whitespace+-- * placing \\n and \\r at the end of multi-key keystrokes that should be+--   activated via the enter key.+-- * passing keystrokes that begin with the escape character '>' as raw+--   keystrokes.++fixKeymap :: Keymap -> Keymap+fixKeymap = concatMap $ \(keystrokes,action_name) ->+    case () of+        () | B.null keystrokes -> []+        () | B.length keystrokes == 1 -> [(keystrokes,action_name)]+        () | B.head keystrokes == '>' ->+                 [(B.drop 1 keystrokes,action_name)]+        () -> let fixed_keystrokes =+                      B.concat $ intersperse "-" $ B.words keystrokes+                  in [(fixed_keystrokes `B.append` "\r",action_name),+                      (keystrokes `B.append` "\n",action_name)]++-- | 'validKeyMap' reduces a 'Keymap' to one that contains only those actions+-- that are valid at the instant of the atomic transaction.+validKeyMap :: ActionInput -> Keymap -> STM [(B.ByteString,B.ByteString)]+validKeyMap action_input raw_keymap =+    do valid_actions <- getValidActions action_input Nothing+       return $ filter (\x -> snd x `elem` valid_actions) raw_keymap++-- | 'filterKeySequence' transforms a key sequence, providing services such as:+-- * blanking the input buffer is there is no possible completion+-- * performing tab complation+filterKeySequence :: ActionInput -> Keymap -> B.ByteString -> STM B.ByteString+filterKeySequence _ _ key_sequence | (length $ B.words key_sequence) /= 1 = return ""+filterKeySequence action_input keymap key_sequence =+    do valid_key_map <- validKeyMap action_input keymap+       let is_tab_key_completion = B.last key_sequence == '\t'+       let stripped_key_sequence = B.unwords $ B.words key_sequence+       let possible_completions =+               filter (\x -> elem stripped_key_sequence $ B.inits x) $+                   map fst $ valid_key_map+       return $ case length possible_completions of+           -- if there are no possible completions, clear the buffer+           0 -> ""+           -- if the trailing input isn't a tab, chill+           _ | not is_tab_key_completion -> stripped_key_sequence+           -- if there's only one completion, get it, but strip+           -- the trailing return in case they didn't want+           -- to exec that completion.+           1 -> if key_sequence /= head possible_completions+                    then B.init $ head possible_completions+                    else key_sequence+           -- get the best completion we can find+           _ -> maximumBy (\x y -> compare (B.length x) (B.length y)) $+                    foldr1 intersect $ map B.inits possible_completions++-- | 'keysToActionNames' gets a list of the names of all action that could be+-- executed by the given key sequence at this instant.  A null result+-- indicates that the key sequence isn't a valid command.  A result with more+-- than one element indicates a collision in the key map, which is an error.++keysToActionNames :: ActionInput -> Keymap -> B.ByteString -> STM [B.ByteString]+keysToActionNames action_input keymap key_sequence =+    liftM (map snd . filter (\x -> fst x == key_sequence)) $ validKeyMap action_input keymap ++-- 'actionNameToKeys' provides reverse lookup versus keysToActionNames.+actionNameToKeys :: ActionInput -> Keymap -> B.ByteString -> STM [B.ByteString]+actionNameToKeys action_input keymap action_name =+    liftM (map fst . filter (\x -> snd x == action_name)) $ validKeyMap action_input keymap+
− src/Keymaps/Keymaps.lhs 
@@ -1,77 +0,0 @@-\section{Keymaps}--\texttt{Keymap}s are simple mappings from a sequence of keystrokes to the names of various commands.--\begin{code}-module Keymaps.Keymaps-    (Keymap,-     KeymapName,-     fixKeymap,-     filterKeySequence,-     keysToActionNames,-     actionNameToKeys)-    where--import Actions-import Data.List-import Control.Monad--type Keymap = [(String,String)]-type KeymapName = String-\end{code}--\texttt{fixKeymap} processes a keymap to make it usable.  If you type in a multi-character command and it executes before you press enter,-you forgot to use \texttt{fixKeymap}.--\begin{code}-fixKeymap :: Keymap -> Keymap-fixKeymap = concatMap $ \(x,y) -> -    case x of-        [c] -> [([c],y)]-	('>':keystrokes) | (not $ null keystrokes) -> [(keystrokes,y)]-	command -> let keystrokes = concat $ intersperse "-" $ words command in [(keystrokes ++ "\r",y),(keystrokes ++ "\n",y)]-\end{code}--\texttt{validKeyMap} reduces a \texttt{Keymap} to one that contains only those actions that are valid at this instant.--\begin{code}-validKeyMap :: ActionInput -> Keymap -> IO [(String,String)]-validKeyMap action_input raw_keymap =-    do valid_actions <- getValidActions action_input Nothing-       return $ filter (\x -> snd x `elem` valid_actions) raw_keymap-\end{code}--\texttt{filterKeySequence} transforms a key sequence into either the empty string, if it isn't the prefix of any valid action,-or completes the key sequence if it is the prefix of exactly one valid action.--\begin{code}-filterKeySequence :: ActionInput -> Keymap -> String -> IO String-filterKeySequence _ _ key_sequence | (length $ words key_sequence) == 0 = return ""-filterKeySequence action_input keymap key_sequence =-    do valid_key_map <- validKeyMap action_input keymap-       let possible_completions = filter (\x -> elem key_sequence $ inits x) $ map fst $ valid_key_map-       return $ case length possible_completions of-		 0 -> ""-		 1 -> if key_sequence /= head possible_completions-		      then init $ head possible_completions-		      else key_sequence-		 _ -> maximumBy (\x -> \y -> compare (length x) (length y)) $ foldr1 intersect $ map inits possible_completions-\end{code}--\texttt{keysToActionNames} gets a list of the names of all action that could be exected by the given key sequence at this instant.-A result of zero indicates that the key sequence isn't a valid command.  A result with more than one element indicates-a collision in the key map, which is an error.--\begin{code}-keysToActionNames :: ActionInput -> Keymap -> String -> IO [String]-keysToActionNames action_input keymap key_sequence = -    liftM (map snd . filter (\x -> fst x == key_sequence)) $ validKeyMap action_input keymap -\end{code}--\texttt{actionNameToKeys} provides reverse lookup versus keysToActionNames.--\begin{code}-actionNameToKeys :: ActionInput -> Keymap -> String -> IO [String]-actionNameToKeys action_input keymap action_name = -    liftM (map fst . filter (\x -> snd x == action_name)) $  validKeyMap action_input keymap-\end{code}
src/Keymaps/NumpadKeymap.hs view
@@ -1,21 +1,21 @@+{-# LANGUAGE OverloadedStrings #-}+ module Keymaps.NumpadKeymap-    (numpad_movement_keymap,numpad_keymap)+    (numpad_keymap)     where  import Keymaps.CommonKeymap import Keymaps.Keymaps -numpad_movement_keymap :: MovementKeymap-numpad_movement_keymap = MovementKeymap {-    mk_n = "8",-    mk_s = "2",-    mk_w = "4",-    mk_e = "6",-    mk_nw = "7",-    mk_ne = "9",-    mk_sw = "1",-    mk_se = "3" }- numpad_keymap :: Keymap-numpad_keymap =-   commonMovementKeymap numpad_movement_keymap ++ common_keymap+numpad_keymap = common_keymap +++    [("8","n"),+     ("2","s"),+     ("4","w"),+     ("6","e"),+     ("7","nw"),+     ("9","ne"),+     ("1","sw"),+     ("3","se"),+     ("8","prev"),+     ("2","next")]
src/Keymaps/VIKeymap.hs view
@@ -1,21 +1,21 @@+{-# LANGUAGE OverloadedStrings #-}+ module Keymaps.VIKeymap-    (vi_movement_keymap,vi_keymap)+    (vi_keymap)     where  import Keymaps.Keymaps import Keymaps.CommonKeymap -vi_movement_keymap :: MovementKeymap-vi_movement_keymap = MovementKeymap {-    mk_n = "k",-    mk_s = "j",-    mk_w = "h",-    mk_e = "l",-    mk_nw = "y",-    mk_ne = "u",-    mk_sw = "b",-    mk_se = "n" }- vi_keymap :: Keymap-vi_keymap =-   commonMovementKeymap vi_movement_keymap ++ common_keymap+vi_keymap = common_keymap +++    [("k","n"),+     ("j","s"),+     ("h","w"),+     ("l","e"),+     ("y","nw"),+     ("u","ne"),+     ("b","sw"),+     ("n","se"),+     ("j","next"),+     ("k","prev")]
+ src/Limbs.hs view
@@ -0,0 +1,122 @@+{-# LANGUAGE Arrows, OverloadedStrings, TypeFamilies #-}++module Limbs+    (bothArms,+     bothLegs)+    where++import VisibleObject+import Animation+import RSAGL.Animation+import RSAGL.Math+import Models.LibraryData+import Control.Arrow+import RSAGL.Scene+import RSAGL.FRP+import EventUtils+import RSAGL.Types++-- | Animate an arbitrary articulated joint.+libraryJointAnimation :: (FRPModel m, StateOf m ~ AnimationState) => RSdouble -> LibraryModel -> LibraryModel -> FRP e m Joint ()+libraryJointAnimation maximum_length upper lower = proc joint_info ->+    jointAnimation (proc () -> transformA libraryA -< (Affine $ scale' (maximum_length/2),(std_scene_layer_local,upper)))+                   (proc () -> transformA libraryA -< (Affine $ scale' (maximum_length/2),(std_scene_layer_local,lower))) -< +		       joint_info++-- | Animate an articulated joint holding constant the bend vector and arm length.+arm :: (FRPModel m, StateOf m ~ AnimationState) => LibraryModel -> LibraryModel -> Vector3D -> RSdouble -> FRP e m (Point3D,Point3D) Joint+arm arm_upper arm_lower bend_vector maximum_length = proc (shoulder_point,hand_point) ->+    do let joint_info = joint bend_vector shoulder_point maximum_length hand_point+       libraryJointAnimation maximum_length arm_upper arm_lower -< joint_info +       returnA -< joint_info++-- | Animate a right arm.  This animation is aware of what tool the current creature (based on thread ID) is holding and raises the arm forward+-- while holding any tool.+rightArm :: (FRPModel m, StateOf m ~ AnimationState, ThreadIDOf m ~ Maybe Integer) => LibraryModel -> LibraryModel -> Vector3D -> Point3D -> RSdouble -> Point3D -> FRP e m () Joint+rightArm arm_upper arm_lower bend_vector shoulder_anchor maximum_length hand_rest = proc () ->+    do m_time_recent_attack <- recentAttack ThisObject -< ()+       t_now <- threadTime -< ()+       m_tool_type <- objectDetailsLookup (WieldedTool ThisObject) "tool-type" -< () +       is_wielding <- isWielding ThisObject -< ()+       hand_point <- approachA 0.1 (perSecond 1.0) -< case m_time_recent_attack of+           Just t  | t_now < t `add` fromSeconds 0.5 && m_tool_type == Just "sword" -> translate (Vector3D maximum_length 0 0) shoulder_anchor+           Just t  | t_now < t `add` fromSeconds 0.3 && m_tool_type == Nothing -> translate (Vector3D 0 0 $ maximum_length / 4) shoulder_anchor+           Just t  | t_now < t `add` fromSeconds 1.0 && m_tool_type == Nothing -> translate (Vector3D 0 0 maximum_length) shoulder_anchor+           _       | is_wielding -> translate (Vector3D 0 0 maximum_length) shoulder_anchor+	   _       | otherwise   -> hand_rest+       arm arm_upper arm_lower bend_vector maximum_length -< (shoulder_anchor,hand_point)++-- | Animate a left arm, which is always held at the side.+leftArm :: (FRPModel m, StateOf m ~ AnimationState, ThreadIDOf m ~ Maybe Integer) => LibraryModel -> LibraryModel -> Vector3D -> Point3D -> RSdouble -> Point3D -> FRP e m () Joint+leftArm arm_upper arm_lower bend_vector shoulder_anchor maximum_length hand_rest = +    proc () -> arm arm_upper arm_lower bend_vector maximum_length -< (shoulder_anchor,hand_rest)++-- | Animate two arms.  The parameters describe the right arm, and are swapped across the yz plane to produce left arm parameters.+bothArms :: (FRPModel m,+             StateOf m ~ AnimationState,+             ThreadIDOf m ~ Maybe Integer,+             LibraryModelSource lm1,+             LibraryModelSource lm2) =>+     lm1 ->+     lm2 ->+     Vector3D ->+     Point3D ->+     RSdouble ->+     Point3D ->+     FRP e m () (Joint,Joint)+bothArms arm_upper+         arm_lower+         bend_vector+         shoulder_anchor+         maximum_length+         hand_rest = proc () ->+    do left_joint <- leftArm (toLibraryModel arm_upper)+                             (toLibraryModel arm_lower)+                             (swapX bend_vector)+                             (swapX shoulder_anchor)+                             maximum_length+                             (swapX hand_rest) -< ()+       right_joint <- rightArm (toLibraryModel arm_upper)+                               (toLibraryModel arm_lower)+                               bend_vector+                               shoulder_anchor+                               maximum_length+                               hand_rest -< ()+       returnA -< (left_joint,right_joint)++-- | Animate legs, which automatically know how to take steps when moved.+bothLegs :: (FRPModel m,+             StateOf m ~ AnimationState,+             LibraryModelSource lm1,+             LibraryModelSource lm2) =>+    lm1 ->+    lm2 ->+    Vector3D ->+    Point3D ->+    RSdouble ->+    Point3D ->+    FRP e m () ()+bothLegs leg_upper+         leg_lower+         bend_vector+         hip_anchor+         maximum_length+         foot_rest = proc () ->+    do legs [leg bend_vector+                 hip_anchor+                 maximum_length+                 foot_rest+                 (libraryJointAnimation maximum_length+                                        (toLibraryModel leg_upper)+                                        (toLibraryModel leg_lower)),+             leg bend_vector+                 (swapX hip_anchor)+                 maximum_length+                 (swapX foot_rest)+                 (libraryJointAnimation maximum_length+                                        (toLibraryModel leg_upper)+                                        (toLibraryModel leg_lower))]+                 -< ()++swapX :: (AffineTransformable a) => a -> a+swapX = scale (Vector3D (-1.0) 1.0 1.0)
− src/Limbs.lhs 
@@ -1,66 +0,0 @@-\section{Limbs}--\begin{code}-{-# LANGUAGE Arrows #-}--module Limbs-    (rightArm,-     leftArm,-     bothArms,-     bothLegs)-    where-import VisibleObject-import Animation-import RSAGL.Joint-import RSAGL.Affine-import Models.LibraryData-import Control.Arrow-import RSAGL.Vector-import RSAGL.CoordinateSystems-import RSAGL.Scene-import RSAGL.InverseKinematics-import Data.Maybe-import RSAGL.Time--libraryJointAnimation :: Double -> LibraryModel -> LibraryModel -> RSAnimAX any t i o Joint ()-libraryJointAnimation maximum_length upper lower = proc joint_info ->-    jointAnimation (proc () -> transformA libraryA -< (Affine $ scale' (maximum_length/2),(Local,upper)))-                   (proc () -> transformA libraryA -< (Affine $ scale' (maximum_length/2),(Local,lower))) -< joint_info--arm :: LibraryModel -> LibraryModel -> Vector3D -> Double -> RSAnimAX any t i o (Point3D,Point3D) Joint-arm arm_upper arm_lower bend_vector maximum_length = proc (shoulder_point,hand_point) ->-    do let joint_info = joint bend_vector shoulder_point maximum_length hand_point-       libraryJointAnimation maximum_length arm_upper arm_lower -< joint_info -       returnA -< joint_info--rightArm :: LibraryModel -> LibraryModel -> Vector3D -> Point3D -> Double -> Point3D -> RSAnimA (Maybe Integer) i o () Joint-rightArm arm_upper arm_lower bend_vector shoulder_anchor maximum_length hand_rest = proc () ->-    do is_wielding <- arr isJust <<< wieldedTool -< ()-       hand_point <- approachA 0.1 (perSecond 1.0) -< if is_wielding-           then translate (Vector3D 0 0 maximum_length) shoulder_anchor-	   else hand_rest-       arm arm_upper arm_lower bend_vector maximum_length -< (shoulder_anchor,hand_point)--leftArm :: LibraryModel -> LibraryModel -> Vector3D -> Point3D -> Double -> Point3D -> RSAnimA (Maybe Integer) i o () Joint-leftArm arm_upper arm_lower bend_vector shoulder_anchor maximum_length hand_rest = -    proc () -> arm arm_upper arm_lower bend_vector maximum_length -< (shoulder_anchor,hand_rest)-\end{code}--\texttt{bothArms} and \texttt{bothLegs} render two limbs by swapping the description for the right limb.--\begin{code}-bothArms :: LibraryModel -> LibraryModel -> Vector3D -> Point3D -> Double -> Point3D -> RSAnimA (Maybe Integer) i o () (Joint,Joint)-bothArms arm_upper arm_lower bend_vector shoulder_anchor maximum_length hand_rest = proc () ->-    do left_joint <- leftArm arm_upper arm_lower (swapX bend_vector) (swapX shoulder_anchor) maximum_length (swapX hand_rest) -< ()-       right_joint <- rightArm arm_upper arm_lower bend_vector shoulder_anchor maximum_length hand_rest -< ()-       returnA -< (left_joint,right_joint)--bothLegs :: LibraryModel -> LibraryModel -> Vector3D -> Point3D -> Double -> Point3D -> RSAnimA t i o () ()-bothLegs leg_upper leg_lower bend_vector hip_anchor maximum_length foot_rest = proc () ->-    do legs [leg bend_vector hip_anchor maximum_length foot_rest (libraryJointAnimation maximum_length leg_upper leg_lower),-             leg bend_vector (swapX hip_anchor) maximum_length (swapX foot_rest) (libraryJointAnimation maximum_length leg_upper leg_lower)]-	         -< ()--swapX :: (AffineTransformable a) => a -> a-swapX = scale (Vector3D (-1.0) 1.0 1.0)-\end{code}
+ src/Main.hs view
@@ -0,0 +1,145 @@+{-# 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/Main.lhs 
@@ -1,114 +0,0 @@-\section{Main}--\begin{code}-{-# LANGUAGE Arrows #-}--module Main-    (main)-    where--import System.IO-import PrintText---import Quality-import Data.Maybe-import Data.List-import Graphics.UI.GLUT-import Control.Monad-import Actions-import Keymaps.Keymaps-import CommandLine-import Keymaps.BuiltinKeymaps-import RenderingControl-import Driver---import Models.LibraryData---import Models.Library---import Camera-import Animation-import RSAGL.Scene-import Models.Library-import System.Timeout-import System.Exit--roguestar_client_version :: String-roguestar_client_version = "0.2.2"--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----qualityFromArgs :: [String] -> Quality---qualityFromArgs [] = Good---qualityFromArgs ("quality-bad":_) = Bad---qualityFromArgs ("quality-poor":_) = Poor---qualityFromArgs ("quality-good":_) = Good---qualityFromArgs ("quality-super":_) = Super---qualityFromArgs args = qualityFromArgs $ tail args--main :: IO ()-main =-    do (_, command_line) <- getArgsAndInitialize-       let command_line_options = parseCommandLine command_line-       let keymap = findKeymapOrDefault $ keymap_name command_line_options-       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-       displayCallback $= roguestarDisplayCallback lib driver_object print_text_object animation_object-       keyboardMouseCallback $= (Just $ keyCallback print_text_object)-       addTimerCallback timer_callback_millis (roguestarTimerCallback driver_object print_text_object keymap window)-       mainLoop--roguestarReshapeCallback :: Size -> IO ()-roguestarReshapeCallback (Size width height) = -    do matrixMode $= Projection-       loadIdentity-       viewport $= (Position 0 0,Size width height)--roguestarDisplayCallback :: Library -> DriverObject -> PrintTextObject -> RoguestarAnimationObject -> IO ()-roguestarDisplayCallback lib driver_object print_text_object animation_object =-  do result <- timeout 20000000 $-         do color (Color4 0 0 0 0 :: Color4 Float)-            clear [ColorBuffer]-            scene <- runRoguestarAnimationObject lib driver_object print_text_object animation_object -            (Size width height) <- get windowSize-            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 :: DriverObject -> PrintTextObject -> Keymap -> Window -> IO ()-roguestarTimerCallback driver_object print_text_object keymap window =-    do result <- timeout 20000000 $-        do addTimerCallback timer_callback_millis $ roguestarTimerCallback driver_object print_text_object keymap window-           driverRead driver_object-           postRedisplay $ Just window-           maybeExecuteKeymappedAction 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 :: DriverObject -> PrintTextObject -> Keymap -> IO ()-maybeExecuteKeymappedAction driver_object print_text_object keymap =-    do let action_input = ActionInput driver_object print_text_object-       buffer_contents <- getInputBuffer print_text_object-       actions <- keysToActionNames action_input keymap buffer_contents-       worked <- takeUserInputAction action_input actions-       if worked-           then clearInputBuffer print_text_object-	   else setInputBuffer print_text_object =<< filterKeySequence action_input keymap buffer_contents-\end{code}
src/Models/Androsynth.hs view
@@ -2,12 +2,10 @@     (androsynth)     where -import RSAGL.Affine-import RSAGL.Vector-import RSAGL.Model+import RSAGL.Math+import RSAGL.Modeling import Quality import Models.Materials-import RSAGL.ModelingExtras  androsynth_head :: Quality -> Modeling () androsynth_head _ = model $
src/Models/Ascendant.hs view
@@ -2,11 +2,9 @@     (ascendant_glow)     where -import RSAGL.Model-import RSAGL.ModelingExtras-import RSAGL.Vector+import RSAGL.Modeling+import RSAGL.Math import Quality-import RSAGL.Affine  ascendant_glow :: Quality -> Modeling () ascendant_glow _ =
src/Models/Caduceator.hs view
@@ -4,21 +4,17 @@      caduceator_arm_lower)     where -import RSAGL.Vector-import RSAGL.CurveExtras-import RSAGL.Model+import RSAGL.Math+import RSAGL.Math.CurveExtras+import RSAGL.Modeling import Quality import Models.Materials-import RSAGL.Affine-import RSAGL.Interpolation-import RSAGL.ModelingExtras-import RSAGL.Angle  caduceator :: Quality -> Modeling () caduceator _ = model $     do model $            do tube $ linearInterpolation-                  [(0.001,Point3D 0 0   (-5)),+                  [(0,Point3D 0 0   (-5)), 	           (0.5,  Point3D 0 2   (-3)), 	           (0.5,  Point3D 0 2.5 (-2)), 	           (0.5,  Point3D 0 2.5 (-1)),@@ -30,7 +26,7 @@ 	           (0.5,  Point3D 0 7     3.5), 	           (0.5,  Point3D 0 7.5   4 ), 	           (0.75, Point3D 0 7.25  5 ),-	           (0.001,Point3D 0 7   7 )]+	           (0,Point3D 0 7   7 )]               deform $ \(Point3D x y z) ->                    let x' = flip lerpMap y                         [(0,4),@@ -52,22 +48,22 @@ caduceator_arm_upper :: Quality -> Modeling () caduceator_arm_upper _ = rotate (Vector3D 1 0 0) (fromDegrees 90) $ model $     do model $ sor $ linearInterpolation $-           points2d [(0.0001,0),+           points2d [(0,0), 	             (1.0,1.0), 		     (0.5,10.0),-		     (0.0001,10.5)]+		     (0,10.5)]        caduceator_skin        affine $ scale' (1/10)  caduceator_arm_lower :: Quality -> Modeling () caduceator_arm_lower _ = rotate (Vector3D 1 0 0) (fromDegrees 90) $ model $     do model $ sor $ linearInterpolation $-           points2d [(0.0001,-0.5),+           points2d [(0,-0.5), 	             (0.5,0.0), 		     (0.25,9.0), 		     (1.25,10.0), 		     (1.0,10.25), 		     (0.75,9.75),-		     (0.0001,9)]+		     (0,9)]        caduceator_skin        affine $ scale' (1/10)
src/Models/Encephalon.hs view
@@ -3,18 +3,16 @@     where      import Quality-import RSAGL.Vector-import RSAGL.CurveExtras-import RSAGL.Model-import RSAGL.ModelingExtras+import RSAGL.Math+import RSAGL.Math.CurveExtras+import RSAGL.Modeling import Models.Materials-import RSAGL.Affine  encephalon_head :: Quality -> Modeling () encephalon_head _ = model $     do sor $ linearInterpolation $            points2d $ reverse-	            [(0.001,9),+	            [(0,9),                      (0.5,9),                      (1,9),                      (1.5,9),@@ -25,8 +23,7 @@                      (3,3)]        deform dfn        encephalon_skin-  where dfn (Point3D x y z) | y > (abs x ** 0.4) + 7.5 = Point3D x ((abs x ** 0.4) + 7.5) z -        dfn pt = pt+  where dfn (Point3D x y z) = Point3D x (min (abs x ** 4 + 7.5) y) z   encephalon_eye :: Quality -> Modeling () encephalon_eye _ = model $@@ -43,7 +40,7 @@                      (8,1),                      (8,0.5), 		     (7,0),-		     (0.001,0)]+		     (0,0)]        alliance_metal                            encephalon :: Quality -> Modeling ()
+ src/Models/Library.hs view
@@ -0,0 +1,214 @@+{-# LANGUAGE OverloadedStrings #-}++module Models.Library+    (Library,+     newLibrary,+     lookupModel)+    where++import Quality+import Data.Maybe+import Data.Map as Map+import RSAGL.Modeling hiding (model)+import Control.Concurrent.STM+import Control.Monad+import GHC.Conc+import PrioritySync.PrioritySync+import System.IO+import Control.Concurrent.MVar++import Models.LibraryData++import Models.Terrain+import Models.QuestionMark+import Models.Tree+import Models.Encephalon+import Models.Recreant+import Models.Androsynth+import Models.Ascendant+import Models.Caduceator+import Models.Reptilian+import Models.PhaseWeapons+import Models.MachineParts+import Models.Sky+import Models.CyborgType4+import Models.EnergyThings+import Models.EnergySwords+import Models.Spheres+import Models.Monolith+import Models.Stargate++-- |+-- Get the modeling data for a named library model.+--+toModel :: LibraryModel -> Quality -> Modeling ()+toModel (TerrainTile s) = terrainTile s+toModel (SimpleModel LeafyBlob) = const $ leafy_blob+toModel (SimpleModel TreeBranch) = const $ tree_branch+toModel (SkySphere sky_info) = const $ makeSky sky_info+toModel (SunDisc sun_info) = const $ makeSun sun_info+toModel (SimpleModel QuestionMark) = const $ question_mark+toModel NullModel = const $ return ()+toModel (SimpleModel Encephalon) = encephalon+toModel (SimpleModel Recreant) = recreant+toModel (SimpleModel Androsynth) = androsynth+toModel (SimpleModel Caduceator) = caduceator+toModel (SimpleModel Reptilian) = reptilian+toModel (SimpleModel AscendantGlow) = ascendant_glow+toModel (SimpleModel PhasePistol) = phase_pistol+toModel (SimpleModel Phaser) = phaser+toModel (SimpleModel PhaseRifle) = phase_rifle+toModel (SimpleModel GasSphere) = gasSphere+toModel (SimpleModel MetalSphere) = metalSphere+toModel (SimpleModel ChromaliteSphere) = chromaliteSphere+toModel (SimpleModel MachineArmLower) = machine_arm_lower+toModel (SimpleModel MachineArmUpper) = machine_arm_upper+toModel (SimpleModel CaduceatorArmLower) = caduceator_arm_lower+toModel (SimpleModel CaduceatorArmUpper) = caduceator_arm_upper+toModel (SimpleModel ReptilianLegLower) = reptilian_leg_lower+toModel (SimpleModel ReptilianLegUpper) = reptilian_leg_upper+toModel (SimpleModel ReptilianArmLower) = reptilian_arm_lower+toModel (SimpleModel ReptilianArmUpper) = reptilian_arm_upper+toModel (SimpleModel ThinLimb) = thin_limb+toModel (SimpleModel CyborgType4Dome) = cyborg_type_4_dome+toModel (SimpleModel CyborgType4Base) = cyborg_type_4_base+toModel (SimpleModel CyborgType4HyperspaceDisc) = cyborg_type_4_hyperspace_disc+toModel (SimpleModel CyborgType4HyperspaceRotor) =+        cyborg_type_4_hyperspace_rotor+toModel (SimpleModel CyborgType4HyperspaceStabilizer) =+        cyborg_type_4_hyperspace_stabilizer+toModel (EnergyThing EnergyCylinder c) = energyCylinder c+toModel (EnergyThing EnergySword c) = energySword c 3+toModel (SimpleModel Monolith) = monolith+toModel (SimpleModel Portal) = portal++-- |+-- Models that should be displayed at lower quality.+--+downgraded_models :: [LibraryModel]+downgraded_models =+    Prelude.map toLibraryModel+        [LeafyBlob,TreeBranch,+         GasSphere,MetalSphere,ChromaliteSphere,MachineArmLower,+         MachineArmUpper,CaduceatorArmLower,CaduceatorArmUpper,+         ReptilianLegLower,ReptilianLegUpper,ReptilianArmLower,+         ReptilianArmUpper, ThinLimb]++-- |+-- Sometimes we want to constrain the quality of some models.+--+forceQuality :: LibraryModel -> Quality -> Quality+-- ambient box, LOD doesn't affect appearance+forceQuality (SimpleModel CyborgType4HyperspaceRotor) = const Bad+-- terrain just isn't that interesting+forceQuality (TerrainTile _) = min Poor+forceQuality x | x `elem` downgraded_models = \q -> case q of+    Bad -> Bad+    Poor -> Bad+    Good -> Poor+    Super -> Poor+forceQuality _ = id++-- |+-- Models to build at start time.+--+essential_library_models :: [LibraryModel]+essential_library_models =+    Prelude.map TerrainTile known_terrain_types +++    Prelude.map SimpleModel [minBound..maxBound] +++    [EnergyThing x y | x <- [minBound..maxBound],+                       y <- [minBound..maxBound]]++modelPriority :: Quality -> LibraryModel -> Integer+modelPriority Bad model | model `elem` essential_library_models = 0+modelPriority q (SkySphere {}) = 10 * qualityPriority q+modelPriority q _ = qualityPriority q++qualityPriority :: Quality -> Integer+qualityPriority Bad = 1+qualityPriority Poor = 2+qualityPriority Good = 4+qualityPriority Super = 8++-- |+-- A library of named models.  Models are generated on demand, but models+-- known in all_library_models are generated at worst quality when the library+-- is first initialized.+--+data Library = Library {+    library_cache :: TVar (Map.Map (Quality,LibraryModel)+                                   (TVar (Maybe BakedModel))),+    library_wrapper :: Quality -> LibraryModel -> IO () -> IO () }++-- |+-- Create a new library.+-- Only one Library should be needed per process instance.+--+newLibrary :: IO Library+newLibrary =+    do task_pool <- newTaskPool fast_queue_configuration+                                (max 1 $ numCapabilities - 2)+                                ()+       startQueue task_pool+       cache <- newTVarIO Map.empty+       loading_stdout_mvar <- newMVar ()+       let lib = Library cache $ \q m actionIO ->+                     do _ <- dispatch (schedule task_pool $ modelPriority q m)+                                      actionIO+                        return ()+       forM_ essential_library_models $ \x -> lookupModel lib x Bad+       let waitFor x = atomically $+                  do b <- isLoaded lib x+                     when (not b) retry+       forM_ essential_library_models $ \x -> forkIO $+           do waitFor x+              modifyMVar_ loading_stdout_mvar $ const $+                  do hPutStrLn stderr $ "Pregenerated model: " ++ show x+                     hPutStrLn stderr . modelInfo =<< lookupModel lib x Bad+                     return ()+       forM_ essential_library_models $ \x -> waitFor x+       return lib++-- |+-- Get a library model.  If the model is not available at the requested quality+-- level, a poorer model will be provided instead, and a background thread will+-- launch to begin generating the model at the requested level of detail.+--+lookupModel :: Library -> LibraryModel -> Quality -> IO IntermediateModel+lookupModel lib model q_ = (id =<<) $ atomically $+    do let q = forceQuality model q_+       cache <- readTVar $ library_cache lib+       let m_var = Map.lookup (q,model) cache+       case m_var of+           Just var ->+               do m_result <- liftM (fmap toIntermediateModel) $ readTVar var+                  case m_result of+                      Just result -> return $ return result+                      Nothing | model == NullModel ->+                          return $ atomically $ liftM toIntermediateModel $+                              maybe retry return =<< readTVar var+                      Nothing | q == Bad -> return $+                          lookupModel lib NullModel Bad+                      Nothing -> return $+                          lookupModel lib model (pred q)+           Nothing ->+               do target <- newTVar Nothing+                  writeTVar (library_cache lib) $+                      Map.insert (q,model) target cache+                  return $+                      do library_wrapper lib q model $+                             bakeAndStore target model q+                         lookupModel lib model q++isLoaded :: Library -> LibraryModel -> STM Bool+isLoaded lib model =+    do cache <- readTVar $ library_cache lib+       let m_var = Map.lookup (Bad,model) cache+       maybe (return False) (liftM isJust . readTVar) m_var++bakeAndStore :: TVar (Maybe BakedModel) -> LibraryModel -> Quality -> IO ()+bakeAndStore target model q =+    do result <- bakeModel $ buildIntermediateModel (qualityToVertices q)+                                                    (toModel model q)+       atomically $ writeTVar target $ Just result+
− src/Models/Library.lhs 
@@ -1,93 +0,0 @@-\section{The Model Library}--\begin{code}-module Models.Library-    (Library,-     newLibrary,-     lookupModel)-    where-    -import Quality-import Models.LibraryData-import Models.Terrain-import Models.QuestionMark-import Data.Map as Map-import RSAGL.Model-import RSAGL.QualityControl-import Control.Concurrent-import RSAGL.Bottleneck-import Control.Monad-import System.IO-import Models.Encephalon-import Models.Recreant-import Models.Androsynth-import Models.Ascendant-import Models.Caduceator-import Models.Reptilian-import Models.PhaseWeapons-import Models.MachineParts--toModel :: LibraryModel -> Quality -> Modeling ()-toModel (TerrainTile s) = terrainTile s-toModel QuestionMark = const $ question_mark-toModel NullModel = const $ return ()-toModel Encephalon = encephalon-toModel Recreant = recreant-toModel Androsynth = androsynth-toModel Caduceator = caduceator-toModel Reptilian = reptilian-toModel AscendantGlow = ascendant_glow-toModel PhasePistol = phase_pistol-toModel MachineArmLower = machine_arm_lower-toModel MachineArmUpper = machine_arm_upper-toModel CaduceatorArmLower = caduceator_arm_lower-toModel CaduceatorArmUpper = caduceator_arm_upper-toModel ReptilianLegLower = reptilian_leg_lower-toModel ReptilianLegUpper = reptilian_leg_upper-toModel ReptilianArmLower = reptilian_arm_lower-toModel ReptilianArmUpper = reptilian_arm_upper-toModel ThinLimb = thin_limb--all_library_models :: [LibraryModel]-all_library_models =-    Prelude.map TerrainTile known_terrain_types ++-    [QuestionMark, NullModel,-     Encephalon,-     Recreant,-     Androsynth,-     Caduceator,-     Reptilian,-     AscendantGlow,-     PhasePistol,-     MachineArmLower,-     MachineArmUpper,-     CaduceatorArmLower,-     CaduceatorArmUpper,-     ReptilianLegLower,-     ReptilianLegUpper,-     ReptilianArmLower,-     ReptilianArmUpper,-     ThinLimb]--data Library = Library -    Bottleneck-    (MVar (Map LibraryModel (QualityCache Quality IntermediateModel)))--newLibrary :: IO Library-newLibrary = -    do lib <- liftM2 Library newBottleneck (newMVar Map.empty)-       mapM_ (\x -> do hPutStrLn stderr ("Preloading model: " ++ show x)-                       lookupModel lib x Poor) all_library_models-       return lib--lookupModel :: Library -> LibraryModel -> Quality -> IO IntermediateModel-lookupModel (Library bottleneck lib) lm q =-    do lib_map <- takeMVar lib-       m_qo <- return $ Map.lookup lm lib_map-       case m_qo of-           Just qo -> do putMVar lib lib_map-	                 getQuality qo q-	   Nothing -> do qo <- newQuality bottleneck parIntermediateModel (\q' -> toIntermediateModel (qualityToVertices q') (toModel lm q')) [Bad,Poor,Good,Super]-                         putMVar lib $ insert lm qo lib_map-			 getQuality qo q-\end{code}
+ src/Models/LibraryData.hs view
@@ -0,0 +1,82 @@+module Models.LibraryData+    (LibraryModel(..),+     SimpleModel(..),+     EnergyColor(..),+     EnergyThing(..),+     LibraryModelSource(..))+    where++import Models.Sky+import qualified Data.ByteString.Char8 as B++data EnergyColor = Blue | Yellow | Red | Green+         deriving (Eq,Ord,Show,Enum,Bounded)++data SimpleModel =+    LeafyBlob+  | TreeBranch+  | QuestionMark+    -- Creature Bodies+  | Encephalon+  | Recreant+  | Androsynth+  | AscendantGlow+  | Caduceator+  | Reptilian+    -- Tools+  | PhasePistol+  | Phaser+  | PhaseRifle+  | GasSphere+  | MetalSphere+  | ChromaliteSphere+    -- Arms and Legs+  | MachineArmLower+  | MachineArmUpper+  | CaduceatorArmLower+  | CaduceatorArmUpper+  | ReptilianLegUpper+  | ReptilianLegLower+  | ReptilianArmUpper+  | ReptilianArmLower+  | ThinLimb+    -- Space Ship Parts+  | CyborgType4Dome+  | CyborgType4Base+  | CyborgType4HyperspaceDisc+  | CyborgType4HyperspaceRotor+  | CyborgType4HyperspaceStabilizer+    -- Buildings+  | Monolith+  | Portal+      deriving (Eq,Ord,Show,Enum,Bounded)++data EnergyThing =+    EnergySword+  | EnergyCylinder+      deriving (Eq,Ord,Show,Enum,Bounded)++data LibraryModel =+    -- Terrain+    TerrainTile B.ByteString+    -- Astronomical Phenomena+  | SkySphere SkyInfo+  | SunDisc SunInfo+    -- The Null Model+  | NullModel+    -- SimpleModels (zero-parameter models)+  | SimpleModel SimpleModel+    -- Energy things+  | EnergyThing EnergyThing EnergyColor+      deriving (Eq,Ord,Show)++-- | Things that are also LibraryModels.+class LibraryModelSource a where+    toLibraryModel :: a -> LibraryModel++instance LibraryModelSource LibraryModel where+    toLibraryModel = id++instance LibraryModelSource SimpleModel where+    toLibraryModel = SimpleModel+
− src/Models/LibraryData.lhs 
@@ -1,29 +0,0 @@-\section{Library Models}--\begin{code}-module Models.LibraryData-    (LibraryModel(..))-    where--data LibraryModel = -    TerrainTile String-  | QuestionMark-  | NullModel-  | Encephalon-  | Recreant-  | Androsynth-  | AscendantGlow-  | Caduceator-  | Reptilian-  | PhasePistol-  | MachineArmLower-  | MachineArmUpper-  | CaduceatorArmLower-  | CaduceatorArmUpper-  | ReptilianLegUpper-  | ReptilianLegLower-  | ReptilianArmUpper-  | ReptilianArmLower-  | ThinLimb-      deriving (Eq,Ord,Show)-\end{code}
src/Models/MachineParts.hs view
@@ -5,33 +5,31 @@     where      import Quality-import RSAGL.Model-import RSAGL.CurveExtras-import RSAGL.Affine-import RSAGL.Vector-import RSAGL.Angle+import RSAGL.Modeling+import RSAGL.Math.CurveExtras+import RSAGL.Math import Models.Materials  machine_arm_lower :: Quality -> Modeling () machine_arm_lower _ = scale' (1/4) $ rotate (Vector3D 1 0 0) (fromDegrees 90) $ model $-    do sor $ linearInterpolation $-        points2d [(0.001,4.5),+    do sor $ linearInterpolation $ reverse $ +        points2d [(0.0,4.5),                   (0.25,4.5),                   (0.25,3.5),                   (0.35,3),                   (0.35,0.5),-                  (0.001,0.3)]+                  (0.0,0.3)]        alliance_metal  machine_arm_upper :: Quality -> Modeling () machine_arm_upper _ = scale' (1/4) $ rotate (Vector3D 1 0 0) (fromDegrees 90) $ model $-    do sor $ linearInterpolation $-        points2d [(0.001,4.5),+    do sor $ linearInterpolation $ reverse $+        points2d [(0.0,4.5),                   (0.5,4.5),                   (0.75,3.5),                   (0.5,3),                   (0.5,1),-                  (0.001,-0.5)]+                  (0.0,-0.5)]        alliance_metal  thin_limb :: Quality -> Modeling ()
+ src/Models/Materials.hs view
@@ -0,0 +1,133 @@+module Models.Materials+    (+     -- | Materials by Faction+     treaty_metal,+     treaty_glow,+     treaty_energy_field,+     alliance_metal,+     concordance_metal,+     concordance_dark_glass,+     concordance_bright_glass,+     cyborg_metal,+     cyborg_glow,+     -- | Material by Species+     caduceator_skin,+     encephalon_skin,+     reptilian_skin,+     reptilian_pigment,+     reptilian_specular,+     -- | Material by Energy Type+     energyColor,+     energyMaterial)+    where++import RSAGL.Modeling+import Models.LibraryData++{---------------------------------------------------------+ - Materials by Faction+ - -------------------------------------------------------}++-- Treaty Organization Materials (cyan-teal solid colors, yellow energy colors)++treaty_metal :: MaterialM attr ()+treaty_metal = material $+    do pigment $ pure camouflage_green+       specular 1 $ pure $ viridian++treaty_glow :: MaterialM attr ()+treaty_glow = material $+    do pigment $ pure black+       emissive $ pure brass++treaty_energy_field :: MaterialM attr ()+treaty_energy_field = material $+    do emissive $ pure brass+       specular 1 $ pure saffron++-- Alliance Materials  (yellow-gold solid colors, orange energy colors)++alliance_metal :: Modeling ()+alliance_metal = material $+    do pigment $ pure $ scaleRGB 0.6 gold+       specular 7 $ pure gold++-- Concordance Materials  (violet solid colors, blue energy colors)++concordance_metal :: Modeling ()+concordance_metal = material $+    do pigment $ pure slate_gray+       specular 4 $ pure lilac++concordance_dark_glass :: Modeling ()+concordance_dark_glass = material $+    do pigment $ pure black+       specular 8 $ pure eggplant++concordance_bright_glass :: Modeling ()+concordance_bright_glass = material $+    do pigment $ pure black+       emissive $ pure puce+       specular 8 $ pure eggplant++-- Pirates  (green solid colors, red energy colors)++-- Utopiate (red solid colors, cyan-teal energy colors)++-- Whispers (black solid colors, white energy colors)++-- Monster (orange solid colors, violet energy colors)++-- Cyborg Materials  (white solid colors, green energy colors)++cyborg_metal :: MaterialM attr ()+cyborg_metal = metallic $ pure wheat++cyborg_glow :: MaterialM attr ()+cyborg_glow = +    do pigment $ pure blackbody+       emissive $ pure $ scaleRGB 1.0 green++{-------------------------------------------------------+ - Materials by Species+ - -----------------------------------------------------}++-- Caduceator Skins++caduceator_skin :: Modeling ()+caduceator_skin = material $ pigment $ pattern (cloudy 75 0.01) [(0.0,pure red),(0.5,pure safety_orange),(1.0,pure black)]++-- Reptilian Skins++reptilian_pigment :: ColorFunction RGB+reptilian_pigment = pattern (cloudy 75 0.1) [(0.0,pure lavender),(1.0,pure saffron)]++reptilian_specular :: ColorFunction RGB+reptilian_specular = pattern (cloudy 75 0.1) [(0.0,pure firebrick),(1.0,pure chartreuse)]++reptilian_skin :: Modeling ()+reptilian_skin = material $+    do pigment $ reptilian_pigment+       specular 5.0 $ reptilian_specular++-- Encephalon Skins++encephalon_skin :: Modeling ()+encephalon_skin = material $ pigment $ pattern (cloudy 32 0.1) [(0.0,pure sepia),(1.0,pure amethyst)]++{--------------------------------------------------------+ - Material by Energy Type+ - ------------------------------------------------------}++energyColor :: EnergyColor -> RGB+energyColor Blue = cobalt+energyColor Yellow = saffron+energyColor Red = red+energyColor Green = shamrock++energyMaterial :: EnergyColor -> Modeling ()+energyMaterial c = material $+    do pigment $ pure $ scaleRGB 0.33 $ energyColor c+       specular 1.0 $ pure $ scaleRGB 0.33 $ energyColor c+       emissive $ pure $ scaleRGB 0.33 $ energyColor c+
− src/Models/Materials.lhs 
@@ -1,92 +0,0 @@-\section{Materials}--\begin{code}-module Models.Materials-    (alliance_metal,-     concordance_metal,-     concordance_dark_glass,-     concordance_bright_glass,-     caduceator_skin,-     encephalon_skin,-     recreant_metal,-     reptilian_skin,-     reptilian_pigment,-     reptilian_specular)-    where--import RSAGL.Model-import RSAGL.ModelingExtras-\end{code}--\subsection{Materials by Alliance}--\subsubsection{Alliance Materials}--\begin{code}-alliance_metal :: Modeling ()-alliance_metal = material $-    do pigment $ pure $ scaleRGB 0.6 gold-       specular 75 $ pure $ scaleRGB 1.0 gold-\end{code}--\subsubsection{Condorance Materials}--\begin{code}-concordance_metal :: Modeling ()-concordance_metal = material $-    do pigment $ pure slate_gray-       specular 45 $ pure lilac-\end{code}--\begin{code}-concordance_dark_glass :: Modeling ()-concordance_dark_glass = material $-    do pigment $ pure black-       specular 85 $ pure eggplant-\end{code}--\begin{code}-concordance_bright_glass :: Modeling ()-concordance_bright_glass = material $-    do pigment $ pure black-       emissive $ pure puce-       specular 85 $ pure eggplant-\end{code}--\section{Materials by Species}--\subsubsection{Encephalon Materials}--\begin{code}-caduceator_skin :: Modeling ()-caduceator_skin = material $ pigment $ pattern (cloudy 75 0.01) [(0.0,pure red),(0.5,pure safety_orange),(1.0,pure black)]-\end{code}--\begin{code}-reptilian_pigment :: ColorFunction RGB-reptilian_pigment = pattern (cloudy 75 0.1) [(0.0,pure lavender),(1.0,pure saffron)]--reptilian_specular :: ColorFunction RGB-reptilian_specular = pattern (cloudy 75 0.1) [(0.0,pure firebrick),(1.0,pure chartreuse)]--reptilian_skin :: Modeling ()-reptilian_skin = material $-    do pigment $ reptilian_pigment-       specular 5.0 $ reptilian_specular-       -\end{code}--\begin{code}-encephalon_skin :: Modeling ()-encephalon_skin = material $ pigment $ pattern (cloudy 32 0.1) [(0.0,pure sepia),(1.0,pure amethyst)]-\end{code}--\subsubsection{Recreant Materials}--\begin{code}-recreant_metal :: Modeling ()-recreant_metal = material $-    do pigment $ pure camouflage_green -       specular 25 $ pure white-\end{code}-
+ src/Models/Monolith.hs view
@@ -0,0 +1,14 @@+module Models.Monolith+    (monolith)+    where++import RSAGL.Math+import RSAGL.Modeling+import Quality++monolith :: Quality -> Modeling ()+monolith _ =+    do box (Point3D (-1/2) 0 (-1/8)) (Point3D (1/2) (9/4) (1/8))+       material $+           do pigment $ pure blackbody+              specular 100 $ pure white
src/Models/PhaseWeapons.hs view
@@ -1,20 +1,23 @@ module Models.PhaseWeapons-    (phase_pistol)+    (phase_pistol,+     phaser,+     phase_rifle)     where  import Quality import Models.Materials-import RSAGL.Vector-import RSAGL.Model-import RSAGL.Affine-import RSAGL.CurveExtras-import RSAGL.Angle+import RSAGL.Math+import RSAGL.Modeling+import RSAGL.Math.CurveExtras+import Control.Monad -phase_weapon_emitter :: Quality -> Modeling ()-phase_weapon_emitter _ = model $+-- | A phase weapon emitter.  Includes a specification of a phase guide length.+phaseWeaponEmitter :: Integer -> Quality -> Modeling ()+phaseWeaponEmitter guide_length _ = model $     do sor $ linearInterpolation $                 points2d $ reverse -		         [(0.001,0),+		         [(0,0),+                          (1,0),                           (4,1),                           (7,2),                           (9,3),@@ -23,15 +26,16 @@                           (7,-6),                           (4,-9),                           (2,-10),-                          (0.001,-10)]-       deform dfn+                          (0,-10)]+       let guide_length_y = fromInteger guide_length * 3 + 6+       when (guide_length > 0) $ openCone (Point3D 0 0 8,1) (Point3D 0 guide_length_y 8,0)+       _ <- flip mapM [2..guide_length] $ \i ->+           do let y = fromInteger i * 3+              translate (Vector3D 0 y 0) $ torus 8 (lerpBetween (0,y,guide_length_y) (1,0))+       deform dfn_squish        affine $ rotateX (fromDegrees 90)-    where dfn_squish p@(Point3D _ _ z) | z > 0 = scale (Vector3D 1 1 0.1) p-          dfn_squish p = scale (Vector3D 1 1 0.25) p-          dfn_smoothe_dish p@(Point3D _ y _) | y > 0 = scale (Vector3D 1 (u/10) 1) p-              where u = distanceBetween origin_point_3d $ scale (Vector3D 1 0 1) p-          dfn_smoothe_dish p = p-          dfn = dfn_smoothe_dish . dfn_squish+    where dfn_squish p@(Point3D _ _ z) | z > 0 = scale (Vector3D 1 1 0.1) p  -- bottom of emitter is flattened+          dfn_squish p = scale (Vector3D 1 1 0.25) p                         -- top of emitter is more round                                   phase_weapon_grip :: Quality -> Modeling () phase_weapon_grip _ = model $@@ -52,10 +56,19 @@          dfn_flat_sides (Point3D x y z) = Point3D ((signum x *) $ sqrt (abs x/3)) y z          dfn_slope_backwards pt@(Point3D _ y _) = translate (Vector3D 0 0 (-y/3)) pt          dfn = dfn_slope_backwards . dfn_flat_back . dfn_flat_sides . dfn_gripped_front-                                -phase_pistol :: Quality -> Modeling ()-phase_pistol q = model $++phaseWeapon :: Integer -> Quality -> Modeling ()+phaseWeapon guide_length q = model $     scale' (1/100) $-        do translate (Vector3D 0 5 7) $ phase_weapon_emitter q+        do translate (Vector3D 0 5 7) $ phaseWeaponEmitter guide_length q            translate (Vector3D 0 5 0) $ phase_weapon_grip q 	   concordance_metal++phase_pistol :: Quality -> Modeling ()+phase_pistol = phaseWeapon 0++phaser :: Quality -> Modeling ()+phaser = phaseWeapon 1++phase_rifle :: Quality -> Modeling ()+phase_rifle = phaseWeapon 2
src/Models/QuestionMark.hs view
@@ -2,12 +2,9 @@     (question_mark)     where     -import RSAGL.Model-import RSAGL.ModelingExtras-import RSAGL.Affine-import RSAGL.Vector-import RSAGL.CurveExtras-import RSAGL.Curve+import RSAGL.Modeling+import RSAGL.Math+import RSAGL.Math.CurveExtras  question_mark_material :: Modeling ()  question_mark_material = material $
src/Models/Recreant.hs view
@@ -3,10 +3,9 @@     where      import Quality-import RSAGL.Model-import RSAGL.CurveExtras-import RSAGL.Vector-import RSAGL.Affine+import RSAGL.Modeling+import RSAGL.Math.CurveExtras+import RSAGL.Math import Models.Materials  recreant_antenna_small :: Quality -> Modeling ()@@ -31,11 +30,11 @@ recreant_body _ =      do sor $ linearInterpolation $                   points2d $ reverse-		           [(0.001,3),+		           [(0,3),                             (4,3),                             (6,2),                             (7,1),-			    (0.001,0)]+			    (0,0)]                              recreant :: Quality -> Modeling () recreant q = scale' 0.05 $
src/Models/RecreantFactory.hs view
@@ -3,8 +3,8 @@     where      import Quality-import RSAGL.Model-import RSAGL.Vector+import RSAGL.Modeling+import RSAGL.Math import Models.Materials  recreant_factory :: Quality -> Modeling ()@@ -17,4 +17,4 @@        sphere (Point3D 0.4 0 (-0.4)) 0.1        sphere (Point3D 0.4 0 0.4) 0.1        sphere (Point3D (-0.4) 0 0.4) 0.1-       recreant_metal+       alliance_metal
src/Models/Reptilian.hs view
@@ -6,20 +6,17 @@      reptilian_arm_lower)     where -import RSAGL.Vector-import RSAGL.Model+import RSAGL.Math+import RSAGL.Modeling import Quality import Models.Materials-import RSAGL.ModelingExtras-import RSAGL.CurveExtras-import RSAGL.Affine-import RSAGL.Angle+import RSAGL.Math.CurveExtras  reptilian :: Quality -> Modeling () reptilian _ = model $     do model $            do tube $ linearInterpolation-                  [(0.001,Point3D 0 0   (-6)),+                  [(0    ,Point3D 0 0   (-6)), 		   (1    ,Point3D 0 5   (-4)), 		   (1.5  ,Point3D 0 5.5 (-3)), 		   (2.4  ,Point3D 0 6   (-2)),@@ -31,7 +28,7 @@ 		   (1    ,Point3D 0 11  1), 		   (1    ,Point3D 0 11  2), 		   (0.5  ,Point3D 0 10  2.5),-		   (0.001,Point3D 0 9   3)]+		   (0    ,Point3D 0 9   3)]               model $ 	          do triangle (Point3D 0 7 (-2)) (Point3D (-1) 10 (-8)) (Point3D 1 10 (-8)) 		     triangle (Point3D 0 7 (-2)) (Point3D (-0.25) 9 (-9)) (Point3D (-3.5) 9.5 (-8))@@ -42,20 +39,20 @@ 		     deform $ \(Point3D x y z) -> Point3D x (y+x^2/100) (z+x^2/25+sin (x*10)/4) 	      reptilian_skin         model $-           do sphere (Point3D 0.5 11 2) 0.25-	      sphere (Point3D (-0.5) 11 2) 0.25+           do sphere (Point3D 0.55 11 2) 0.5+	      sphere (Point3D (-0.55) 11 2) 0.5 	      material $ pigment $ pure black        affine $ scale' (1/20)  reptilian_leg_upper :: Quality -> Modeling () reptilian_leg_upper _ = rotate (Vector3D 1 0 0) (fromDegrees 90) $ model $     do model $ sor $ linearInterpolation $-           points2d [(0.0001,0),+           points2d [(0  ,0), 	             (1.9,1), 		     (1.6,5), 		     (1,7.5), 		     (0.75,10.6),-		     (0.0001,10.8)]+		     (0  ,10.8)]        material $            do pigment $ pattern (gradient origin_point_3d (Vector3D 0 10 0)) [(0.0,reptilian_pigment),(1.0,pure burgundy)]               specular 5.0 $ pattern (gradient origin_point_3d (Vector3D 0 10 0)) [(0.0,reptilian_specular),(1.0,pure crimson)]@@ -64,12 +61,12 @@ reptilian_leg_lower :: Quality -> Modeling () reptilian_leg_lower _ = rotate (Vector3D 1 0 0) (fromDegrees 90) $ model $     do sor $ linearInterpolation $-           points2d [(0.0001,-0.15),+           points2d [(0  ,-0.15), 	             (0.5,-0.1), 	             (1.0,0.0), 		     (0.5,9.0), 		     (0.5,10.0),-		     (0.0001,10.1)]+		     (0  ,10.1)]        openCone (Point3D 0 9.5 0,0.5) (Point3D 0 10 7,0.0001)        openCone (Point3D 0 9.5 0,0.5) (Point3D 5 10 5,0.0001)        openCone (Point3D 0 9.5 0,0.5) (Point3D (-5) 10 5,0.0001)@@ -81,13 +78,13 @@ reptilian_arm_upper :: Quality -> Modeling () reptilian_arm_upper _ = rotate (Vector3D 1 0 0) (fromDegrees 90) $ model $     do sor $ linearInterpolation $-	   points2d [(0.0001,0.0),+	   points2d [(0  ,0.0), 	             (1.0,0.1), 	             (0.5,1.0), 	   	     (0.25,5.0), 		     (0.5,9.0), 		     (1.0,9.9),-		     (0.0001,0.0)]+		     (0  ,0.0)]        material $            do pigment $ pure burgundy               specular 5.0 $ pure crimson@@ -96,12 +93,12 @@ reptilian_arm_lower :: Quality -> Modeling () reptilian_arm_lower _ = rotate (Vector3D 1 0 0) (fromDegrees 90) $ model $     do sor $ linearInterpolation $-           points2d [(0.0001,-1.0),+           points2d [(0  ,-1.0), 	             (1.0,0.0), 		     (0.25,5.0), 		     (0.5,9.0), 		     (0.5,9.9),-		     (0.0001,0.0)]+		     (0  ,0.0)]        material $            do pigment $ pure burgundy               specular 5.0 $ pure crimson
+ src/Models/Stargate.hs view
@@ -0,0 +1,38 @@+module Models.Stargate+    (portal)+    where++import RSAGL.Math+import RSAGL.Modeling+import Models.Materials+import Quality++portal :: Quality -> Modeling ()+portal q =+    do model $+           do model $+                  do box (Point3D (-0.6) 0 (-0.05)) (Point3D (-0.5) 1.618 0.05)+                     box (Point3D 0.6 0 (-0.05)) (Point3D 0.5 1.618 0.05)+                     box (Point3D (-1.1) 1.568 (-0.05))+                         (Point3D (1.1) 1.668 0.05)+                     minorFixedQuality q+              let cone =+                      do openCone (Point3D 0 (1.618/6) 0,0.4)+                                  (Point3D 0 (1.618/3) 0,0)+                         openCone (Point3D 0 (1.618/6) 0,0.4) (Point3D 0 0 0,0)+                  cone_stack = scale (Vector3D 1 (7/8) 1) $+                      do cone+                         translate (Vector3D 0 (1.618/3) 0) cone+                         translate (Vector3D 0 (2*1.618/3) 0) cone+                         translate (Vector3D 0 1.618 0) cone+              translate (Vector3D 1.1 0 0) cone_stack+              translate (Vector3D (-1.1) 0 0) cone_stack+              material treaty_metal+       model $+           do quadralateral (Point3D (-0.55) 0 0)+                            (Point3D (-0.55) 1.618 0)+                            (Point3D 0.55 1.618 0)+                            (Point3D 0.55 0 0)+              twoSided True+              material treaty_energy_field+
+ src/Models/Terrain.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE OverloadedStrings #-}++module Models.Terrain+    (known_terrain_types,+     terrainTile)+    where++import Quality+import Models.RecreantFactory+import RSAGL.Modeling+import RSAGL.Math+import RSAGL.Types+import qualified Data.ByteString.Char8 as B++-- |+-- A list of all terrain type names known to roguestar-gl.+-- But at any given moment the engine might have been extended to include other types.+known_terrain_types :: [B.ByteString]+known_terrain_types =+    ["water",+     "deepwater",+     "sand",+     "desert",+     "grass",+     "dirt",+     "forest",+     "deepforest",+     "ice",+     "lava",+     "glass",+     "rockyground",+     "rubble",+     "rockface",+     "recreantfactory"]++-- |+-- A simple 1-by-1 square patch, centered at the origin, and raised on a slope toward it's center.+-- The first parameter indicates the patch's actual height, while the second represent's the patch's+-- apparent height based on it's normal vectors.+-- The sloping effect makes it clear where one tile ends and another begins, which is practical for game play.+-- The two heights are different as it is not desireable that creature's legs should dissappear inside the landscape,+-- but at shallow angles of attack this makes the terrain tile look fake.  REVISIT+--+-- This is just the shape, without any material.+--+terrainTileShape :: RSdouble -> RSdouble -> Quality -> Modeling ()+terrainTileShape physical_height aesthetic_height q = model $+    do heightField (-0.5,-0.5) (0.5,0.5) $ \(x,z) -> let y = 1 - max (abs x) (abs z) * 2 in min (max 0 $ sqrt y) (2*y)+       affine $ scale (Vector3D 1 aesthetic_height 1)+       deform $ \(SurfaceVertex3D p v) -> SurfaceVertex3D (scale (Vector3D 1 (physical_height/aesthetic_height) 1) p) v+       qualityToFixed q++-- |+-- Creates a terrain tile based on 'terrainTileShape' with appropriate characteristics and material for its type,+-- but without any special casing for unsual terrains like forest.+--+basicTerrainTile :: B.ByteString -> Quality -> Modeling ()+basicTerrainTile s q = model $+    do terrainTileShape 0.01 (terrainHeight s) q+       material $ terrainTexture s++-- |+-- Creates a terrain tile based on 'terrainTileShape'+-- Provides special casing for forest, rockface, liquids, etc.+--+terrainTile :: B.ByteString -> Quality -> Modeling ()+terrainTile "recreantfactory" q = recreant_factory q+terrainTile "rockface" q = model $+    do terrainTileShape (terrainHeight "rockface") (terrainHeight "rockface") q+       material $ terrainTexture "rockface"+terrainTile s q = basicTerrainTile s q++-- |+-- Answers the height of a type of terrain.+-- Note that, with some exceptions, all terrain is the same height, but some terrain is given+-- sharper contrast in its normal vectors than others (see 'terrainTileShape').+-- Unrecognized terrain types will appear very tall, so they can be easily noticed and corrected.+--+terrainHeight :: B.ByteString -> RSdouble+terrainHeight "water" = 0.01+terrainHeight "deepwater" = 0.005+terrainHeight "sand" = 0.1+terrainHeight "desert" = 0.1+terrainHeight "grass" = 0.13+terrainHeight "dirt" = 0.12+terrainHeight "forest" = 0.15+terrainHeight "deepforest" = 0.17+terrainHeight "ice" = 0.05+terrainHeight "lava" = 0.06+terrainHeight "glass" = 0.04+terrainHeight "rockyground" = 0.18+terrainHeight "rubble" = 0.2+terrainHeight "rockface" = 1.0+terrainHeight _ = 5.0++-- |+-- Answers the material of a type of terrain.+-- Unrecognized terrain types will appear bright magenta, so they can be easily+-- noticed and corrected.+--+terrainTexture :: B.ByteString -> MaterialM () ()+terrainTexture "water" =+    do pigment $ pure blue+       specular 100 $ pure white+terrainTexture "deepwater" =+    do pigment $ pure $ scaleRGB 0.8 blue+       specular 100 $ pure white+terrainTexture "sand" = pigment $ pure corn+terrainTexture "desert" = pigment $ pure $ lerp 0.5 (corn,white)+terrainTexture "grass" = pigment $ pure forest_green+terrainTexture "dirt" = pigment $ pure brown+terrainTexture "forest" = pigment $ pure fern_green+terrainTexture "deepforest" = pigment $ pure fern_green+terrainTexture "ice" =+    do pigment $ pure white+       specular 1 $ pure teal+terrainTexture "lava" =+    do pigment $ pure blackbody+       emissive $ pure coral+terrainTexture "glass" =+    do pigment $ pure black+       specular 1 $ pure white+terrainTexture "rockyground" = pigment $ pure slate_gray+terrainTexture "rubble" = pigment $ pure slate_gray+terrainTexture "rockface" = pigment $ pure slate_gray+terrainTexture _ =+    do pigment $ pure blackbody+       emissive $ pure magenta+
− src/Models/Terrain.lhs 
@@ -1,108 +0,0 @@-\section{Terrain Tiles}--\begin{code}-module Models.Terrain-    (known_terrain_types,-     terrainTile)-    where--import Quality-import Models.RecreantFactory-import RSAGL.Model-import RSAGL.ModelingExtras-import Models.Tree-import RSAGL.Vector-import RSAGL.Interpolation-import RSAGL.Affine-import RSAGL.Angle--known_terrain_types :: [String]-known_terrain_types =-    ["water",-     "deepwater",-     "sand",-     "desert",-     "grass",-     "forest",-     "deepforest",-     "ice",-     "lava",-     "glass",-     "rockyground",-     "rubble",-     "rockface",-     "recreantfactory"]--terrainTileShape :: Double -> Double -> Modeling ()-terrainTileShape squash height = model $-    do regularPrism (origin_point_3d,sqrt 0.5) (Point3D 0 1 0,0.0001) 4-       deform $ \(Point3D x y z) -> Point3D x (sqrt $ max 0 y) z-       affine $ scale (Vector3D 1 height 1) . rotate (Vector3D 0 1 0) (fromDegrees 45)-       deform $ \(SurfaceVertex3D p v) -> SurfaceVertex3D (scale (Vector3D 1 squash 1) p) v--terrainTile :: String -> Quality -> Modeling ()-terrainTile "recreantfactory" q = recreant_factory q-terrainTile "forest" q =-    do basicTerrainTile "forest"-       leafy_tree q-terrainTile "deepforest" q =-    do basicTerrainTile "deepforest"-       translate (Vector3D 0.5 0 0.5) $ leafy_tree q-       translate (Vector3D (-0.5) 0 0.5) $ leafy_tree q-       translate (Vector3D 0 0 (-0.5)) $ leafy_tree q-terrainTile "rockface" _ = model $-    do terrainTileShape 1.0 (terrainHeight "rockface")-       material $ terrainTexture "rockface"-terrainTile s _ = basicTerrainTile s--basicTerrainTile :: String -> Modeling ()-basicTerrainTile s = model $-    do terrainTileShape 0.01 (terrainHeight s)-       material $ terrainTexture s--terrainHeight :: String -> Double-terrainHeight "water" = 0.025-terrainHeight "deepwater" = 0.025-terrainHeight "sand" = 0.1-terrainHeight "desert" = 0.1-terrainHeight "grass" = 0.13-terrainHeight "dirt" = 0.12-terrainHeight "forest" = 0.15-terrainHeight "deepforest" = 0.17-terrainHeight "ice" = 0.05-terrainHeight "lava" = 0.06-terrainHeight "glass" = 0.04-terrainHeight "rockyground" = 0.18-terrainHeight "rubble" = 0.2-terrainHeight "rockface" = 0.5-terrainHeight _ = 2.0--terrainTexture :: String -> MaterialM () ()-terrainTexture "water" =-    do pigment $ pure blue-       specular 100 $ pure white-terrainTexture "deepwater" =-    do pigment $ pure $ scaleRGB 0.8 blue-       specular 100 $ pure white-terrainTexture "sand" = pigment $ pure corn-terrainTexture "desert" = pigment $ pure $ lerp 0.5 (corn,white)-terrainTexture "grass" = pigment $ pure forest_green-terrainTexture "dirt" = pigment $ pure brown-terrainTexture "forest" = pigment $ pure fern_green-terrainTexture "deepforest" = pigment $ pure fern_green-terrainTexture "ice" = -    do pigment $ pure white-       specular 1 $ pure teal-terrainTexture "lava" =-    do pigment $ pure blackbody-       emissive $ pure coral-terrainTexture "glass" =-    do pigment $ pure black-       specular 1 $ pure white-terrainTexture "rockyground" = pigment $ pure slate_gray-terrainTexture "rubble" = pigment $ pure slate_gray-terrainTexture "rockface" = pigment $ pure slate_gray-terrainTexture _ =-    do pigment $ pure blackbody-       emissive $ pure magenta-\end{code}
src/Models/Tree.hs view
@@ -1,39 +1,17 @@ module Models.Tree-    (leafy_tree)+    (leafy_blob, tree_branch)     where -import RSAGL.Model-import RSAGL.ModelingExtras-import RSAGL.Vector-import Control.Monad.Random-import Quality-import RSAGL.Affine-import RSAGL.AbstractVector-import RSAGL.Interpolation-import Control.Monad.State+import RSAGL.Modeling+import RSAGL.Math -leafy_tree :: Quality -> Modeling ()-leafy_tree Bad = evalRandT (leafyTreeBranch origin_point_3d (Vector3D 0 0.5 0) 0.1 2) (mkStdGen 45)-leafy_tree Poor = evalRandT (leafyTreeBranch origin_point_3d (Vector3D 0 0.5 0) 0.1 3) (mkStdGen 45)-leafy_tree Good = evalRandT (leafyTreeBranch origin_point_3d (Vector3D 0 0.5 0) 0.1 4) (mkStdGen 45)-leafy_tree Super = evalRandT (leafyTreeBranch origin_point_3d (Vector3D 0 0.5 0) 0.1 5) (mkStdGen 45)+leafy_blob :: ModelingM () ()+leafy_blob = model $+    do sphere (Point3D 0 0 0) 1.0+       material $ pigment $ pure forest_green -leafyTreeBranch :: Point3D -> Vector3D -> Double -> Int -> RandT StdGen (ModelingM ()) ()-leafyTreeBranch point vector thickness recursion | recursion <= 0 = -     do b <- getRandom-        when b $ lift $ model $-            do sphere point (vectorLength vector + thickness)-               material $ pigment $ pure forest_green-leafyTreeBranch point vector thickness recursion =-    do lift $ model $-           do closedCone (point,thickness) (translate vector point,thickness/2)-	      material $ pigment $ pure dark_brown-       us <- liftM (take recursion) $ getRandomRs (0.0,1.0)-       mapM leafyTreeBranchFrom us-       leafyTreeBranchFrom 1.0-  where leafyTreeBranchFrom :: Double -> RandT StdGen (ModelingM ()) ()-        leafyTreeBranchFrom u =-	    do let new_vector_constraint = vectorLength vector / 1.5-	       (x:y:z:_) <- getRandomRs (-new_vector_constraint,new_vector_constraint)-	       t <- getRandomR (thickness/3,thickness/2)-               leafyTreeBranch (lerp u (point,translate vector point)) (vectorScaleTo new_vector_constraint $ vector `add` (Vector3D x y z)) t (recursion - 1)+tree_branch :: ModelingM () ()+tree_branch = model $+    do closedCone (Point3D 0 0 0, 1.0) (Point3D 0 1 0, 0.5)+       material $ pigment $ pure dark_brown+
+ src/PrintText.hs view
@@ -0,0 +1,175 @@+{-# LANGUAGE OverloadedStrings #-}++-- | A 'PrintTextObject' renders the text console at the bottom of the screen.++module PrintText+    (newPrintTextObject,+     printText,+     PrintTextObject,+     renderText,+     PrintTextMode(..),+     TextType(..),+     getInputBuffer,+     pullInputBuffer,+     setInputBuffer,+     setPrintTextMode,+     clearOutputBuffer,+     clearInputBuffer,+     keyCallback)+    where++import Control.Concurrent.STM+import Graphics.UI.GLUT as GLUT+import PrintTextData+import Control.Monad+import Control.Concurrent.Chan+import qualified Data.ByteString.Char8 as B++data PrintTextData = PrintTextData {+    text_output_buffer :: [(TextType,B.ByteString)],+    text_input_buffer :: B.ByteString,+    text_output_mode :: PrintTextMode }++data PrintTextObject = PrintTextObject (TVar PrintTextData) (Chan B.ByteString)++font_width_pixels :: Int+font_width_pixels = 9++font_height_pixels :: Int+font_height_pixels = 15++padding_pixels :: Int+padding_pixels = 10++font :: BitmapFont+font = Fixed9By15++newPrintTextObject :: IO PrintTextObject+newPrintTextObject =+    do pt_data <- newTVarIO $ PrintTextData {+           text_output_buffer = [],+           text_input_buffer = B.empty,+           text_output_mode = Unlimited }+       pt_chan <- newChan+       return $ PrintTextObject pt_data pt_chan++printText :: PrintTextObject -> TextType -> B.ByteString -> STM ()+printText (PrintTextObject pto _) text_type str =+    do print_text <- readTVar pto+       writeTVar pto $ print_text {+           text_output_buffer = text_output_buffer print_text +++                                map ((,) text_type) (B.lines str) }++keyCallback :: PrintTextObject -> KeyboardMouseCallback+keyCallback (PrintTextObject _ chan) (Char char) Down _ _ =+    writeChan chan $ B.pack [char]+keyCallback (PrintTextObject _ chan) (SpecialKey special) Down _ _ =+    writeChan chan $ ":::" `B.append` (B.pack $ show special)+keyCallback _ _ _ _ _ = return ()++getInputBuffer :: PrintTextObject -> IO B.ByteString+getInputBuffer (PrintTextObject pto _) =+    liftM text_input_buffer $ atomically $ readTVar pto++-- | Pull one keypress into the input buffer, if it exists.+pullInputBuffer :: PrintTextObject -> IO ()+pullInputBuffer (PrintTextObject pto chan) =+    do e <- isEmptyChan chan+       when (not e) $+           do r <- readChan chan+              atomically $+                  do print_text <- readTVar pto+                     writeTVar pto $ print_text {+                         text_input_buffer = text_input_buffer print_text+                                             `B.append` r }+              return ()++setInputBuffer :: PrintTextObject -> B.ByteString -> IO ()+setInputBuffer (PrintTextObject pto _) new_input_buffer = atomically $+    do print_text <- readTVar pto+       writeTVar pto $ print_text { text_input_buffer = new_input_buffer }++clearOutputBuffer :: PrintTextObject -> STM ()+clearOutputBuffer (PrintTextObject pto _) =+    do print_text <- readTVar pto+       writeTVar pto $ print_text { text_output_buffer = [] }++setPrintTextMode :: PrintTextObject -> PrintTextMode -> STM ()+setPrintTextMode (PrintTextObject pto _) pt_mode =+    do print_text <- readTVar pto+       writeTVar pto $ print_text { text_output_mode = pt_mode }++clearInputBuffer :: PrintTextObject -> IO ()+clearInputBuffer (PrintTextObject pto _) = atomically $+    do print_text <- readTVar pto+       writeTVar pto $ print_text { text_input_buffer = B.empty }++renderText :: PrintTextObject -> IO ()+renderText (PrintTextObject pto _) =+    do ptd <- atomically $ readTVar pto+       (Size width height) <- get windowSize+       save_depth_func <- get depthFunc+       save_depth_mask <- get depthMask+       save_blend <- get blend+       depthFunc $= Nothing+       depthMask $= GLUT.Disabled+       blend $= Enabled+       matrixMode $= Projection+       loadIdentity+       ortho2D 0 (fromIntegral width) 0 (fromIntegral height)+       matrixMode $= Modelview 0+       loadIdentity+       let max_characters_height =+               (fromIntegral height - 2 * fromIntegral padding_pixels) `div`+               (fromIntegral font_height_pixels)+       let max_characters_width =+               (fromIntegral width - 2 * fromIntegral padding_pixels) `div`+               (fromIntegral font_width_pixels)+       let lines_to_print =+               restrictLines max_characters_height max_characters_width $+                   (case (text_output_mode ptd) of+                       PrintTextData.Disabled -> []+                       Limited -> reverse $ take 3 $ reverse $+                                      text_output_buffer ptd+                       Unlimited -> (text_output_buffer ptd)) +++                   (if B.length (text_input_buffer ptd) > 0 ||+                                text_output_mode ptd /= PrintTextData.Disabled+                       then [(Query,"> " `B.append` (text_input_buffer ptd))]+                       else [])+           actual_width_pixels = font_width_pixels *+                                 (maximum $ map (B.length . snd) lines_to_print)+           actual_height_pixels = font_height_pixels * (length lines_to_print)+           in do color $ (Color4 0 0 0 0.92 :: Color4 GLfloat)+                 (rect :: Vertex2 GLfloat -> Vertex2 GLfloat -> IO ())+                     (Vertex2 (fromIntegral padding_pixels)+                              (fromIntegral padding_pixels))+                     (Vertex2 (fromIntegral (actual_width_pixels ++                                             padding_pixels))+                              (fromIntegral (actual_height_pixels ++                                             padding_pixels)))+                 currentRasterPosition $= (Vertex4 (fromIntegral padding_pixels)+                                                   (fromIntegral padding_pixels)+                                                   0 1)+                 mapM_ drawLine $ reverse lines_to_print+       blend $= save_blend+       depthMask $= save_depth_mask+       depthFunc $= save_depth_func++drawLine :: (TextType,B.ByteString) -> IO ()+drawLine (textType,str) = do (Vertex4 x y _ _) <- get currentRasterPosition+			     color $ textTypeToColor textType+			     currentRasterPosition $= (Vertex4 x y 0 1)+			     renderString font $ B.unpack str+			     currentRasterPosition $= (Vertex4 x (y + fromIntegral font_height_pixels) 0 1)++restrictLines :: Int -> Int -> [(TextType,B.ByteString)] -> [(TextType,B.ByteString)]+restrictLines height width text_lines = reverse $ take height $ reverse $ concatMap splitLongLines text_lines+    where splitLongLines (_,l) | B.null l = []+	  splitLongLines (textType,str) = (textType,B.take width str):(splitLongLines (textType,B.drop width str))++textTypeToColor :: TextType -> Color3 GLfloat+textTypeToColor UnexpectedEvent = Color3 1.0 0.5 0.0+textTypeToColor Event = Color3 0.5 0.75 1.0+textTypeToColor Input = Color3 0.5 1.0 0.5+textTypeToColor Query = Color3 1.0 1.0 1.0+
− src/PrintText.lhs 
@@ -1,137 +0,0 @@-\section{PrintText}--A \texttt{PrintTextObject} renders the text console at the bottom of the screen.--\begin{code}-module PrintText-    (newPrintTextObject,-     printText,-     PrintTextObject,-     renderText,-     PrintTextMode(..),-     TextType(..),-     getInputBuffer,-     setInputBuffer,-     setPrintTextMode,-     clearOutputBuffer,-     clearInputBuffer,-     keyCallback)-    where--import Data.IORef-import Graphics.UI.GLUT as GLUT-import PrintTextData-import Control.Monad-\end{code}--\begin{code}-data PrintTextData = PrintTextData {-    text_output_buffer :: [(TextType,String)],-    text_input_buffer :: String,-    text_output_mode :: PrintTextMode }--newtype PrintTextObject = PrintTextObject (IORef PrintTextData)--font_width_pixels :: Int-font_width_pixels = 9--font_height_pixels :: Int-font_height_pixels = 15--padding_pixels :: Int-padding_pixels = 10--font :: BitmapFont-font = Fixed9By15--newPrintTextObject :: IO PrintTextObject-newPrintTextObject = liftM PrintTextObject $ newIORef $ PrintTextData {-    text_output_buffer = [],-    text_input_buffer = [],-    text_output_mode = Unlimited } --printText :: PrintTextObject -> TextType -> String -> IO ()-printText (PrintTextObject pto) text_type str =-    modifyIORef pto $ -        \print_text -> print_text { text_output_buffer = text_output_buffer print_text ++ map (\l -> (text_type,l)) (lines str) } --keyCallback :: PrintTextObject -> KeyboardMouseCallback-keyCallback _ _ Up _ _ = return ()-keyCallback _ (MouseButton {}) _ _ _ = return ()-keyCallback (PrintTextObject pto) (Char char) _ _ _ = modifyIORef pto $ -    \ptd -> ptd { text_input_buffer = text_input_buffer ptd ++ [char] }-keyCallback (PrintTextObject pto) (SpecialKey special) _ _ _ = modifyIORef pto $-    \ptd -> ptd { text_input_buffer = text_input_buffer ptd ++ show special }--getInputBuffer :: PrintTextObject -> IO String-getInputBuffer (PrintTextObject pto) = liftM text_input_buffer $ readIORef pto--setInputBuffer :: PrintTextObject -> String -> IO ()-setInputBuffer (PrintTextObject pto) new_input_buffer = modifyIORef pto $-    \print_text -> print_text { text_input_buffer = new_input_buffer }--clearOutputBuffer :: PrintTextObject -> IO ()-clearOutputBuffer (PrintTextObject pto) = modifyIORef pto $ \ptd -> ptd { text_output_buffer = [] }--setPrintTextMode :: PrintTextObject -> PrintTextMode -> IO ()-setPrintTextMode (PrintTextObject pto) pt_mode =-    do modifyIORef pto $ \print_text -> print_text { text_output_mode = pt_mode }--clearInputBuffer :: PrintTextObject -> IO ()-clearInputBuffer (PrintTextObject pto) = modifyIORef pto $ \ptd -> ptd { text_input_buffer = [] }--renderText :: PrintTextObject -> IO ()-renderText (PrintTextObject pto) = -    do ptd <- readIORef pto-       (Size width height) <- get windowSize-       save_depth_func <- get depthFunc-       save_depth_mask <- get depthMask-       save_blend <- get blend-       depthFunc $= Nothing-       depthMask $= GLUT.Disabled-       blend $= Enabled-       matrixMode $= Projection-       loadIdentity-       ortho2D 0 (fromIntegral width) 0 (fromIntegral height)-       matrixMode $= Modelview 0-       loadIdentity-       let max_characters_height = (fromIntegral height - 2 * fromIntegral padding_pixels) `div` (fromIntegral font_height_pixels)-       let max_characters_width = (fromIntegral width - 2 * fromIntegral padding_pixels) `div` (fromIntegral font_width_pixels)-       let lines_to_print = restrictLines max_characters_height max_characters_width $ -			    (case (text_output_mode ptd) of-			        PrintTextData.Disabled -> []-			        Limited -> reverse $ take 3 $ reverse $ text_output_buffer ptd-	        		Unlimited -> (text_output_buffer ptd)) ++-                            (if length (text_input_buffer ptd) > 0 || (text_output_mode ptd) /= PrintTextData.Disabled -			        then [(Query,"> " ++ (text_input_buffer ptd))] -			        else [])-	   actual_width_pixels = font_width_pixels * (maximum $ map (length . snd) lines_to_print)-	   actual_height_pixels = font_height_pixels * (length lines_to_print)-	   in do color $ (Color4 0 0 0 0.92 :: Color4 GLfloat)-		 (rect :: Vertex2 GLfloat -> Vertex2 GLfloat -> IO ())-		     (Vertex2 (fromIntegral padding_pixels) (fromIntegral padding_pixels)) -		     (Vertex2 (fromIntegral (actual_width_pixels + padding_pixels)) (fromIntegral (actual_height_pixels + padding_pixels)))-		 currentRasterPosition $= (Vertex4 (fromIntegral padding_pixels) (fromIntegral padding_pixels) 0 1)-		 mapM_ drawLine $ reverse lines_to_print-       blend $= save_blend-       depthMask $= save_depth_mask-       depthFunc $= save_depth_func--drawLine :: (TextType,String) -> IO ()-drawLine (textType,str) = do (Vertex4 x y _ _) <- get currentRasterPosition-			     color $ textTypeToColor textType-			     currentRasterPosition $= (Vertex4 x y 0 1)-			     renderString font str-			     currentRasterPosition $= (Vertex4 x (y + fromIntegral font_height_pixels) 0 1)--restrictLines :: Int -> Int -> [(TextType,String)] -> [(TextType,String)]-restrictLines height width text_lines = reverse $ take height $ reverse $ concatMap splitLongLines text_lines-    where splitLongLines (_,[]) = []-	  splitLongLines (textType,str) = (textType,take width str):(splitLongLines (textType,drop width str))--textTypeToColor :: TextType -> Color3 GLfloat-textTypeToColor UnexpectedEvent = Color3 1.0 0.5 0.0-textTypeToColor Event = Color3 0.5 0.75 1.0-textTypeToColor Input = Color3 0.5 1.0 0.5-textTypeToColor Query = Color3 1.0 1.0 1.0-\end{code}
+ src/PrintTextData.hs view
@@ -0,0 +1,19 @@+module PrintTextData+    (PrintTextMode(..),+     TextType(..))+    where++-- | How much of the screen should we use for text.+data PrintTextMode = Limited -- ^ print only a few lines+		   | Unlimited -- ^ fill the entire screen with text+		   | Disabled -- ^ don't print any text at all+		     deriving (Eq)++-- |+-- Type of any line of text printed on the screen.  We print the+-- different TextTypes in different colors for readability.+--+data TextType = Event -- ^ message related to an event in the game +	      | UnexpectedEvent -- ^ message related to a software problem+	      | Input -- ^ something the user typed in+	      | Query -- ^ asking the user to type something
− src/PrintTextData.lhs 
@@ -1,30 +0,0 @@-\section{PrintText Data Structures}--\begin{code}-module PrintTextData-    (PrintTextMode(..),-     TextType(..))-    where-\end{code}-How to run printText.--Limited -- print only the most recent lines at the top of the screen-Unlimited -- fill the entire screen with text-Disabled -- don't print any text at all--\begin{code}-data PrintTextMode = Limited -- print only a few lines (or only 1)-		   | Unlimited -- fill the entire screen with text-		   | Disabled -- don't print any text at all-		     deriving (Eq)-\end{code}--Type of any line of text printed on the screen.  We print the-different TextTypes in different colors for readability.--\begin{code}-data TextType = Event -- message related to an even in the game -	      | UnexpectedEvent -- -	      | Input -- something the user typed in-	      | Query-\end{code}
+ src/ProtocolTypes.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE OverloadedStrings #-}+-- | ADTs corresponding to certain data tables incomming from roguestar-engine.+module ProtocolTypes+    (ProtocolType(..),+     TerrainTile(..),+     VisibleObject(..),+     WieldedObject(..),+     tableSelectTyped)+    where++import Data.Maybe+import Tables+import RSAGL.Math.Angle+import Debug.Trace+import qualified Data.ByteString.Char8 as B++-- | 'ProtocolType' is any type that can be constructed from a row of a 'RoguestarTable'.+-- 'formatTable' is a function from bottom to the expected format of the table row.+class ProtocolType t where+    fromTable :: [TableDataFormat B.ByteString Integer] -> Maybe t+    formatTable :: t -> [TableDataFormat B.ByteString B.ByteString]++data TerrainTile = TerrainTile {+    tt_type :: B.ByteString,+    tt_xy :: (Integer,Integer) }+        deriving (Eq,Show)++instance ProtocolType TerrainTile where+    formatTable = const [TDString "terrain-type",TDNumber "x",TDNumber "y"]+    fromTable [TDString t,TDNumber x,TDNumber y] = Just $ TerrainTile t (x,y)+    fromTable _ = Nothing++data VisibleObject = VisibleObject {+    vo_unique_id :: Integer,+    vo_xy :: (Integer,Integer),+    vo_facing :: BoundAngle }++instance ProtocolType VisibleObject where+    formatTable = const $ [TDNumber "object-unique-id",TDNumber "x",TDNumber "y",TDString "facing"]+    fromTable [TDNumber unique_id,TDNumber x,TDNumber y,TDString facing] = Just $+        VisibleObject unique_id (x,y) (facingToAngle facing)+    fromTable _ = Nothing++data WieldedObject = WieldedObject {+    wo_unique_id :: Integer,+    wo_creature_id :: Integer }++instance ProtocolType WieldedObject where+    formatTable = const $ [TDNumber "uid",TDNumber "creature"]+    fromTable [TDNumber unique_id,TDNumber creature_id] = Just $+        WieldedObject unique_id creature_id+    fromTable _ = Nothing++facingToAngle :: B.ByteString -> BoundAngle+facingToAngle "south" = BoundAngle $ fromDegrees 0+facingToAngle "southeast" = BoundAngle $ fromDegrees 45+facingToAngle "east" = BoundAngle $ fromDegrees 90+facingToAngle "northeast" = BoundAngle $ fromDegrees 135+facingToAngle "north" = BoundAngle $ fromDegrees 180+facingToAngle "northwest" = BoundAngle $ fromDegrees 225+facingToAngle "west" = BoundAngle $ fromDegrees 270+facingToAngle "southwest" = BoundAngle $ fromDegrees 315+facingToAngle "here" = BoundAngle $ fromDegrees 0+facingToAngle s = trace ("facingToAngle: what is " ++ B.unpack s ++ "?") $ BoundAngle $ fromDegrees 180++tableSelectTyped :: (ProtocolType t) => RoguestarTable -> [t]+tableSelectTyped the_table = result+    where result = mapMaybe fromTable $ tableSelectFormatted the_table the_format +          the_format = formatTable $ (error "tableSelectTyped: undefined" :: (a -> a)) (head result)+
− src/ProtocolTypes.lhs 
@@ -1,72 +0,0 @@-\section{Protocol Types}--\begin{code}-module ProtocolTypes-    (ProtocolType(..),-     TerrainTile(..),-     VisibleObject(..),-     WieldedObject(..),-     tableSelectTyped)-    where--import Data.Maybe-import Tables-import RSAGL.Angle-import Debug.Trace-\end{code}--\texttt{ProtocolType} is any type that can be constructed from a row of a \texttt{RoguestarTable}.-\texttt{formatTable} is a function from bottom to the expected format of the table row.--\begin{code}-class ProtocolType t where-    fromTable :: [TableDataFormat String Integer] -> Maybe t-    formatTable :: t -> [TableDataFormat String String]--data TerrainTile = TerrainTile {-    tt_type :: String,-    tt_xy :: (Integer,Integer) }--instance ProtocolType TerrainTile where-    formatTable = const [TDString "terrain-type",TDNumber "x",TDNumber "y"]-    fromTable [TDString t,TDNumber x,TDNumber y] = Just $ TerrainTile t (x,y)-    fromTable _ = Nothing--data VisibleObject = VisibleObject {-    vo_unique_id :: Integer,-    vo_xy :: (Integer,Integer),-    vo_facing :: BoundAngle }--instance ProtocolType VisibleObject where-    formatTable = const $ [TDNumber "object-unique-id",TDNumber "x",TDNumber "y",TDString "facing"]-    fromTable [TDNumber unique_id,TDNumber x,TDNumber y,TDString facing] = Just $-        VisibleObject unique_id (x,y) (facingToAngle facing)-    fromTable _ = Nothing--data WieldedObject = WieldedObject {-    wo_unique_id :: Integer,-    wo_creature_id :: Integer }--instance ProtocolType WieldedObject where-    formatTable = const $ [TDNumber "uid",TDNumber "creature"]-    fromTable [TDNumber unique_id,TDNumber creature_id] = Just $-        WieldedObject unique_id creature_id-    fromTable _ = Nothing--facingToAngle :: String -> BoundAngle-facingToAngle "south" = BoundAngle $ fromDegrees 0-facingToAngle "southeast" = BoundAngle $ fromDegrees 45-facingToAngle "east" = BoundAngle $ fromDegrees 90-facingToAngle "northeast" = BoundAngle $ fromDegrees 135-facingToAngle "north" = BoundAngle $ fromDegrees 180-facingToAngle "northwest" = BoundAngle $ fromDegrees 225-facingToAngle "west" = BoundAngle $ fromDegrees 270-facingToAngle "southwest" = BoundAngle $ fromDegrees 315-facingToAngle "here" = BoundAngle $ fromDegrees 0-facingToAngle s = trace ("facingToAngle: what is " ++ s ++ "?") $ BoundAngle $ fromDegrees 180--tableSelectTyped :: (ProtocolType t) => RoguestarTable -> [t]-tableSelectTyped the_table = result-    where result = mapMaybe fromTable $ tableSelectFormatted the_table the_format -          the_format = formatTable $ (error "tableSelectTyped: undefined" :: (a -> a)) (head result)-\end{code}
src/Quality.hs view
@@ -1,9 +1,12 @@  module Quality     (Quality(..),-     qualityToVertices)+     qualityToVertices,+     qualityToFixed,+     minorFixedQuality)     where +import RSAGL.Modeling  data Quality = Bad 	     | Poor@@ -12,8 +15,23 @@ 	     deriving (Eq,Enum,Ord,Show)  qualityToVertices :: Quality -> Integer-qualityToVertices Bad = 2^5-qualityToVertices Poor = 2^9-qualityToVertices Good = 2^13-qualityToVertices Super = 2^17+qualityToVertices Bad = 2^6+qualityToVertices Poor = 2^8+qualityToVertices Good = 2^10+qualityToVertices Super = 2^12 +-- | Sets the fixed quality of of modeled surface using 'RSAGL.Model.fixed'.+-- Good for pieces that need to mesh together but don't for some reason.+qualityToFixed :: Quality -> ModelingM attr ()+qualityToFixed Bad = fixed (2^2,2^2)+qualityToFixed Poor = fixed (2^3,2^3)+qualityToFixed Good = fixed (2^4,2^4)+qualityToFixed Super = fixed (2^5,2^5)++-- | Sets the fixed quality of of modeled surface using 'RSAGL.Model.fixed'.+-- The quality here is very low.+minorFixedQuality :: Quality -> ModelingM attr ()+minorFixedQuality Bad = fixed (2^1,2^1)+minorFixedQuality Poor = fixed (2^1,2^1)+minorFixedQuality Good = fixed (2^2,2^2)+minorFixedQuality Super = fixed (2^3,2^3)
+ src/RenderingControl.hs view
@@ -0,0 +1,180 @@+{-# LANGUAGE Arrows, OverloadedStrings, TypeFamilies #-}++module RenderingControl+    (mainAnimationLoop)+    where++import Globals+import RSAGL.FRP+import RSAGL.Math+import RSAGL.Modeling+import Animation+import Control.Arrow+import Data.Maybe+import PrintText+import Tables+import VisibleObject+import RSAGL.Animation+import qualified Data.Map as Map+import Sky+import Scene+import Data.Monoid+import AnimationTerrain+import AnimationCreatures+import AnimationBuildings+import AnimationTools+import AnimationMenus+import AnimationExtras+import AnimationEvents+import Strings+import RSAGL.Types+import qualified Data.ByteString.Char8 as B++-- | Enters the top-level animation loop.+mainAnimationLoop :: FRP e (FRP1 AnimationState () SceneLayerInfo) () SceneLayerInfo+mainAnimationLoop = proc () ->+    do m_state <- driverGetAnswerA -< "state"+       switchContinue -< (fmap (const $ mainWelcome >>> mainDispatch) m_state,())+       printTextOnce -< Just (UnexpectedEvent,"Waiting for engine...")+       returnA -< roguestarSceneLayerInfo mempty basic_camera+  where mainWelcome = proc () ->+            do printTextOnce -< Just (Event,"Welcome to Roguestar-GL.")+	       returnA -< ()++-- | This is the actual to-level animation loop.+mainDispatch :: (FRPModel m) => FRP e (RSwitch Disabled () () SceneLayerInfo m) () SceneLayerInfo+mainDispatch = proc () ->+    do result <- frp1Context (mainStateHeader (const False) >>> arr (const $ roguestarSceneLayerInfo mempty basic_camera)) -< ()+       monitorPlanetName -< ()+       monitorCompassReading -< ()+       returnA -< result++-- | Forces the current RSAnim thread to switch whenever the current state does not match the specified predicate.+-- Any switch that wants to surrender control whenever the state changes should call this first.+mainStateHeader :: (FRPModel m) => (B.ByteString -> Bool) -> FRP e (RSwitch Disabled () () SceneLayerInfo m) () ()+mainStateHeader = genericStateHeader switchTo+  where switchTo blanking_state | blanking_state `elem` blanking_states = blankingDispatch blanking_state+        switchTo menu_state | menu_state `elem` menu_states = menuManager+        switchTo planar_state | planar_state `elem` planar_states = planarGameplayDispatch+	switchTo "game-over" = gameOver+	switchTo unknown_state = error $ "mainStateHeader: unrecognized state: " ++ B.unpack unknown_state++-- | Displays all menus with a black background.+menuManager :: (FRPModel m) => FRP e (RSwitch Disabled () () SceneLayerInfo m) () SceneLayerInfo+menuManager = proc () ->+    do mainStateHeader (`elem` menu_states) -< ()+       frp1Context menuDispatch -< ()++-- | Print a "Welcome to P-XXXX" message whenever we arrive on a new planet.+monitorPlanetName :: (FRPModel m, StateOf m ~ AnimationState) => FRP e m () ()+monitorPlanetName = proc () ->+    do m_planet_name <- driverGetAnswerA -< "planet-name"+       p <- changed (==) <<< sticky isJust Nothing -< m_planet_name+       printTextA -< case m_planet_name of+           _ | not p ->      Nothing+           Nothing ->        Nothing+           Just "nothing" -> Nothing+           Just somewhere -> Just (Event, B.concat $ ["Welcome to ", capitalize somewhere, "."])+       returnA -< ()++-- | Print a compass heading message whenever it changes.+monitorCompassReading :: (FRPModel m, StateOf m ~ AnimationState) => FRP e m () ()+monitorCompassReading = proc () ->+    do m_compass <- driverGetAnswerA -< "compass"+       p <- changed (==) <<< sticky isJust Nothing -< m_compass+       printTextA -< case m_compass of+           _ | not p ->      Nothing+           Nothing ->        Nothing+           Just "nothing" -> Nothing+           Just "here" ->    Nothing+           Just compass ->   Just (Event, B.concat $ ["Compass reading: ", hrstring compass, "."])+       returnA -< ()+++-- | Print the game over message and retain control of the rendering loop forever.+gameOver :: (FRPModel m) => FRP e (RSwitch Disabled () () SceneLayerInfo m) () SceneLayerInfo+gameOver = proc () ->+    do printTextOnce -< Just (Event,"Game Over")+       returnA -< roguestarSceneLayerInfo mempty basic_camera++-- | List of all states that require the display of the planar environment (terrain, characters, tools, and sky)+planar_states :: [B.ByteString]+planar_states = ["player-turn","move","turn","jump","attack","fire","clear-terrain"] ++ recognized_events++-- | Captures all planar visuals: terrain, characters, tools, and sky.+planarGameplayDispatch :: (FRPModel m) => FRP e (RSwitch Disabled () () SceneLayerInfo m) () SceneLayerInfo+planarGameplayDispatch = proc () ->+    do -- setup/get infos+       mainStateHeader (`elem` planar_states) -< () +       clearPrintTextOnce -< ()+       frp1Context eventMessager -< ()+       -- terrain threads+       frpContext (allowAnonymous forbidDuplicates) [(Nothing,terrainThreadLauncher)] -< ()+       -- building threads+       frpContext (allowAnonymous forbidDuplicates) [(Nothing,visibleObjectThreadLauncher buildingAvatar)] -< ()+       -- creature threads+       ctos <- arr (catMaybes . map (uncurry $ liftA2 (,))) <<< +           frpContext (allowAnonymous forbidDuplicates) +              [(Nothing,visibleObjectThreadLauncher creatureAvatar)] -< ()+       -- tool threads+       frpContext (allowAnonymous forbidDuplicates) [(Nothing,visibleObjectThreadLauncher toolAvatar)] -< +           ToolThreadInput {+               tti_wield_points = Map.fromList $ map (\(uid,cto) -> (uid,cto_wield_point cto)) ctos }+       -- camera/lighting stuff, including sky sphere +       sky_info <- getSkyInfo -< ()+       sky -< sky_info+       m_lookat <- whenJust (approachA 1.0 (perSecond 3.0)) <<< sticky isJust Nothing <<<+           arr (fmap (\(x,y) -> Point3D (realToFrac x) 0.25 (negate $ realToFrac y))) <<< centerCoordinates -< ()+       camera_distance <- approachA 5.0 (perSecond 5.0) <<< readGlobal global_planar_camera_distance -< ()+       let (planar_camera,lookat) = maybe (basic_camera,origin_point_3d) (\x -> (planarCamera camera_distance x,x)) m_lookat+       artificial_light_intensity <- arr lighting_artificial <<< lightingConfiguration -< sky_info+       sky_on <- readGlobal global_sky_on -< ()+       accumulateSceneA -< (scene_layer_local, lightSource $ case () of+           () | artificial_light_intensity > 0.05 && sky_on ->+                    mapLightSource (mapBoth $ scaleRGB artificial_light_intensity) $ PointLight {+                        lightsource_position = camera_position planar_camera,+                        lightsource_radius = measure (camera_position planar_camera) lookat,+                        lightsource_color = gray 0.8,+                        lightsource_ambient = gray 0.2 }+           () | artificial_light_intensity > 0.05 -> PointLight {+                        lightsource_position = camera_position planar_camera,+                        lightsource_radius = measure (camera_position planar_camera) lookat,+                        lightsource_color = gray 0.5,+                        lightsource_ambient = gray 0.5 }+           () | otherwise -> NoLight)+       returnA -< roguestarSceneLayerInfo (skyAbsorbtionFilter sky_info) planar_camera++-- | Sets up a Camera, based on a camera distance parameter (probably tied to the global_planar_camera_distance variable)+-- and the look-at point.+planarCamera :: RSdouble -> Point3D -> Camera+planarCamera camera_distance look_at = PerspectiveCamera {+    camera_position = translate (vectorScaleTo camera_distance $ Vector3D 0 (7*(camera_distance/10)**2) camera_distance) look_at,+    camera_lookat = translate (Vector3D 0 (1/camera_distance) 0) look_at,+    camera_up = Vector3D 0 1 0,+    camera_fov = fromDegrees $ 40 + 30 / camera_distance }++-- | Retrieve the look-at point from the engine.+centerCoordinates :: (FRPModel m, StateOf m ~ AnimationState) => FRP e m () (Maybe (Integer,Integer))+centerCoordinates = proc () ->+    do m_center_coordinates_table <- sticky isJust Nothing <<< driverGetTableA -< ("center-coordinates","0")+       returnA -< do center_coordinates_table <- m_center_coordinates_table+                     x <- tableLookupInteger center_coordinates_table ("axis","coordinate") "x" -- Maybe monad+                     y <- tableLookupInteger center_coordinates_table ("axis","coordinate") "y" +		     return (x,y)++-- | A list of the states that require the screen to be blanked (made black), interrupting the planar visuals.+blanking_states :: [B.ByteString]+blanking_states = ["teleport-event"]++-- | Display the blanked screen and print any blanking events.+blankingDispatch :: (FRPModel m) => B.ByteString -> FRP e (RSwitch Disabled () () SceneLayerInfo m) () SceneLayerInfo+blankingDispatch "teleport-event" = proc () ->+    do mainStateHeader (`elem` blanking_states) -< () +       clearPrintTextOnce -< ()+       printTextOnce -< Just (Event,"Whoosh!")+       blockContinue <<< arr ((< 0.5) . toSeconds) <<< threadTime -< ()+       returnA -< roguestarSceneLayerInfo mempty basic_camera+blankingDispatch blanking_state = proc () ->+    do debugOnce -< Just $ "blankingDispatch: unrecognized blanking_state `" `B.append` blanking_state `B.append` "`"+       returnA -< roguestarSceneLayerInfo mempty basic_camera+
− src/RenderingControl.lhs 
@@ -1,434 +0,0 @@-\section{The Top-Level Animation Loop}--\begin{code}-{-# LANGUAGE Arrows #-}--module RenderingControl-    (mainAnimationLoop)-    where--import Data.List-import RSAGL.FRP-import RSAGL.Edge-import RSAGL.Scene-import RSAGL.Vector-import Animation-import RSAGL.Angle-import Control.Arrow-import Data.Maybe-import PrintText-import Tables-import Models.LibraryData-import RSAGL.CoordinateSystems-import RSAGL.Affine-import RSAGL.ModelingExtras-import RSAGL.Interpolation-import ProtocolTypes-import RSAGL.Time-import RSAGL.AbstractVector-import VisibleObject-import RSAGL.InverseKinematics-import RSAGL.AnimationExtras-import Actions-import Strings-import Control.Applicative-import qualified Data.Map as Map-import Limbs-import RSAGL.Joint-import RSAGL.AbstractVector-\end{code}--\begin{code}-mainAnimationLoop :: RSAnimA1 () Camera () Camera-mainAnimationLoop = proc () ->-    do m_state <- driverGetAnswerA -< "state"-       switchContinue -< (fmap (const $ mainWelcome >>> mainDispatch) m_state,())-       printTextOnce -< Just (UnexpectedEvent,"Waiting for engine...")-       returnA -< basic_camera-  where mainWelcome = proc () ->-            do printTextOnce -< Just (Event,"Welcome to Roguestar-GL.")-	       returnA -< ()--basic_camera :: Camera-basic_camera = PerspectiveCamera {-    camera_position = Point3D 0 0 0,-    camera_lookat = Point3D 0 0 1,-    camera_up = Vector3D 0 1 0,-    camera_fov = fromDegrees 60 }-\end{code}--\subsection{The Main Dispatch}--\texttt{mainDispatch} transfers control of the main thread to a-subprogram based on the state of the engine.  For example, menu-related-states dispatch to \texttt{menuDispatch} which manages the menu gui.--\texttt{mainHeader} guards against changes in the engine state.-Whenever the state changes, the header switches to \texttt{mainDispatch}.--\begin{code}-mainStateHeader :: (String -> Bool) -> RSAnimA1 () Camera () ()-mainStateHeader = genericStateHeader switchTo-  where switchTo menu_state | menu_state `elem` menu_states = menuManager-        switchTo planar_state | planar_state `elem` planar_states = planarGameplayDispatch-	switchTo "game-over" = gameOver-	switchTo unknown_state = error $ "mainStateHeader: unrecognized state: " ++ unknown_state--genericStateHeader :: (String -> RSAnimA1 i o i o) -> (String -> Bool) -> RSAnimA1 i o i ()-genericStateHeader switchTo f = proc i ->-    do m_state <- driverGetAnswerA -< "state"-       switchContinue -< (if fmap f m_state == Just True then Nothing else fmap switchTo m_state,i)-       returnA -< ()--mainDispatch :: RSAnimA1 () Camera () Camera-mainDispatch = mainStateHeader (const False) >>> arr (const basic_camera)-\end{code}--\subsection{The Menu Dispatch}--\begin{code}-menu_states :: [String]-menu_states = ["race-selection",-               "class-selection"]-menuManager :: RSAnimA1 () Camera () Camera-menuManager = proc () ->-    do mainStateHeader (`elem` menu_states) -< ()-       frp1Context menuDispatch -< ()--menuStateHeader :: (String -> Bool) -> RSAnimA1 () Camera () Camera-menuStateHeader f = genericStateHeader switchTo f >>> arr (const basic_camera)-  where switchTo "race-selection" = menuRaceSelection-        switchTo "class-selection" = menuClassSelection-        switchTo unknown_state = error $ "menuStateHeader: unrecognized state: " ++ unknown_state--menuDispatch :: RSAnimA1 () Camera () Camera-menuDispatch = menuStateHeader (const False) >>> arr (const basic_camera)--menuRaceSelection :: RSAnimA1 () Camera () Camera-menuRaceSelection = proc s -> -    do menuStateHeader (== "race-selection") -< s-       requestPrintTextMode -< Unlimited-       clearPrintTextA -< ()-       printMenuA select_race_action_names -< ()-       printTextA -< Just (Query,"Select a Race:")-       returnA -< basic_camera--menuClassSelection :: RSAnimA1 () Camera () Camera-menuClassSelection = proc () -> -    do menuStateHeader (== "class-selection") -< ()-       changed <- edgep <<< sticky isJust Nothing <<<arr (fmap table_created) <<< driverGetTableA -< ("player-stats","0")-       switchContinue -< (if changed then Just menuClassSelection else Nothing,())-       requestPrintTextMode -< Unlimited-       clearPrintTextA -< ()-       printCharacterStats 0 -< ()-       printMenuA select_base_class_action_names -< ()-       printMenuItemA "reroll" -< ()-       printTextA -< Just (Query,"Select a Class:")-       returnA -< basic_camera--printCharacterStats :: Integer -> RSAnimAX any t i o () ()-printCharacterStats unique_id = proc () ->-    do m_player_stats <- driverGetTableA -< ("player-stats",show unique_id)-       print1CharacterStat -< (m_player_stats,"str")-       print1CharacterStat -< (m_player_stats,"dex")-       print1CharacterStat -< (m_player_stats,"con")-       print1CharacterStat -< (m_player_stats,"int")-       print1CharacterStat -< (m_player_stats,"per")-       print1CharacterStat -< (m_player_stats,"cha")-       print1CharacterStat -< (m_player_stats,"mind")--print1CharacterStat :: RSAnimAX any t i o (Maybe RoguestarTable,String) ()-print1CharacterStat = proc (m_player_stats,stat_str) ->-    do let m_stat_int = (\x -> tableLookupInteger x ("property","value") stat_str) =<< m_player_stats-       printTextA -< fmap (\x -> (Event,hrstring stat_str ++ ": " ++ show x)) m_stat_int-\end{code}--\subsection{The Game Over State}--\begin{code}-gameOver :: RSAnimA1 () Camera () Camera-gameOver = proc () ->-    do printTextOnce -< Just (Event,"You have been killed.")-       returnA -< basic_camera-\end{code}--\subsection{The Planar Gameplay Dispatch}--\begin{code}-planar_states :: [String]-planar_states = ["player-turn","pickup","drop","wield","attack","miss","killed"]--planarGameplayDispatch :: RSAnimA1 () Camera () Camera-planarGameplayDispatch = proc () ->-    do mainStateHeader (`elem` planar_states) -< () -       clearPrintTextOnce -< ()-       frp1Context eventMessager -< ()-       frpContext (maybeThreadIdentity terrainTileThreadIdentity) [(Nothing,terrainThreadLauncher)] -< ()-       ctos <- arr (catMaybes . map (uncurry $ liftA2 (,))) <<< -           frpContext (maybeThreadIdentity $ unionThreadIdentity (==)) -	       [(Nothing,visibleObjectThreadLauncher creatureAvatar)] -< ()-       frpContext (maybeThreadIdentity $ unionThreadIdentity (==)) [(Nothing,visibleObjectThreadLauncher toolAvatar)] -< -           ToolThreadInput {-	       tti_wield_points = Map.fromList $ map (\(uid,cto) -> (uid,cto_wield_point cto)) ctos } -       lookat <- whenJust (approachA 1.0 (perSecond 3.0)) <<< sticky isJust Nothing <<<-           arr (fmap (\(x,y) -> Point3D (realToFrac x) 0 (negate $ realToFrac y))) <<< centerCoordinates -< ()-       accumulateSceneA -< (Infinite,lightSource $ DirectionalLight (Vector3D 0.15 1 (-0.3)) (scaleRGB 0.4 $ rgb 1.0 0.9 0.75) (scaleRGB 0.2 $ rgb 0.75 0.9 1.0))-       returnA -< maybe basic_camera cameraLookAtToCamera lookat--cameraLookAtToCamera :: Point3D -> Camera-cameraLookAtToCamera look_at = PerspectiveCamera {-    camera_position = translate (Vector3D 0 3 3) look_at,-    camera_lookat = look_at,-    camera_up = Vector3D 0 1 0,-    camera_fov = fromDegrees 60 }--centerCoordinates :: RSAnimAX any t i o () (Maybe (Integer,Integer))-centerCoordinates = proc () ->-    do m_center_coordinates_table <- sticky isJust Nothing <<< driverGetTableA -< ("center-coordinates","0")-       returnA -< do center_coordinates_table <- m_center_coordinates_table-                     x <- tableLookupInteger center_coordinates_table ("axis","coordinate") "x" -- Maybe monad-                     y <- tableLookupInteger center_coordinates_table ("axis","coordinate") "y" -		     return (x,y)-\end{code}--\subsection{Terrain}--\begin{code}-terrainThreadLauncher :: RSAnimA (Maybe ProtocolTypes.TerrainTile) () () () ()-terrainThreadLauncher = spawnThreads <<< arr (map (\x -> (Just x,terrainTile x))) <<< terrainElements--terrainTile :: ProtocolTypes.TerrainTile -> RSAnimA (Maybe ProtocolTypes.TerrainTile) () () () ()-terrainTile terrain_tile = proc () ->-    do t <- threadTime -< ()-       still_here <- renderTerrainTile terrain_tile -< fromSeconds $ min 0 $ toSeconds t - 1-       switchTerminate -< (if still_here then Nothing else Just $ terrainTile_Descending terrain_tile,())-       -terrainTile_Descending :: ProtocolTypes.TerrainTile -> RSAnimA (Maybe ProtocolTypes.TerrainTile) () () () ()-terrainTile_Descending terrain_tile = proc () ->-    do t <- threadTime -< ()-       killThreadIf -< t >= fromSeconds 1-       renderTerrainTile terrain_tile -< t-       returnA -< ()--renderTerrainTile :: ProtocolTypes.TerrainTile -> RSAnimA t i o Time Bool-renderTerrainTile (ProtocolTypes.TerrainTile terrain_type (x,y)) = proc t ->-    do let awayness = max 0 $ min 0.99 $ (toSeconds t)^2-       terrain_elements <- terrainElements -< ()-       transformA libraryA -< (Affine $ translate (Vector3D (realToFrac x) 0 (negate $ realToFrac y)) . scale' (1 - awayness),-                               (Local,Models.LibraryData.TerrainTile terrain_type))-       returnA -< isJust $ find (\a -> tt_xy a == (x,y)) terrain_elements--terrainElements :: RSAnimA t i o () [ProtocolTypes.TerrainTile]-terrainElements = arr (maybe [] tableSelectTyped) <<< sticky isJust Nothing <<< driverGetTableA <<< arr (const ("visible-terrain","0"))--terrainTileThreadIdentity :: ThreadIdentity ProtocolTypes.TerrainTile-terrainTileThreadIdentity = unionThreadIdentity (\a b -> tt_xy a == tt_xy b)-\end{code}--\subsection{Creatures and Objects}--\begin{code}-data CreatureThreadOutput = CreatureThreadOutput {-    cto_wield_point :: CoordinateSystem }--class AbstractEmpty a where-    abstractEmpty :: a--instance AbstractEmpty () where-    abstractEmpty = ()--instance AbstractEmpty (Maybe a) where-    abstractEmpty = Nothing--visibleObjectThreadLauncher :: (AbstractEmpty o) => RSAnimA (Maybe Integer) i o i o -> RSAnimA (Maybe Integer) i o i o-visibleObjectThreadLauncher avatarA = arr (const abstractEmpty) <<< spawnThreads <<< arr (map (\x -> (Just x,avatarA))) <<< allObjects <<< arr (const ())--objectTypeGuard :: (String -> Bool) -> RSAnimA (Maybe Integer) a b () ()-objectTypeGuard f = proc () ->-    do m_obj_type <- objectDetailsLookup "object-type" -< ()-       killThreadIf -< maybe False (not . f) m_obj_type--creatureAvatar :: RSAnimA (Maybe Integer) () (Maybe CreatureThreadOutput) () (Maybe CreatureThreadOutput)-creatureAvatar = proc () ->-    do objectTypeGuard (== "creature") -< ()-       m_species <- objectDetailsLookup "species" -< ()-       switchContinue -< (fmap switchTo m_species,())-       returnA -< Nothing-  where switchTo "encephalon" = encephalonAvatar-        switchTo "recreant" = recreantAvatar-	switchTo "androsynth" = androsynthAvatar-	switchTo "ascendant" = ascendantAvatar-	switchTo "caduceator" = caduceatorAvatar-	switchTo "reptilian" = reptilianAvatar-        switchTo _ = questionMarkAvatar--genericCreatureAvatar :: RSAnimA (Maybe Integer) () (Maybe CreatureThreadOutput) () CreatureThreadOutput ->-                         RSAnimA (Maybe Integer) () (Maybe CreatureThreadOutput) () (Maybe CreatureThreadOutput)-genericCreatureAvatar creatureA = proc () ->-    do visibleObjectHeader -< ()-       m_orientation <- objectIdealOrientation -< ()-       switchTerminate -< if isNothing m_orientation then (Just $ genericCreatureAvatar creatureA,Nothing) else (Nothing,Nothing)-       arr Just <<< transformA creatureA -< (fromMaybe (error "genericCreatureAvatar: fromMaybe") m_orientation,())--encephalonAvatar :: RSAnimA (Maybe Integer) () (Maybe CreatureThreadOutput) () (Maybe CreatureThreadOutput)-encephalonAvatar = genericCreatureAvatar $ proc () ->-    do libraryA -< (Local,Encephalon)-       wield_point <- exportCoordinateSystem <<< arr (joint_arm_hand . snd) <<< -           bothArms MachineArmUpper MachineArmLower (Vector3D 0.66 0.66 0) (Point3D 0.145 0.145 0) 0.33 (Point3D 0.35 0.066 0.133) -< ()-       returnA -< CreatureThreadOutput {-           cto_wield_point = wield_point }--recreantAvatar :: RSAnimA (Maybe Integer) () (Maybe CreatureThreadOutput) () (Maybe CreatureThreadOutput)-recreantAvatar = genericCreatureAvatar $ floatBobbing 0.25 0.4 $ proc () ->-    do libraryA -< (Local,Recreant)-       wield_point <- exportCoordinateSystem <<< arr (joint_arm_hand . snd) <<<-           bothArms MachineArmUpper MachineArmLower (Vector3D 0 (-1.0) 0) (Point3D 0.3 0.075 0) 0.5 (Point3D 0.5 0.075 0.2) -< ()-       returnA -< CreatureThreadOutput {-           cto_wield_point = wield_point }--androsynthAvatar :: RSAnimA (Maybe Integer) () (Maybe CreatureThreadOutput) () (Maybe CreatureThreadOutput)-androsynthAvatar = genericCreatureAvatar $ proc () ->-    do libraryA -< (Local,Androsynth)-       bothLegs ThinLimb ThinLimb (Vector3D 0 0 1) (Point3D (0.07) 0.5 (-0.08)) 0.7 (Point3D 0.07 0 0.0) -< ()-       wield_point <- exportCoordinateSystem <<< arr (joint_arm_hand . snd) <<<-           bothArms ThinLimb ThinLimb (Vector3D (1.0) (-1.0) (-1.0)) (Point3D 0.05 0.65 0.0) 0.45 (Point3D 0.15 0.34 0.1) -< ()-       returnA -< CreatureThreadOutput {-           cto_wield_point = wield_point }--glower :: Point3D -> Vector3D -> RSAnimA (Maybe Integer) i o () ()-glower p_init v_init = proc () ->-    do local_origin <- exportToA root_coordinate_system -< origin_point_3d-       transformA-           (accelerationModel fps120 (p_init,perSecond $ v_init) -                 (proc () -> -	             do a <- derivative <<< derivative <<< exportToA root_coordinate_system -< origin_point_3d-	 	        returnA -< concatForces [quadraticTrap 10 p_init,-	                                         drag 1.0,-			    		         \_ _ _ -> scalarMultiply (-1) a,-						 \_ _ _ -> perSecond $ perSecond v_init,-						 \_ p _ -> perSecond $ perSecond $ vectorNormalize $-						               vectorToFrom origin_point_3d p `crossProduct` v_init]) -	         (proc (_,()) -> libraryPointAtCamera -< (Local,AscendantGlow))) -< -	             (translateToFrom local_origin origin_point_3d $ root_coordinate_system,())--ascendantAvatar :: RSAnimA (Maybe Integer) () (Maybe CreatureThreadOutput) () (Maybe CreatureThreadOutput)-ascendantAvatar = genericCreatureAvatar $ proc () ->-    do glower (Point3D 0 0.5 0) zero -< ()-       glower (Point3D 0 0.5 0.35) (Vector3D 0 0 (-1)) -< ()-       glower (Point3D 0 0.5 (-0.35)) (Vector3D 0 0 1) -< ()-       glower (Point3D 0.35 0.5 0) (Vector3D (-1) 0 0) -< ()-       glower (Point3D (-0.35) 0.5 0) (Vector3D 1 0 0) -< ()-       accumulateSceneA -< (Local,-                            lightSource $ PointLight (Point3D 0 0.5 0)-                                                     (measure (Point3D 0 0.5 0) (Point3D 0 0 0))-						     azure-						     azure)-       t <- threadTime -< ()-       wield_point <- exportCoordinateSystem -< translate (rotateY (fromRotations $ t `cyclical'` (fromSeconds 3)) $ Vector3D 0.25 0.5 0)-       returnA -< CreatureThreadOutput {-           cto_wield_point = wield_point }--caduceatorAvatar :: RSAnimA (Maybe Integer) () (Maybe CreatureThreadOutput) () (Maybe CreatureThreadOutput)-caduceatorAvatar = genericCreatureAvatar $ proc () ->-    do libraryA -< (Local,Caduceator)-       wield_point <- exportCoordinateSystem <<< arr (joint_arm_hand . snd) <<<-           bothArms CaduceatorArmUpper CaduceatorArmLower (Vector3D 1.0 (-1.0) 1.0) (Point3D 0.1 0.15 0.257) 0.34 (Point3D 0.02 0.17 0.4) -< ()-       returnA -< CreatureThreadOutput {-           cto_wield_point = wield_point }--reptilianAvatar :: RSAnimA (Maybe Integer) () (Maybe CreatureThreadOutput) () (Maybe CreatureThreadOutput)-reptilianAvatar = genericCreatureAvatar $ proc () ->-    do libraryA -< (Local,Reptilian)-       bothLegs ReptilianLegUpper ReptilianLegLower (Vector3D 0 0 1) (Point3D (0.05) 0.25 (-0.1)) 0.29 (Point3D 0.07 0 0.0) -< ()-       wield_point <- exportCoordinateSystem <<< arr (joint_arm_hand . snd) <<<-           bothArms ReptilianArmUpper ReptilianArmLower (Vector3D 1.0 0.0 1.0) (Point3D (0.05) 0.35 (-0.1)) 0.25 (Point3D 0.07 0.25 0.12) -< ()-       returnA -< CreatureThreadOutput {-           cto_wield_point = wield_point }--toolAvatar :: RSAnimA (Maybe Integer) ToolThreadInput () ToolThreadInput ()-toolAvatar = proc tti ->-    do objectTypeGuard (== "tool") -< ()-       m_tool <- objectDetailsLookup "tool" -< ()-       switchContinue -< (fmap switchTo m_tool,tti)-       returnA -< ()-  where switchTo "phase_pistol" = phasePistolAvatar-        switchTo _ = questionMarkAvatar >>> arr (const ())--phasePistolAvatar :: RSAnimA (Maybe Integer) ToolThreadInput () ToolThreadInput ()-phasePistolAvatar = proc tti ->-    do visibleObjectHeader -< ()-       m_orientation <- wieldableObjectIdealOrientation -< tti-       transformA libraryA -< maybe (root_coordinate_system,(Local,NullModel))-                                    (\o -> (o,(Local,PhasePistol))) -				    m_orientation--floatBobbing :: Double -> Double -> RSAnimAX any t i o j p -> RSAnimAX any t i o j p-floatBobbing ay by animationA = proc j ->-    do t <- threadTime -< ()-       let float_y = lerpBetween (-1,sine $ fromRotations $ t `cyclical'` (fromSeconds 5),1) (ay,by)-       transformA animationA -< (Affine $ translate (Vector3D 0 float_y 0),j)--questionMarkAvatar :: RSAnimA (Maybe Integer) i o i (Maybe CreatureThreadOutput)-questionMarkAvatar = proc _ ->-    do visibleObjectHeader -< ()-       t <- threadTime -< ()-       m_object_type <- objectDetailsLookup "object-type" -< ()-       m_species <- objectDetailsLookup "species" -< ()-       m_tool <- objectDetailsLookup "tool" -< ()                -       debugOnce -< if any (isJust) [m_object_type,m_species,m_tool] -                    then (Just $ "questionMarkAvatar: apparently didn't recognize object: " ++ -		                 show m_object_type ++ ", " ++ show m_species ++ ", " ++ show m_tool)-		    else Nothing-       m_position <- objectIdealPosition -< ()-       let float_y = sine $ fromRotations $ t `cyclical'` (fromSeconds 5)-       let m_transform = fmap (translate (Vector3D 0 (0.7 + float_y/10) 0)) m_position -       transformA libraryA -< maybe (Affine id,(Local,NullModel)) (\p -> (Affine $ translateToFrom p origin_point_3d,(Local,QuestionMark))) m_transform-       m_wield_point <- whenJust exportCoordinateSystem -< fmap (\p -> translate (vectorToFrom p origin_point_3d `add` Vector3D 0.4 0 0)) m_transform -       returnA -< -           do wield_point <- m_wield_point-	      return $ CreatureThreadOutput {-                           cto_wield_point = wield_point }-\end{code}--\subsection{Messages}--\begin{code}-eventStateHeader :: (String -> Bool) -> RSAnimA1 () () () ()-eventStateHeader = genericStateHeader switchTo-    where switchTo s = fromMaybe eventMessager $ lookup s messages--eventMessager :: RSAnimA1 () () () ()-eventMessager = proc () -> -    do eventStateHeader (isNothing . flip lookup messages) -< () -       blockContinue -< True --messageState :: String -> RSAnimA1 () () () (Maybe String) -> (String,RSAnimA1 () () () ())-messageState s actionA = (s,eventStateHeader (== s) >>> (proc () ->-    do m_string <- actionA -< ()-       blockContinue -< isNothing m_string-       printTextOnce -< fmap ((,) Event) m_string))--messages :: [(String,RSAnimA1 () () () ())]-messages = [-    messageState "attack" $ proc () -> -        do m_weapon <- driverGetAnswerA -< "weapon-used"-	   returnA -< -	       do weapon <- m_weapon-	          return $ case () of-		      () | weapon == "0" -> "It attacks!  It hits!"-		      () | otherwise -> "You attack!  You hit!",-    messageState "miss" $ proc () -> -        do m_weapon <- driverGetAnswerA -< "weapon-used"-	   returnA -<-	       do weapon <- m_weapon-	          return $ case () of-		      () | weapon == "0" -> "It attacks!  It misses."-		      () | otherwise -> "You attack!  You miss.",-    messageState "killed" $ proc () -> -        do m_who_killed <- driverGetAnswerA -< "who-killed"-	   returnA -<-	       do who_killed <- m_who_killed-	          return $ case () of-		      () | who_killed == "2" -> "You are mortally wounded."-		      () | otherwise -> "You kill it!"]-\end{code}
+ src/Statistics.hs view
@@ -0,0 +1,79 @@+module Statistics+    (Statistics,newStatistics,runStatistics)+    where++import qualified Data.Vector.Unboxed as V+import Statistics.Sample as S+import Data.List as L+import Statistics.Quantile+import Control.Concurrent+import RSAGL.FRP.Time+import System.IO+import System.IO.Unsafe+import RSAGL.Math.AbstractVector+import Control.Monad+import RSAGL.Types+import Text.Printf+import Control.Exception++{-# NOINLINE error_pump #-}+error_pump :: Chan String+error_pump = unsafePerformIO $+    do pump <- newChan+       _ <- forkIO $ forever $+                do hPutStrLn stderr =<< readChan pump+       return pump++data Statistics = Statistics {+    statistics_sample :: MVar [Double],+    statistics_max :: MVar Double,+    statistics_avg :: MVar Double,+    statistics_time :: MVar Time,  -- time since last flushing of statistics+    statistics_name :: String }++newStatistics :: String -> IO Statistics+newStatistics name =+    do sample <- newMVar []+       t <- newMVar =<< getTime+       s_max <- newMVar 0+       s_avg <- newMVar 1000+       return $ Statistics {+           statistics_sample = sample,+           statistics_max = s_max,+           statistics_avg = s_avg,+           statistics_time = t,+           statistics_name = name }++runStatistics :: Statistics -> IO a -> IO a+runStatistics stats action =+    do t_start <- getTime+       a <- action+       t_end <- getTime+       let t_diff = f2f $ toSeconds $ t_end `sub` t_start+       modifyMVar_ (statistics_sample stats) $ return . (t_diff :)+       modifyMVar_ (statistics_max stats) $ return . (max t_diff)+       modifyMVar_ (statistics_avg stats) $ return . (\t -> (99*t + t_diff)/100)+       _ <- evaluate =<< readMVar (statistics_max stats)+       _ <- evaluate =<< readMVar (statistics_avg stats)+       modifyMVar_ (statistics_time stats) $ \t ->+           do let should_report = (toSeconds (t_end `sub` t) > 30)+              when should_report $ liftM (const ()) $ forkIO $+                  do modifyMVar_ (statistics_sample stats) $ \x ->+                         do let sv = V.fromList $ take (60*30) x :: Sample+                            let f = printf "%.4f" . (*60) :: Double -> String+                            writeChan error_pump $ "\nSTATISTICS " ++ statistics_name stats +++                                                   "\nMEAN       " ++ f (mean sv) +++                                                   "\nSTD DEV    " ++ f (stdDev sv) +++                                                   "\nKURTOSIS   " ++ f (kurtosis sv) +++                                                   "\nQUARTILES  " ++ (concat $ intersperse " | " $ map f $+				[continuousBy medianUnbiased 0 4 sv,+                                 continuousBy medianUnbiased 1 4 sv,+                                 continuousBy medianUnbiased 2 4 sv,+                                 continuousBy medianUnbiased 3 4 sv,+                                 continuousBy medianUnbiased 4 4 sv])+                            writeChan error_pump =<< liftM ((statistics_name stats ++ " lifetime maximum ") ++) (liftM f $ readMVar $ statistics_max stats)+                            writeChan error_pump =<< liftM ((statistics_name stats ++ " floating average ") ++) (liftM f $ readMVar $ statistics_avg stats)+                            return []+              return $ if should_report then t_end else t+       return a+
+ src/Strings.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE OverloadedStrings #-}+module Strings+    (replace,capitalize,hrstring)+    where++import Data.Char+import qualified Data.ByteString.Char8 as B++-- | Replace all instances of the first string with the second string in the third string.+-- @replace "old" "new" "What's old?"@+replace :: B.ByteString -> B.ByteString -> B.ByteString -> B.ByteString+replace a b s = case B.breakSubstring a s of+    (x,y) | B.null y  -> x+    (x,y) | otherwise -> x `B.append` b `B.append` replace a b (B.drop (B.length a) y)++-- | Just capitalize the first letter of the string.+capitalize :: B.ByteString -> B.ByteString+capitalize s = case B.uncons s of+    Nothing -> s+    Just (c,s') -> toUpper c `B.cons` s'++-- | Human readable strings, when we can't just rip the plaintext from the protocol.+hrstring :: B.ByteString -> B.ByteString+hrstring "str" =   "Strength     "+hrstring "spd" =   "Speed        "+hrstring "con" =   "Endurance    "+hrstring "int" =   "Intellect    "+hrstring "per" =   "Perception   "+hrstring "cha" =   "Charisma     "+hrstring "mind" =  "Mindfulness  "+hrstring "maxhp" = "Health       "+hrstring "forceadept" = "force adept"+hrstring x = B.map (\c -> if c == '_' then ' ' else c) x++
− src/Strings.lhs 
@@ -1,21 +0,0 @@-\section{Strings}--This section merely contains a mapping from strings used in the protocol to human-readable strings.-For example, "str" becomes "strength."--\begin{code}-module Strings-    (hrstring)-    where--hrstring :: String -> String-hrstring "str" = "strength"-hrstring "dex" = "dexterity"-hrstring "con" = "constitution"-hrstring "int" = "intelligence"-hrstring "per" = "perception"-hrstring "cha" = "charisma"-hrstring "mind" = "mindfulness"-hrstring "forceadept" = "force adept"-hrstring x = x-\end{code}
+ src/Tables.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE OverloadedStrings #-}+module Tables+    (RoguestarTable(..),+     TableDataFormat(..),+     tableSelect,+     tableSelectFormatted,+     tableLookup,+     tableLookupInteger,+     readInteger)+    where++import Data.List+import RSAGL.FRP.Time+import qualified Data.ByteString.Char8 as B++-- | 'RoguestarTable' is a crude implementation of a relational data table that is used to represent information that has been sent to us from roguestar-engine.+data RoguestarTable = RoguestarTable { table_created :: Time, table_name, table_id :: B.ByteString, table_header :: [B.ByteString], table_data :: [[B.ByteString]] }+                          deriving (Eq,Show)++-- | 'tableSelect' selects rows from a table, like the SQL select statement.+-- For example: \texttt{tableSelect people ["name","sex","phone-number"] = [["bob","male","123-4567"],["susan","female","987-6543"]]}+-- If a given header is not in the table, it lists \texttt{"???"} as the value.+--+-- There is a guarantee that all select functions will return results in the same order.+tableSelect :: RoguestarTable -> [B.ByteString] -> [[B.ByteString]]+tableSelect table headers = let header_indices = map (\x -> elemIndex x $ table_header table) headers+				in map (rowSelect header_indices) $ table_data table++rowSelect :: [Maybe Int] -> [B.ByteString] -> [B.ByteString]+rowSelect (Nothing:more) row = "???" : rowSelect more row+rowSelect (Just x:more) row = (row !! x) : rowSelect more row+rowSelect [] _ = []++-- | 'tableSelectFormatted' allows Selection of arbitrary strings and integers.+tableSelectFormatted :: RoguestarTable -> [TableDataFormat B.ByteString B.ByteString] -> [[TableDataFormat B.ByteString Integer]]+tableSelectFormatted table headers = map (toFormat headers) $ tableSelect table (map toString headers)++-- | "tableLookup table \(\"name\",\"phone-number\"\) \"bob\"" yields Bob\'s phone number, or nothing if \"bob\" isn\'t in the table.+tableLookup :: RoguestarTable -> (B.ByteString,B.ByteString) -> B.ByteString -> Maybe B.ByteString+tableLookup table (k,v) x = fmap (!! 1) $ find ((== x) . head) $ tableSelect table [k,v]++-- | 'tableLookupInteger' works as 'tableLookup', but answers an 'Integer'+tableLookupInteger :: RoguestarTable -> (B.ByteString,B.ByteString) -> B.ByteString -> Maybe Integer+tableLookupInteger table headers x = tableLookup table headers x >>= readInteger++data TableDataFormat s n = TDString s+                         | TDNumber n++readInteger :: B.ByteString -> Maybe Integer+readInteger = fmap fst . B.readInteger++toString :: TableDataFormat B.ByteString B.ByteString -> B.ByteString+toString (TDString str) = str+toString (TDNumber str) = str++toFormat :: [TableDataFormat a b] -> [B.ByteString] -> [TableDataFormat B.ByteString Integer]+toFormat headers row = zipWith toFormat_ headers row+    where toFormat_ (TDString {}) str = TDString str+          toFormat_ (TDNumber {}) str = maybe (TDString str) TDNumber $ readInteger str
− src/Tables.lhs 
@@ -1,81 +0,0 @@-\section{Tables}--\begin{code}-module Tables-    (RoguestarTable(..),-     TableDataFormat(..),-     tableSelect,-     tableSelectFormatted,-     tableLookup,-     tableLookupInteger)-    where--import Data.List-import Data.Maybe-import RSAGL.Time-import Control.Monad-\end{code}--\texttt{RoguestarTable} is a crude implementation of a relational data table that is used to represent information that has been sent to us from roguestar-engine.--\begin{code}-data RoguestarTable = RoguestarTable { table_created :: Time, table_name, table_id :: String, table_header :: [String], table_data :: [[String]] }-		      deriving (Eq,Show)-\end{code}--\texttt{tableSelect} selects rows from a table, like the SQL select statement.-For example: \texttt{tableSelect people ["name","sex","phone-number"] = [["bob","male","123-4567"],["susan","female","987-6543"]]}-If a given header is not in the table, it lists \texttt{"???"} as the value.--There is a guarantee that all select functions will return results in the same order.--\begin{code}-tableSelect :: RoguestarTable -> [String] -> [[String]]-tableSelect table headers = let header_indices = map (\x -> elemIndex x $ table_header table) headers-				in map (rowSelect header_indices) $ table_data table--rowSelect :: [Maybe Int] -> [String] -> [String]-rowSelect (Nothing:more) row = "???" : rowSelect more row-rowSelect (Just x:more) row = (row !! x) : rowSelect more row-rowSelect [] _ = []-\end{code}--\texttt{tableSelectFormatted} allows Selection of arbitrary strings and integers.--\begin{code}-tableSelectFormatted :: RoguestarTable -> [TableDataFormat String String] -> [[TableDataFormat String Integer]]-tableSelectFormatted table headers = map (toFormat headers) $ tableSelect table (map toString headers)-\end{code}--\texttt{tableLookup table ("name","phone-number") "bob"} yields Bob's phone number, or nothing if "bob" isn't in the table.--\begin{code}-tableLookup :: RoguestarTable -> (String,String) -> String -> Maybe String-tableLookup table (k,v) x = fmap (!! 1) $ find ((== x) . head) $ tableSelect table [k,v]-\end{code}--\texttt{tableLookupInteger} works as \texttt{tableLookup}, but answers an \texttt{Integer}.--\begin{code}-tableLookupInteger :: RoguestarTable -> (String,String) -> String -> Maybe Integer-tableLookupInteger table headers x = tableLookup table headers x >>= readInteger-\end{code}--\subsection{Formatting Arbitrary Table Elements}--\begin{code}-data TableDataFormat s n = TDString s-                         | TDNumber n--readInteger :: String -> Maybe Integer-readInteger = listToMaybe . map fst . reads--toString :: TableDataFormat String String -> String-toString (TDString str) = str-toString (TDNumber str) = str--toFormat :: [TableDataFormat a b] -> [String] -> [TableDataFormat String Integer]-toFormat headers row = zipWith toFormat_ headers row-    where toFormat_ (TDString {}) str = TDString str-          toFormat_ (TDNumber {}) str = maybe (TDString str) TDNumber $ readInteger str-\end{code}
+ src/VisibleObject.hs view
@@ -0,0 +1,232 @@+{-# LANGUAGE+    Arrows,+    OverloadedStrings,+    Rank2Types,+    TypeFamilies,+    FlexibleContexts #-}++module VisibleObject+    (ToolThreadInput(..),+     CreatureThreadOutput(..),+     AbstractEmpty(..),+     AvatarSwitch,+     visibleObjectThreadLauncher,+     objectTypeGuard,+     questionMarkAvatar,+     visibleObjects,+     allObjects,+     VisibleObjectReference(..),+     getVisibleObject,+     isBeingWielded,+     isWielding,+     visibleObject,+     objectDetailsLookup,+     objectDestination,+     objectIdealPosition,+     objectFacing,+     objectIdealFacing,+     objectIdealOrientation,+     visibleObjectHeader,+     wieldableObjectIdealOrientation)+    where++import RSAGL.FRP+import Data.Maybe+import ProtocolTypes+import Animation+import Tables+import Control.Arrow+import Data.List+import RSAGL.Animation+import AnimationExtras+import RSAGL.Math+import qualified Data.Set as Set+import qualified Data.Map as Map+import Control.Monad+import Scene+import Models.LibraryData+import qualified Data.ByteString.Char8 as B++data ToolThreadInput = ToolThreadInput {+    -- | Wield points of all creatures that are on screen.+    tti_wield_points :: Map.Map Integer CoordinateSystem }++data CreatureThreadOutput = CreatureThreadOutput {+    -- | Wield point for this creature.  This is the coordinate system in which+    -- a tool should be rendered, where the origin is the point at which the+    -- creature is grasping the weapon.+    cto_wield_point :: CoordinateSystem }++class AbstractEmpty a where+    abstractEmpty :: a++instance AbstractEmpty () where+    abstractEmpty = ()++instance AbstractEmpty (Maybe a) where+    abstractEmpty = Nothing++type AvatarSwitch i o m = RSwitch Enabled (Maybe Integer) i o m++-- | Avatar for unrecognized objects.  Basically this is a big conspicuous+-- warning that something is implemented in the engine but not in the client.+questionMarkAvatar :: (FRPModel m) => FRP e (AvatarSwitch i o m) i (Maybe CreatureThreadOutput)+questionMarkAvatar = proc _ ->+    do visibleObjectHeader -< ()+       t <- threadTime -< ()+       m_object_type <- objectDetailsLookup ThisObject "object-type" -< ()+       m_species <- objectDetailsLookup ThisObject "species" -< ()+       m_tool <- objectDetailsLookup ThisObject "tool" -< ()+       m_building <- objectDetailsLookup ThisObject "building" -< ()+       debugOnce -< if any (isJust) [m_object_type,m_species,m_tool]+                    then (Just $ B.concat $ ["questionMarkAvatar: apparently didn't recognize object: ",+		                 B.pack $ show m_object_type, ", ", B.pack $ show m_species, ", ", B.pack $ show m_tool, ", ", B.pack $ show m_building]) +		    else Nothing+       m_position <- objectIdealPosition ThisObject -< ()+       let float_y = sine $ fromRotations $ t `cyclical'` (fromSeconds 5)+       let m_transform = fmap (translate (Vector3D 0 (0.7 + float_y/10) 0)) m_position +       transformA libraryA -< maybe (Affine id,(scene_layer_local,NullModel))+           (\p -> (Affine $ translateToFrom p origin_point_3d,+                  (scene_layer_local,SimpleModel QuestionMark))) m_transform+       m_wield_point <- whenJust exportCoordinateSystem -< fmap (\p -> translate (vectorToFrom p origin_point_3d `add` Vector3D 0.4 0 0)) m_transform +       returnA -< +           do wield_point <- m_wield_point+	      return $ CreatureThreadOutput {+                           cto_wield_point = wield_point }+++-- | Launch threads to represent every visible object.+visibleObjectThreadLauncher :: (FRPModel m,AbstractEmpty o) =>+                               FRP e (AvatarSwitch i o m) i o ->+                               FRP e (AvatarSwitch i o m) i o+visibleObjectThreadLauncher avatarA =+    arr (const abstractEmpty) <<<+    spawnThreads <<<+    arr (map (\x -> (Just x,avatarA))) <<<+    newListElements <<< allObjects <<<+    arr (const ())++-- | Kill a thread if an object has the wrong \"object-type\" field, e.g. anything that isn't a \"creature\".+objectTypeGuard :: (FRPModel m, StateOf m ~ AnimationState, ThreadingOf m ~ Enabled, ThreadIDOf m ~ Maybe Integer) => (B.ByteString -> Bool) -> FRP e m () ()+objectTypeGuard f = proc () ->+    do m_obj_type <- objectDetailsLookup ThisObject "object-type" -< ()+       killThreadIf -< maybe False (not . f) m_obj_type++-- | Header function that just kills the current thread if it isn't a visible object.+visibleObjectHeader :: (FRPModel m, ThreadingOf m ~ Enabled, ThreadIDOf m ~ Maybe Integer, StateOf m ~ AnimationState) => FRP e m () ()+visibleObjectHeader = proc () ->+    do unique_id <- arr (fromMaybe (error "visibleObjectHeader: threadIdentity was Nothing")) <<< threadIdentity -< ()+       uids <- allObjects -< ()+       killThreadIf -< not $ unique_id `elem` uids++-- | List all 'VisibleObject' records.+visibleObjects :: (FRPModel m, StateOf m ~ AnimationState) => FRP e m () [VisibleObject]+visibleObjects = proc () -> arr (maybe [] tableSelectTyped) <<< sticky isJust Nothing <<< driverGetTableA -< ("visible-objects","0")++-- | List all object UIDs.+allObjects :: (FRPModel m,StateOf m ~ AnimationState) => FRP e m () [Integer]+allObjects = proc () ->+    do visible_object_ids <- arr (map vo_unique_id . maybe [] tableSelectTyped)+           <<< sticky isJust Nothing+           <<< driverGetTableA -< ("visible-objects","0")+       wielded_object_ids <- arr (map wo_unique_id . maybe [] tableSelectTyped)+           <<< sticky isJust Nothing+           <<< driverGetTableA -< ("wielded-objects","0")+       returnA -< Set.toList $ Set.fromList visible_object_ids `Set.union`+                               Set.fromList wielded_object_ids++{-------------------------------------------------------------------------------+  Retrieving information about specific visible objects.+-------------------------------------------------------------------------------}++-- | Indirect or direct reference to a visible object.+data VisibleObjectReference =+    ThisObject+  | UniqueID Integer+  | WieldedParent VisibleObjectReference+  | WieldedTool VisibleObjectReference+  | Attacker++-- | As a Tool, who is wielding you?+wieldedParent :: (FRPModel m,StateOf m ~ AnimationState) => FRP e m (Maybe Integer) (Maybe Integer)+wieldedParent = proc m_unique_id -> +    do wielded_pairs <- arr (maybe [] tableSelectTyped) <<< sticky isJust Nothing <<< driverGetTableA -< ("wielded-objects","0")+       returnA -< fmap wo_creature_id $ find ((== m_unique_id) . Just . wo_unique_id) wielded_pairs++-- | As a creature, what tool are you wielding?+wieldedTool :: (FRPModel m,StateOf m ~ AnimationState) => FRP e m (Maybe Integer) (Maybe Integer)+wieldedTool = proc m_unique_id ->+    do wielded_pairs <- arr (maybe [] tableSelectTyped) <<< sticky isJust Nothing <<< driverGetTableA -< ("wielded-objects","0")+       returnA -< fmap wo_unique_id $ find ((== m_unique_id) . Just . wo_creature_id) wielded_pairs++-- | Get the unique ID of the object specified.+getVisibleObject :: (FRPModel m, StateOf m ~ AnimationState, ThreadIDOf m ~ Maybe Integer) => VisibleObjectReference -> FRP e m () (Maybe Integer)+getVisibleObject (ThisObject) = threadIdentity+getVisibleObject (UniqueID unique_id) = proc () -> returnA -< Just unique_id+getVisibleObject (WieldedParent (WieldedTool ref)) = getVisibleObject ref+getVisibleObject (WieldedTool (WieldedParent ref)) = getVisibleObject ref+getVisibleObject (WieldedParent ref) = getVisibleObject ref >>> wieldedParent+getVisibleObject (WieldedTool ref) = getVisibleObject ref >>> wieldedTool+getVisibleObject Attacker = arr (const "who-attacks") >>> driverGetAnswerA >>> arr (maybe Nothing readInteger)++-- | As a Tool, are you currently being wielded by anyone?+isBeingWielded :: (FRPModel m,StateOf m ~ AnimationState,ThreadIDOf m ~ Maybe Integer) => VisibleObjectReference -> FRP e m () Bool+isBeingWielded obj = getVisibleObject (WieldedParent obj) >>> arr isJust++-- | As a Creature, are you currently wielding a tool?+isWielding :: (FRPModel m,StateOf m ~ AnimationState,ThreadIDOf m ~ Maybe Integer) => VisibleObjectReference -> FRP e m () Bool+isWielding obj = getVisibleObject (WieldedTool obj) >>> arr isJust++-- | Get the 'VisibleObject' record for any object.+visibleObject :: (FRPModel m,StateOf m ~ AnimationState,ThreadIDOf m ~ Maybe Integer) => VisibleObjectReference -> FRP e m () (Maybe VisibleObject)+visibleObject obj = proc () ->+    do m_unique_id <- getVisibleObject obj -< ()+       visible_objects <- visibleObjects -< ()+       returnA -< do find ((== m_unique_id) . Just . vo_unique_id) visible_objects++-- | Get an "object-details" field for the specified visible object.+objectDetailsLookup :: (FRPModel m,StateOf m ~ AnimationState,ThreadIDOf m ~ Maybe Integer) => VisibleObjectReference -> B.ByteString -> FRP e m () (Maybe B.ByteString)+objectDetailsLookup obj field = proc _ ->+    do m_unique_id <- getVisibleObject obj -< ()+       m_details_table <- arr (fromMaybe Nothing) <<< whenJust (driverGetTableA <<< arr (\x -> ("object-details",B.pack $ show x))) -< m_unique_id+       sticky isJust Nothing -< +           do details_table <- m_details_table+              tableLookup details_table ("property","value") field++-- | Grid position to which the specified object should move.+objectDestination :: (FRPModel m,StateOf m ~ AnimationState,ThreadIDOf m ~ Maybe Integer) => VisibleObjectReference -> FRP e m () (Maybe (Integer,Integer))+objectDestination obj = arr (fmap vo_xy) <<< visibleObject obj++-- | Correct position of the specified object, with smooth translation.+objectIdealPosition :: (FRPModel m,StateOf m ~ AnimationState,ThreadIDOf m ~ Maybe Integer) => VisibleObjectReference -> FRP e m () (Maybe Point3D)+objectIdealPosition obj = +    whenJust (approachA 0.25 (perSecond 3)) <<< +    arr (fmap (\(x,y) -> Point3D (realToFrac x) 0 (negate $ realToFrac y))) <<< +    objectDestination obj++-- | Goal direction in which the specified object should be pointed.+objectFacing :: (FRPModel m,StateOf m ~ AnimationState,ThreadIDOf m ~ Maybe Integer) => VisibleObjectReference -> FRP e m () (Maybe BoundAngle)+objectFacing obj = arr (fmap vo_facing) <<< visibleObject obj++-- | Direction in which the specified object should be pointed, with smooth rotation.+objectIdealFacing :: (FRPModel m,StateOf m ~ AnimationState,ThreadIDOf m ~ Maybe Integer) => VisibleObjectReference -> FRP e m () (Maybe Angle)+objectIdealFacing obj = arr (fmap unboundAngle) <<< whenJust (approachA 0.1 (perSecond 1)) <<< objectFacing obj++-- | Combine 'objectIdealPosition' and 'objectIdealFacing' to place an object.+objectIdealOrientation :: (FRPModel m,StateOf m ~ AnimationState,ThreadIDOf m ~ Maybe Integer) => VisibleObjectReference -> FRP e m () (Maybe CoordinateSystem)+objectIdealOrientation obj = proc () ->+    do m_p <- objectIdealPosition obj -< ()+       m_a <- objectIdealFacing obj -< ()+       returnA -< do p <- m_p+                     a <- m_a+		     return $ translate (vectorToFrom p origin_point_3d) $ rotateY a $ root_coordinate_system++-- | 'objectIdealOrientation' implementation that is aware of wield points for wieldable objects.  If an object is being+-- wielded, it will snap to it's wield point.+wieldableObjectIdealOrientation :: (FRPModel m,StateOf m ~ AnimationState,ThreadIDOf m ~ Maybe Integer) => VisibleObjectReference -> FRP e m ToolThreadInput (Maybe CoordinateSystem)+wieldableObjectIdealOrientation obj = proc tti ->+    do ideal_resting <- objectIdealOrientation obj -< ()+       m_wielded_parent <- getVisibleObject (WieldedParent obj) -< ()+       let wield_point = do wielded_parent <- m_wielded_parent+                            Map.lookup wielded_parent $ tti_wield_points tti+       returnA -< wield_point `mplus` ideal_resting
− src/VisibleObject.lhs 
@@ -1,117 +0,0 @@-\section{Visible Objects}--\begin{code}-{-# LANGUAGE Arrows #-}--module VisibleObject-    (ToolThreadInput(..),-     visibleObjects,-     allObjects,-     wieldedParent,-     wieldedTool,-     visibleObject,-     visibleObjectUniqueID,-     objectDetailsLookup,-     objectDestination,-     objectIdealPosition,-     objectFacing,-     objectIdealFacing,-     objectIdealOrientation,-     visibleObjectHeader,-     wieldableObjectIdealOrientation)-    where--import RSAGL.FRP-import RSAGL.Edge-import Data.Maybe-import ProtocolTypes-import Animation-import Tables-import Control.Arrow-import Data.List-import RSAGL.Time-import RSAGL.InverseKinematics-import RSAGL.Vector-import RSAGL.Angle-import RSAGL.Affine-import RSAGL.CoordinateSystems-import qualified Data.Set as Set-import qualified Data.Map as Map-import Control.Monad--data ToolThreadInput = ToolThreadInput {-    tti_wield_points :: Map.Map Integer CoordinateSystem }--visibleObjectHeader :: RSAnimA (Maybe Integer) i o () ()-visibleObjectHeader = proc () ->-    do unique_id <- arr (fromMaybe (error "visibleObjectHeader: threadIdentity was Nothing")) <<< threadIdentity -< ()-       uids <- allObjects -< ()-       killThreadIf -< isNothing $ find (== unique_id) uids--visibleObjects :: RSAnimAX any t i o () [VisibleObject]-visibleObjects = proc () -> arr (maybe [] tableSelectTyped) <<< sticky isJust Nothing <<< driverGetTableA -< ("visible-objects","0")--allObjects :: RSAnimAX any a i o () [Integer]-allObjects = proc () ->-    do visible_object_ids <- arr (map vo_unique_id . maybe [] tableSelectTyped) <<< sticky isJust Nothing <<< driverGetTableA -< ("visible-objects","0")-       wielded_object_ids <- arr (map wo_unique_id . maybe [] tableSelectTyped) <<< sticky isJust Nothing <<< driverGetTableA -< ("wielded-objects","0")-       returnA -< Set.toList $ Set.fromList visible_object_ids `Set.union` Set.fromList wielded_object_ids--wieldedParent :: RSAnimA (Maybe Integer) i o () (Maybe Integer)-wieldedParent = proc () -> -    do unique_id <- visibleObjectUniqueID -< ()-       wielded_pairs <- arr (maybe [] tableSelectTyped) <<< sticky isJust Nothing <<< driverGetTableA -< ("wielded-objects","0")-       returnA -< fmap wo_creature_id $ find ((== unique_id) . wo_unique_id) wielded_pairs--wieldedTool :: RSAnimA (Maybe Integer) i o () (Maybe Integer)-wieldedTool = proc () ->-    do unique_id <- visibleObjectUniqueID -< ()-       wielded_pairs <- arr (maybe [] tableSelectTyped) <<< sticky isJust Nothing <<< driverGetTableA -< ("wielded-objects","0")-       returnA -< fmap wo_unique_id $ find ((== unique_id) . wo_creature_id) wielded_pairs--visibleObjectUniqueID :: RSAnimA (Maybe Integer) i o () Integer-visibleObjectUniqueID = arr (fromMaybe (error "visibleObjectUniqueID: threadIdentity was Nothing")) <<< threadIdentity--visibleObject :: RSAnimA (Maybe Integer) i o () (Maybe VisibleObject)-visibleObject = proc () ->-    do unique_id <- visibleObjectUniqueID -< ()-       visible_objects <- visibleObjects -< ()-       returnA -< do find ((== unique_id) . vo_unique_id) visible_objects--objectDetailsLookup :: String -> RSAnimA (Maybe Integer) i o () (Maybe String)-objectDetailsLookup field = proc _ ->-    do unique_id <- visibleObjectUniqueID -< ()-       m_details_table <- driverGetTableA -< ("object-details",show unique_id)-       sticky isJust Nothing -< (\x -> tableLookup x ("property","value") field) =<< m_details_table--objectDestination :: RSAnimA (Maybe Integer) i o () (Maybe (Integer,Integer))-objectDestination = arr (fmap vo_xy) <<< visibleObject-    -objectIdealPosition :: RSAnimA (Maybe Integer) i o () (Maybe Point3D)-objectIdealPosition = -    whenJust (approachA 0.25 (perSecond 3)) <<< -    arr (fmap (\(x,y) -> Point3D (realToFrac x) 0 (negate $ realToFrac y))) <<< -    objectDestination--objectFacing :: RSAnimA (Maybe Integer) i o () (Maybe BoundAngle)-objectFacing = arr (fmap vo_facing) <<< visibleObject--objectIdealFacing :: RSAnimA (Maybe Integer) i o () (Maybe Angle)-objectIdealFacing = arr (fmap unboundAngle) <<< whenJust (approachA 0.1 (perSecond 1)) <<< objectFacing--objectIdealOrientation :: RSAnimA (Maybe Integer) i o () (Maybe CoordinateSystem)-objectIdealOrientation = proc () ->-    do m_p <- objectIdealPosition -< ()-       m_a <- objectIdealFacing -< ()-       returnA -< do p <- m_p-                     a <- m_a-		     return $ translate (vectorToFrom p origin_point_3d) $ rotateY a $ root_coordinate_system--wieldableObjectIdealOrientation :: RSAnimA (Maybe Integer) i o ToolThreadInput (Maybe CoordinateSystem)-wieldableObjectIdealOrientation = proc tti ->-    do ideal_resting <- objectIdealOrientation -< ()-       m_wielded_parent <- wieldedParent -< ()-       let wield_point = do wielded_parent <- m_wielded_parent-                            Map.lookup wielded_parent $ tti_wield_points tti-       returnA -< wield_point `mplus` ideal_resting-\end{code}