diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -1,17 +1,72 @@ module Main (main) where -{- This is a small shell wrapper. - What we do is we use the 'netpipes' program to set up a socket, and then we - tell the shell to set the roguestar server running; we pause briefly to give - it a chance to set up the socket. Then we open up the nice GL - interface. - The 'sleep 2' bit is ugly; we need it because if either one opens up and - can't find the socket at 5618, it'll just exit - it won't wait for the other - one to start up. It's a race condition, alas. -} -import System.Cmd (system) +import System.Process +import System.Exit +import Control.Concurrent +import System.Environment +import System.FilePath +import System.IO +import Control.Monad +import Paths_roguestar_gl + main :: IO () -main = do system $ "faucet 5618 --out --in --unix --once " ++ "roguestar-engine version over begin" ++ " &" - system "sleep 2" -- TODO: Figure out some in-Haskell way - system $ "hose localhost 5618 --out --in --unix " ++ "roguestar-gl" ++ " &" - return () +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 $ + do roguestar_engine_exit <- waitForProcess roguestar_engine + case roguestar_engine_exit of + ExitFailure x -> putStrLn $ "roguestar-engine terminated unexpectedly (" ++ show x ++ ")" + _ -> return () + return () + roguestar_gl_exit <- waitForProcess roguestar_gl + case roguestar_gl_exit of + ExitFailure x -> putStrLn $ "roguestar-gl terminated unexpectedly (" ++ show x ++ ")" + _ -> return () +pump :: Handle -> [(String,Handle)] -> IO () +pump from tos = + do mapM_ (flip hSetBuffering NoBuffering . snd) tos + hSetBuffering from NoBuffering + 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 + +readNumberOfProcessors :: IO (Maybe Int) +readNumberOfProcessors = flip catch (const $ return Nothing) $ liftM Just $ + do n <- getEnv "NUMBER_OF_PROCESSORS" + return $! read n + +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 diff --git a/roguestar-gl.cabal b/roguestar-gl.cabal --- a/roguestar-gl.cabal +++ b/roguestar-gl.cabal @@ -1,8 +1,8 @@ name: roguestar-gl -version: 0.2.1 +version: 0.2.2 license: OtherLicense license-file: LICENSE -author: Christopher Lane Hinson +author: Christopher Lane Hinson maintainer: Christopher Lane Hinson category: Game @@ -10,16 +10,16 @@ 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. Note that there is a runtime dependency on 'netpipes'. + 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. . - The Darcs repository is available at . + The git repository is available at . homepage: http://roguestar.downstairspeople.org/ -build-depends: base>3, containers, arrows, mtl, MonadRandom, GLUT, rsagl>=0.2.1 +build-depends: base>3, containers, arrows, mtl, MonadRandom, GLUT, rsagl >=0.2.2 && <0.3, filepath >1.1 --roguestar-engine==0.3 build-type: Simple tested-with: GHC==6.8.2 @@ -30,14 +30,17 @@ other-modules: Quality, ProtocolTypes, VisibleObject, Strings, WordGenerator, Driver, PrintTextData, Animation, - Actions, Limbs, Tables, PrintText, + Actions, Limbs, Tables, PrintText, CommandLine, Models.Androsynth, Models.QuestionMark, Models.Terrain, Models.RecreantFactory, Models.Recreant, Models.Ascendant, Models.Materials, Models.Reptilian, Models.Library, Models.MachineParts, Models.LibraryData, Models.Caduceator, - Models.Tree, Models.Encephalon, Models.PhaseWeapons, RenderingControl + 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 ghc-prof-options: -prof -auto-all executable: roguestar main-is: Main.hs build-depends: process +ghc-options: -Wall -threaded diff --git a/src/Actions.lhs b/src/Actions.lhs --- a/src/Actions.lhs +++ b/src/Actions.lhs @@ -12,10 +12,8 @@ where import System.Exit -import Control.Monad import Control.Monad.Error import Driver -import Data.IORef import Data.List import PrintText import Tables diff --git a/src/CommandLine.lhs b/src/CommandLine.lhs new file mode 100644 --- /dev/null +++ b/src/CommandLine.lhs @@ -0,0 +1,14 @@ +\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} diff --git a/src/Driver.lhs b/src/Driver.lhs --- a/src/Driver.lhs +++ b/src/Driver.lhs @@ -18,7 +18,6 @@ import System.IO import Tables import RSAGL.Time -import Control.Concurrent data RoguestarEngineState = RoguestarEngineState { restate_tables :: [RoguestarTable], diff --git a/src/Keymaps/BuiltinKeymaps.hs b/src/Keymaps/BuiltinKeymaps.hs new file mode 100644 --- /dev/null +++ b/src/Keymaps/BuiltinKeymaps.hs @@ -0,0 +1,27 @@ +module Keymaps.BuiltinKeymaps + (findKeymapOrDefault, + builtin_keymap_names, + builtin_keymaps) + where + +import Data.Char +import Data.List + +import Keymaps.Keymaps +import Keymaps.NumpadKeymap +import Keymaps.VIKeymap + +findKeymapOrDefault :: Maybe KeymapName -> Keymap +findKeymapOrDefault m_keymap_name = fixKeymap $ maybe vi_numpad_keymap id (m_keymap_name >>= (flip lookup builtin_keymaps . (map toLower))) + +builtin_keymap_names :: [KeymapName] +builtin_keymap_names = map fst builtin_keymaps + +builtin_keymaps :: [(KeymapName, Keymap)] +builtin_keymaps = [ + ("vi", vi_keymap), + ("numpad", numpad_keymap), + ("vi+numpad", vi_numpad_keymap)] + +vi_numpad_keymap :: Keymap +vi_numpad_keymap = union vi_keymap numpad_keymap diff --git a/src/Keymaps/CommonKeymap.hs b/src/Keymaps/CommonKeymap.hs new file mode 100644 --- /dev/null +++ b/src/Keymaps/CommonKeymap.hs @@ -0,0 +1,122 @@ +module Keymaps.CommonKeymap + (commonMovementKeymap,MovementKeymap(..),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"), + ("x","anachronid"), + (":anachronid","anachronid"), + ("a","androsynth"), + (":androsynth","androsynth"), + ("A","ascendant"), + (":ascendant","ascendant"), + ("c","caduceator"), + (":caduceator","caduceator"), + ("e","encephalon"), + (":encephalon","encephalon"), + ("g","goliath"), + (":goliath","goliath"), + ("h","hellion"), + (":hellion","hellion"), + ("k","kraken"), + (":kraken","kraken"), + ("m","myrmidon"), + (":myrmidon","myrmidon"), + ("p","perennial"), + (":perennial","perennial"), + ("r","reptilian"), + (":reptilian","reptilian"), + ("R","recreant"), + (":recreant","recreant"), + (".","reroll"), + (":reroll","reroll"), + ("b","barbarian"), + (":barbarian","barbarian"), + ("c","consular"), + (":consular","consular"), + ("e","engineer"), + (":engineer","engineer"), + ("a","forceadept"), + (":force-adept","forceadept"), + ("m","marine"), + (":marine","marine"), + ("n","ninja"), + (":ninja","ninja"), + ("p","pirate"), + (":pirate","pirate"), + ("s","scout"), + (":scout","scout"), + ("S","shepherd"), + (":shepherd","shepherd"), + ("t","thief"), + (":thief","thief"), + ("w","warrior"), + (":warrior","warrior"), + ("#quit","quit"), + (",","pickup"), + (":pickup","pickup"), + ("d","drop"), + (":drop","drop"), + ("w","wield"), + (":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")] diff --git a/src/Keymaps/Keymaps.lhs b/src/Keymaps/Keymaps.lhs new file mode 100644 --- /dev/null +++ b/src/Keymaps/Keymaps.lhs @@ -0,0 +1,77 @@ +\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} diff --git a/src/Keymaps/NumpadKeymap.hs b/src/Keymaps/NumpadKeymap.hs new file mode 100644 --- /dev/null +++ b/src/Keymaps/NumpadKeymap.hs @@ -0,0 +1,21 @@ +module Keymaps.NumpadKeymap + (numpad_movement_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 diff --git a/src/Keymaps/VIKeymap.hs b/src/Keymaps/VIKeymap.hs new file mode 100644 --- /dev/null +++ b/src/Keymaps/VIKeymap.hs @@ -0,0 +1,21 @@ +module Keymaps.VIKeymap + (vi_movement_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 diff --git a/src/Limbs.lhs b/src/Limbs.lhs --- a/src/Limbs.lhs +++ b/src/Limbs.lhs @@ -11,10 +11,8 @@ where import VisibleObject import Animation -import RSAGL.Animation import RSAGL.Joint import RSAGL.Affine -import Models.Library import Models.LibraryData import Control.Arrow import RSAGL.Vector diff --git a/src/Main.lhs b/src/Main.lhs --- a/src/Main.lhs +++ b/src/Main.lhs @@ -10,7 +10,6 @@ import System.IO import PrintText --import Quality -import Data.IORef import Data.Maybe import Data.List import Graphics.UI.GLUT @@ -26,15 +25,12 @@ --import Camera import Animation import RSAGL.Scene -import RSAGL.Vector -import RSAGL.Angle -import Control.Arrow import Models.Library import System.Timeout import System.Exit roguestar_client_version :: String -roguestar_client_version = "0.2.1" +roguestar_client_version = "0.2.2" default_window_size :: Size default_window_size = Size 800 600 diff --git a/src/Models/MachineParts.hs b/src/Models/MachineParts.hs --- a/src/Models/MachineParts.hs +++ b/src/Models/MachineParts.hs @@ -6,7 +6,6 @@ import Quality import RSAGL.Model -import RSAGL.ModelingExtras import RSAGL.CurveExtras import RSAGL.Affine import RSAGL.Vector diff --git a/src/Models/PhaseWeapons.hs b/src/Models/PhaseWeapons.hs --- a/src/Models/PhaseWeapons.hs +++ b/src/Models/PhaseWeapons.hs @@ -6,7 +6,6 @@ import Models.Materials import RSAGL.Vector import RSAGL.Model -import RSAGL.ModelingExtras import RSAGL.Affine import RSAGL.CurveExtras import RSAGL.Angle diff --git a/src/Models/QuestionMark.hs b/src/Models/QuestionMark.hs --- a/src/Models/QuestionMark.hs +++ b/src/Models/QuestionMark.hs @@ -2,7 +2,6 @@ (question_mark) where -import Quality import RSAGL.Model import RSAGL.ModelingExtras import RSAGL.Affine diff --git a/src/Models/Recreant.hs b/src/Models/Recreant.hs --- a/src/Models/Recreant.hs +++ b/src/Models/Recreant.hs @@ -5,8 +5,6 @@ import Quality import RSAGL.Model import RSAGL.CurveExtras -import RSAGL.Material -import RSAGL.ModelingExtras import RSAGL.Vector import RSAGL.Affine import Models.Materials diff --git a/src/Models/RecreantFactory.hs b/src/Models/RecreantFactory.hs --- a/src/Models/RecreantFactory.hs +++ b/src/Models/RecreantFactory.hs @@ -4,11 +4,7 @@ import Quality import RSAGL.Model -import RSAGL.CurveExtras -import RSAGL.Material -import RSAGL.ModelingExtras import RSAGL.Vector -import RSAGL.Affine import Models.Materials recreant_factory :: Quality -> Modeling () diff --git a/src/Models/Terrain.lhs b/src/Models/Terrain.lhs --- a/src/Models/Terrain.lhs +++ b/src/Models/Terrain.lhs @@ -12,7 +12,6 @@ import RSAGL.ModelingExtras import Models.Tree import RSAGL.Vector -import RSAGL.Curve import RSAGL.Interpolation import RSAGL.Affine import RSAGL.Angle diff --git a/src/Models/Tree.hs b/src/Models/Tree.hs --- a/src/Models/Tree.hs +++ b/src/Models/Tree.hs @@ -6,9 +6,7 @@ import RSAGL.ModelingExtras import RSAGL.Vector import Control.Monad.Random -import Control.Monad.Trans import Quality -import Control.Monad import RSAGL.Affine import RSAGL.AbstractVector import RSAGL.Interpolation diff --git a/src/RenderingControl.lhs b/src/RenderingControl.lhs --- a/src/RenderingControl.lhs +++ b/src/RenderingControl.lhs @@ -27,14 +27,12 @@ import RSAGL.Time import RSAGL.AbstractVector import VisibleObject -import Data.Fixed import RSAGL.InverseKinematics import RSAGL.AnimationExtras import Actions import Strings import Control.Applicative import qualified Data.Map as Map -import Data.Monoid import Limbs import RSAGL.Joint import RSAGL.AbstractVector diff --git a/src/Tables.lhs b/src/Tables.lhs --- a/src/Tables.lhs +++ b/src/Tables.lhs @@ -14,7 +14,6 @@ import Data.Maybe import RSAGL.Time import Control.Monad -import RSAGL.AbstractVector \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. diff --git a/src/VisibleObject.lhs b/src/VisibleObject.lhs --- a/src/VisibleObject.lhs +++ b/src/VisibleObject.lhs @@ -35,7 +35,6 @@ import RSAGL.Angle import RSAGL.Affine import RSAGL.CoordinateSystems -import Control.Applicative import qualified Data.Set as Set import qualified Data.Map as Map import Control.Monad