starrover2 (empty) → 0.0.9
raw patch · 30 files changed
+2845/−0 lines, 30 filesdep +EdisonCoredep +FTGLdep +OpenGLsetup-changedbinary-added
Dependencies added: EdisonCore, FTGL, OpenGL, SDL, base, bytestring, directory, haskell98, mtl, random
Files
- LICENSE +23/−0
- Setup.hs +3/−0
- share/DejaVuSans.ttf binary
- share/DejaVuSansMono.ttf binary
- src/AObject.hs +110/−0
- src/Camera.hs +43/−0
- src/Cargo.hs +148/−0
- src/Collision.hs +13/−0
- src/Combat.hs +380/−0
- src/Entity.hs +72/−0
- src/Main.hs +174/−0
- src/Mission.hs +49/−0
- src/OpenGLUtils.hs +67/−0
- src/Politics.hs +78/−0
- src/SDLUtils.hs +138/−0
- src/Space.hs +125/−0
- src/SpaceState/City.hs +292/−0
- src/SpaceState/Combat.hs +95/−0
- src/SpaceState/Common.hs +39/−0
- src/SpaceState/Difficulty.hs +21/−0
- src/SpaceState/Game.hs +182/−0
- src/SpaceState/Init.hs +66/−0
- src/SpaceState/Input.hs +74/−0
- src/SpaceState/Space.hs +113/−0
- src/Statistics.hs +96/−0
- src/TextScreen.hs +113/−0
- src/Tree.hs +27/−0
- src/Universe.hs +52/−0
- src/Utils.hs +191/−0
- starrover2.cabal +61/−0
+ LICENSE view
@@ -0,0 +1,23 @@+Copyright (c) 2010 Antti Salonen++Permission is hereby granted, free of charge, to any person+obtaining a copy of this software and associated documentation+files (the "Software"), to deal in the Software without+restriction, including without limitation the rights to use,+copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the+Software is furnished to do so, subject to the following+conditions:++The above copyright notice and this permission notice shall be+included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES+OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT+HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,+WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING+FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR+OTHER DEALINGS IN THE SOFTWARE.+
+ Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple+main = defaultMain+
binary file changed (absent → 622280 bytes)
binary file changed (absent → 321524 bytes)
+ src/AObject.hs view
@@ -0,0 +1,110 @@+module AObject+where++import Data.Maybe+import Data.Foldable++import Graphics.Rendering.OpenGL as OpenGL++import OpenGLUtils+import Entity+import Collision+import Utils+import Tree++data AObject = AObject {+ aobjName :: String+ , angle :: GLdouble+ , color :: Color4 GLfloat+ , size :: GLdouble+ , orbitalSpeedcoeff :: GLdouble+ , orbitRadius :: GLdouble+ , barycenter :: GLvector3+ , colonyOwner :: Maybe String+ }++modifyAngle :: (GLdouble -> GLdouble) -> AObject -> AObject+modifyAngle f t = t{angle = f (angle t)}++modifyBarycenter :: (GLvector3 -> GLvector3) -> AObject -> AObject+modifyBarycenter f t = t{barycenter = f (barycenter t)}++nullBarycenters :: AObjTree -> AObjTree+nullBarycenters (Leaf a) = Leaf (modifyBarycenter (const glVector3Null) a)+nullBarycenters (Node n ts) = Node n (map nullBarycenters ts)++setupBarycenters :: AObjTree -> AObjTree+setupBarycenters = updateBarycenters . nullBarycenters++updateBarycenters :: AObjTree -> AObjTree+updateBarycenters = go glVector3Null+ where go disp (Leaf a) = + Leaf (modifyBarycenter (*+* disp) a)+ go disp (Node (ang, rad) ts) = + Node (ang, rad) + (map (go ((getPosition' ang rad) *+* disp)) ts)++type Orbit = (GLdouble, GLdouble) -- angle, orbitRadius++type AObjTree = Tree Orbit AObject++nullAObjTree :: AObjTree+nullAObjTree = Node (0.0, 0.0) []++aobjToEntities :: AObject -> (Entity, Entity)+aobjToEntities a = (e, o)+ where e = newEntity + (sin (degToRad $ angle a) * (orbitRadius a),+ cos (degToRad $ angle a) * (orbitRadius a),+ 0)+ 0+ (AObject.color a)+ Polygon+ (circlePoints 16)+ (glVector3AllUnit *** (size a))+ o = newEntity+ glVector3Null+ 0+ (Color4 0.5 0.5 0.5 0.1)+ LineLoop+ (circlePoints 128)+ (glVector3AllUnit *** (orbitRadius a))++aobjPoints = circlePoints 32+aorbitPoints = circlePoints 128+aorbitColor = Color4 0.5 0.5 0.5 (1 :: GLfloat)++getPosition :: AObject -> GLvector3+getPosition aobj = + (getPosition' (angle aobj) (orbitRadius aobj)) *+* + (barycenter aobj)++getPosition' :: GLdouble -> GLdouble -> GLvector3+getPosition' a' r = + let a = degToRad a'+ in (r * cos a, r * sin a, 0)++findCollisions :: (Foldable f) => ((GLdouble, GLdouble), (GLdouble, GLdouble)) -> f AObject -> Maybe AObject+findCollisions plbox aobs = + listToMaybe . catMaybes $ map colliding (toList aobs)+ where colliding aobj =+ if collides2d plbox abox+ then Just aobj+ else Nothing+ where (objcoordx, objcoordy, _) = AObject.getPosition aobj+ abox = boxArea (objcoordx, objcoordy) (size aobj)++planetNameToAllegiance :: AObjTree -> String -> String+planetNameToAllegiance aobs planetname =+ fromMaybe "Unknown" (fmap aobjName (find (\a -> aobjName a == planetname) aobs))++getAllegiance :: AObject -> String+getAllegiance a = fromMaybe "Unknown" (colonyOwner a)++hasOwner :: String -> AObject -> Bool+hasOwner alleg a = case colonyOwner a of+ Nothing -> False+ Just n -> n == alleg++hasSomeOwner :: AObject -> Bool+hasSomeOwner = isJust . colonyOwner
+ src/Camera.hs view
@@ -0,0 +1,43 @@+module Camera+where++import Graphics.Rendering.OpenGL as OpenGL++import OpenGLUtils++type Camera = ((GLdouble, GLdouble), (GLdouble, GLdouble))++setCamera :: Camera -> IO ()+setCamera ((minx, miny), (diffx, diffy)) = do+ matrixMode $= Projection+ loadIdentity+ ortho minx (minx + diffx) miny (miny + diffy) (-10) 10+ matrixMode $= Modelview 0++setZoom :: GLdouble -> Camera -> Camera+setZoom z ((minx, miny), (diffx, diffy)) =+ let ndiffx = z+ ndiffy = z * (diffy / diffx)+ ocent = (minx + diffx / 2, miny + diffy / 2, 0)+ in setCentre ocent ((0, 0), (ndiffx, ndiffy))++setCentre :: GLvector3 -> Camera -> Camera+setCentre (nx, ny, _) ((_, _), (diffx, diffy)) =+ ((nx - diffx / 2, ny - diffy / 2), (diffx, diffy))++data CameraState = CameraState {+ camera :: Camera+ , camzoom :: GLdouble+ , camzoomdelta :: GLdouble+ }++modCamera :: (Camera -> Camera) -> CameraState -> CameraState+modCamera f t = t{camera = f (camera t)}++modCamZoom :: (GLdouble -> GLdouble) -> CameraState -> CameraState+modCamZoom f t = t{camzoom = f (camzoom t)}++modCamZoomDelta :: (GLdouble -> GLdouble) -> CameraState -> CameraState+modCamZoomDelta f t = t{camzoomdelta = f (camzoomdelta t)}++
+ src/Cargo.hs view
@@ -0,0 +1,148 @@+{-# LANGUAGE NoMonomorphismRestriction #-}+module Cargo(Cargo, Market,+ randomCargo, randomMarket,+ showCargo, showMarket,+ fromMarket, fromCargo,+ withdraw,+ tradeScreen, takeScreen)+where++import System.Random+import Text.Printf+import Data.List+import Control.Monad+import Control.Monad.State as State++import qualified Data.Edison.Assoc.StandardMap as M+import Graphics.Rendering.OpenGL as OpenGL+import Graphics.UI.SDL as SDL+import Graphics.Rendering.FTGL as FTGL++import Statistics+import TextScreen+import Space+import SDLUtils++type Cargo = M.FM String Int+type Market = M.FM String (Int, Int)++cargonames = sort ["Grain", "Fruit", "Gem stones", "Firearms"]++randomCargo :: IO String+randomCargo = chooseIO cargonames++showCargo :: Cargo -> String+showCargo c | M.null c = "No cargo\n"+ | otherwise = concatMap (\(k, v) -> printf "%-20s-%4d\n" k v) (M.toOrdSeq c) ++showMarket :: Market -> String+showMarket m = title ++ infos+ where title = printf "%-16s%8s%8s\n" "Good" "Quantity" "Price"+ infos = concatMap (\(n, (q, p)) -> printf "%-20s%10d%10d\n" n q p) (M.toOrdSeq m)++numCargoItems = length cargonames++randomMarket :: IO Market+randomMarket = do+ let names = cargonames+ prices <- replicateM numCargoItems $ randomRIO (5, 15)+ quantities <- replicateM numCargoItems $ randomRIO (0, 30)+ return $ M.fromSeq $ zip names (zip quantities prices)++fitCargo :: Cargo -> [(String, Int)]+fitCargo c = map (\s -> (s, M.lookupWithDefault 0 s c)) cargonames++cargoToMarket :: Cargo -> Market+cargoToMarket cargo = + foldl' (\acc x -> M.insert x (M.lookupWithDefault 0 x cargo, 0) acc) M.empty cargonames++fromMarket :: Int -> String -> Market -> Market+fromMarket q = toMarket (-q)++fromCargo :: Int -> String -> Cargo -> Cargo+fromCargo q = toCargo (-q)++toMarket :: Int -> String -> Market -> Market+toMarket q = M.adjust (\(q', p) -> (q' + q, p))++toCargo :: Int -> String -> Cargo -> Cargo+toCargo q n = M.insertWith (+) n q++showMarketAndCargo :: Bool -> Market -> Cargo -> String+showMarketAndCargo t m c = title ++ infos+ where title = if t+ then printf "%-14s%9s%6s%6s\n" "Good" "Quantity" "Price" "Cargo"+ else printf "%-17s%-12s%-9s\n" "Good" "Captured" "Cargo"+ infos = if t+ then concatMap (\((n, (q, p)), (_, q')) -> printf "%-14s%9d%6d%6d\n" n q p q') (zip (M.toOrdSeq m) (fitCargo c))+ else concatMap (\((n, (q, _)), (_, q')) -> printf "%-17s%-12d%-9d\n" n q q') (zip (M.toOrdSeq m) (fitCargo c))++type TradeState = (Market, Cargo, Int, Int)+type TakeState = (Cargo, Cargo, Int, Int)++buy :: Int -> String -> StateT TradeState IO ()+buy q n = do+ (market, cargo, cash, holdspace) <- State.get+ let mval = M.lookupM n market+ case mval of+ Nothing -> return ()+ Just (q', p) -> do+ let totalq = minimum [max 0 q', q, holdspace]+ let totalp = totalq * p+ if totalp > cash || totalq == 0+ then return ()+ else do+ State.put (fromMarket totalq n market,+ toCargo totalq n cargo,+ subtract totalp cash,+ holdspace - totalq)++sell :: Int -> String -> StateT TradeState IO ()+sell q n = do+ (_, cargo, _, _) <- State.get+ let mval = M.lookupM n cargo+ case mval of+ Nothing -> return ()+ Just q' -> buy (negate (min q' q)) n++tradeScreen :: String -> Font -> Font -> StateT TradeState IO ()+tradeScreen = screenGeneric True++withdraw :: Int -> String -> StateT TradeState IO ()+withdraw q n = withStateT (\(m, c, _, hold) -> (m, c, maxBound, hold)) (buy q n)++screenGeneric :: Bool -> String -> Font -> Font -> StateT TradeState IO ()+screenGeneric trade str f1 f2 = do+ (market, _, _, _) <- State.get+ let exitb = ((100, 100), (100, 30))+ buybuttons = map (\i -> ((550, 440 - 50 * fromIntegral i), (100, 30))) [1..numCargoItems]+ sellbuttons = map (\i -> ((680, 440 - 50 * fromIntegral i), (100, 30))) [1..numCargoItems]+ buyactions = map (\(n, (_, _)) -> buy 1 n >> return Nothing) (M.toOrdSeq market)+ sellactions = map (\(n, (_, _)) -> sell 1 n >> return Nothing) (M.toOrdSeq market)+ allbuttons = exitb : (buybuttons ++ sellbuttons)+ allactions = return (Just ()) : (buyactions ++ sellactions)+ bttoaction = zip allbuttons allactions+ let handleInput = do+ events <- liftIO $ pollAllSDLEvents+ let mbutton = mouseClickInAny height [ButtonLeft] allbuttons events+ case mbutton of+ Nothing -> return Nothing+ Just n -> case lookup n bttoaction of+ Just act -> act+ Nothing -> return Nothing+ loopTextScreen (do (market', cargo, cash, holdspace) <- State.get+ liftIO $ makeTextScreen (10, 500) + [(f1, Color4 1.0 1.0 1.0 1.0, str),+ (f2, Color4 1.0 1.0 0.0 1.0, showMarketAndCargo trade market' cargo),+ (f1, Color4 1.0 1.0 1.0 1.0, if trade then "Cash: " ++ show cash else ""),+ (f1, Color4 1.0 1.0 1.0 1.0, "Hold space: " ++ show holdspace)]+ (drawButton (Just ("Exit", f1)) exitb >>+ mapM_ (drawButton (Just (if trade then "Buy" else "Take", f1))) buybuttons >>+ mapM_ (drawButton (Just (if trade then "Sell" else "Leave", f1))) sellbuttons))+ handleInput++takeScreen :: String -> Font -> Font -> StateT TakeState IO ()+takeScreen str f1 f2 = do+ (stuff, cargo, cash, hold) <- State.get+ (_, cargo', _, hold') <- liftIO $ execStateT (screenGeneric False str f1 f2) (cargoToMarket stuff, cargo, cash, hold)+ State.put (stuff, cargo', cash, hold')
+ src/Collision.hs view
@@ -0,0 +1,13 @@+module Collision+where++boxArea (x, y) r = ((x - r, x + r), (y - r, y + r))++collides1d (a, b) (c, d) =+ (a < c && c < b) || (a < d && d < b) ||+ (c < a && a < d) || (c < b && b < d)++collides2d (x1, y1) (x2, y2) =+ collides1d x1 x2 && collides1d y1 y2++
+ src/Combat.hs view
@@ -0,0 +1,380 @@+module Combat(combatLoop, newCombat, randomEnemy, describeEnemy,+ ShipProp(..),+ randomPolice,+ Enemy,+ fightership, intermediate, cargovessel)+where++import System.Random+import Data.Maybe+import Data.Either+import Control.Monad+import Control.Monad.State as State++import Graphics.Rendering.OpenGL as OpenGL+import Graphics.UI.SDL as SDL+import qualified Data.Edison.Seq.SimpleQueue as S+import qualified Data.Edison.Assoc.StandardMap as M++import OpenGLUtils+import Entity+import Space+import AObject+import Cargo+import Utils+import SDLUtils++data AIMode = Human+ | Dummy+ | Shooter GLdouble+ deriving (Show)++data ShipProp = ShipProp {+ maxaccel :: GLdouble+ , maxturn :: GLdouble+ , maxhealth :: Int+ , holdspace :: Int+ , shipdescr :: String+ , shippoints :: Int+ }++modHoldspace :: (Int -> Int) -> ShipProp -> ShipProp+modHoldspace f t = t{holdspace = f (holdspace t)}++randomAI :: IO AIMode+randomAI = do+ n <- randomRIO (0, 100 :: Int)+ return $ Shooter (fromIntegral n / 100)++fightership = ShipProp+ 0.003+ 2.0+ 3+ 6+ "Fighter ship"+ 200++intermediate = ShipProp+ 0.002+ 1.5+ 5+ 10+ "Trader ship"+ 100++cargovessel = ShipProp+ 0.001+ 1.0+ 8+ 15+ "Cargo vessel"+ 50++randomShipProp :: IO ShipProp+randomShipProp = do+ n <- randomRIO (1, 3 :: Int)+ case n of+ 1 -> return fightership+ 2 -> return intermediate+ _ -> return cargovessel++data Ship = Ship {+ shipentity :: Entity+ , health :: Int+ , aimode :: AIMode+ , shipprop :: ShipProp+ , allegiance :: String+ }++modShipEntity :: (Entity -> Entity) -> Ship -> Ship+modShipEntity f t = t{shipentity = f (shipentity t)}++modHealth :: (Int -> Int) -> Ship -> Ship+modHealth f t = t{health = f (health t)}++data Combat = Combat {+ ship1 :: Ship+ , ship2 :: Ship+ , lasers :: S.Seq Entity+ , combatPaused :: Bool+ }++modShip1 :: (Ship -> Ship) -> Combat -> Combat+modShip1 f t = t{ship1 = f (ship1 t)}++modShip2 :: (Ship -> Ship) -> Combat -> Combat+modShip2 f t = t{ship2 = f (ship2 t)}++modLasers :: (S.Seq Entity -> S.Seq Entity) -> Combat -> Combat+modLasers f t = t{lasers = f (lasers t)}++modCombatPaused :: (Bool -> Bool) -> Combat -> Combat+modCombatPaused f t = t{combatPaused = f (combatPaused t)}++modShipN :: Int -> (Ship -> Ship) -> Combat -> Combat+modShipN 1 f = modShip1 f+modShipN 2 f = modShip2 f+modShipN _ _ = id++newStdShip :: String -> Maybe Int -> ShipProp -> GLvector3 -> Color4 GLfloat -> GLdouble -> AIMode -> Ship+newStdShip alleg mh prop pos c rot mode = + Ship (newStdShipEntity pos c rot)+ (fromMaybe (maxhealth prop) mh) mode prop alleg++type Enemy = (AIMode, ShipProp)++randomEnemy :: GLdouble -> IO Enemy+randomEnemy shift = do+ m <- randomAI+ case m of+ Shooter v -> do+ let m' = Shooter (clamp 0 1 (v + shift))+ if v < 0.15+ then return (m', cargovessel)+ else if v > 0.85+ then return (m', fightership)+ else do+ n <- randomShipProp+ return (m', n)+ t -> do+ n <- randomShipProp+ return (t, n)++randomPolice :: GLdouble -> IO Enemy+randomPolice shift = do+ n <- randomRIO (40, 80 :: Int)+ return (Shooter (clamp 0 1 (shift + (fromIntegral n / 100))), modHoldspace (const 0) fightership)++describeEnemy :: Enemy -> String+describeEnemy (_, p) = shipdescr p++newCombat :: String -> String -> ShipProp -> Int -> GLvector3 -> GLvector3 -> GLdouble -> GLdouble -> Enemy -> Combat+newCombat alleg1 alleg2 plprop plhealth plpos enpos rot rot2 (mode, enprop) = + Combat (newStdShip alleg1 (Just plhealth) plprop plpos playerShipColor rot Human)+ (newStdShip alleg2 Nothing enprop enpos enemyShipColor rot2 mode)+ S.empty+ False++accelerateCombat n a = modify $ modShipN n $ modShipEntity $ modifyAcceleration (const (0.0, a, 0.0))+turnCombat n a = modify $ modShipN n $ modShipEntity $ modifyAngVelocity (+a)+setTurnCombat n a = modify $ modShipN n $ modShipEntity $ modifyAngVelocity (const a)++laserLength :: GLdouble+laserLength = 1++laserSpeed :: GLdouble+laserSpeed = 1++shipNShoot :: Int -> StateT Combat IO ()+shipNShoot n = do+ state <- State.get+ let men = case n of+ 1 -> Just $ shipentity $ ship1 state+ 2 -> Just $ shipentity $ ship2 state+ _ -> Nothing+ case men of+ Nothing -> return ()+ Just en -> do+ let shippos = Entity.position en+ shipvel = Entity.velocity en+ shiprot = Entity.rotation en + 90+ lookVector = (cos (degToRad shiprot), sin (degToRad shiprot), 0)+ laserpos = shippos *+* (lookVector *** 3)+ laservel = shipvel *+* (lookVector *** laserSpeed)+ laserrot = shiprot+ lasercol = if n == 1 then Color4 0.0 1.0 0.0 1.0 else Color4 1.0 0.0 0.0 1.0+ let nent = Entity laserpos laservel glVector3Null laserrot 0 0 lasercol Lines [(1.0, 0.0, 0.0), (-1.0, 0.0, 0.0)] (glVector3AllUnit *** laserLength)+ modify $ modLasers $ S.rcons nent++combatMapping sprop = + [ (SDLK_w, (accelerateCombat 1 (maxaccel sprop), accelerateCombat 1 0))+ , (SDLK_s, (accelerateCombat 1 (-maxaccel sprop), accelerateCombat 1 0))+ , (SDLK_a, (turnCombat 1 (maxturn sprop), turnCombat 1 (-maxturn sprop)))+ , (SDLK_d, (turnCombat 1 (-maxturn sprop), turnCombat 1 (maxturn sprop)))+ , (SDLK_UP, (accelerateCombat 1 (maxaccel sprop), accelerateCombat 1 0))+ , (SDLK_DOWN, (accelerateCombat 1 (-maxaccel sprop), accelerateCombat 1 0))+ , (SDLK_LEFT, (turnCombat 1 (maxturn sprop), turnCombat 1 (-maxturn sprop)))+ , (SDLK_RIGHT, (turnCombat 1 (-maxturn sprop), turnCombat 1 (maxturn sprop)))+ , (SDLK_p, (modify $ modCombatPaused not, return ()))+ , (SDLK_SPACE, (shipNShoot 1, return ()))+ , (SDLK_i, (showCombatInfo, return ()))+ ]++showCombatInfo :: StateT Combat IO ()+showCombatInfo = do+ state <- State.get+ let mpos = Entity.position (shipentity $ ship2 state)+ let epos = Entity.position (shipentity $ ship1 state)+ let evel = Entity.velocity (shipentity $ ship1 state)+ let mvel = Entity.velocity (shipentity $ ship2 state)+ let mtgtpos = findHitpoint (epos *-* mpos) (evel *-* mvel) laserSpeed+ liftIO $ putStrLn $ "Pos diff: " ++ (show (epos *-* mpos))+ liftIO $ putStrLn $ "Player Velocity: " ++ (show evel)+ liftIO $ putStrLn $ "Hit point: " ++ (show mtgtpos)++handleTooFar :: StateT Combat IO Bool+handleTooFar = do+ state <- State.get+ let mpos = Entity.position (shipentity $ ship2 state)+ let epos = Entity.position (shipentity $ ship1 state)+ return $ OpenGLUtils.length (mpos *-* epos) > 200.0++-- Returns (player health, won points, won cargo (if any))+combatLoop :: StateT Combat IO (Int, Int, Maybe Cargo)+combatLoop = do+ liftIO $ delay 10+ state <- State.get+ drawCombat+ oneDead <- if combatPaused state+ then return 0+ else updateCombatState+ handleCombatAI+ toofar <- handleTooFar+ quits <- handleCombatEvents+ if quits || oneDead == 1+ then return (0, 0, Nothing)+ else if oneDead == 2+ then do+ c <- liftIO $ createRandomCargo (holdspace $ shipprop $ ship2 state)+ s' <- State.get+ return (health $ ship1 s', shippoints . shipprop $ ship2 s', Just c)+ else if toofar+ then return (health $ ship1 state, 0, Nothing)+ else combatLoop++createRandomCargo :: Int -> IO Cargo+createRandomCargo 0 = return M.empty+createRandomCargo maxhold = do+ let maxnumtypes = 3+ difftypes <- randomRIO (1, maxnumtypes :: Int)+ cnames <- replicateM difftypes randomCargo+ cargoquantities <- replicateM difftypes (randomRIO (1, maxhold `div` difftypes))+ return $ M.fromSeqWith (+) (zip cnames cargoquantities)++handleCombatAI :: StateT Combat IO ()+handleCombatAI = do+ state <- State.get+ case aimode (ship2 state) of+ Human -> return ()+ Dummy -> accelerateCombat 2 (maxaccel (shipprop (ship2 state)) * 0.5)+ Shooter n -> doShooter n++findHitpoint :: GLvector3 -- ^ target position relative to (0, 0, _)+ -> GLvector3 -- ^ target velocity+ -> GLdouble -- ^ expanding rate of circle radius from own position+ -> Maybe GLvector3 -- ^ meeting point of target and radius+findHitpoint (a, q, _) (d, e, _) c + | c == 0 && d == 0 && e == 0 = Nothing+ | otherwise =+ let (t1, t2) = tps a q d e c+ tf = filter (>= 0) [t1, t2]+ tf' = minimum tf+ in if null tf+ then Nothing+ else Just (a + d * tf', q + e * tf', 0)++tps x y p q c = ((term1 - term2) / term3, (term1 + term2) / term3)+ where term1 = p * x + q * y+ term2 = sqrt (c*c*x*x - q*q*x*x + 2 * p * q * x * y + c*c*y*y - p*p*y*y)+ term3 = c*c - p*p - q*q++chargeTarget :: GLdouble -> StateT Combat IO ()+chargeTarget angleToTarget = do+ state <- State.get+ let myangle = degToRad $ wrapDegrees $ Entity.rotation (shipentity $ ship2 state) + 90+ let epsilon = 0.01+ let turnRate = maxturn $ shipprop $ ship2 state+ if myangle + epsilon < angleToTarget+ then setTurnCombat 2 turnRate+ else if myangle - epsilon > angleToTarget+ then setTurnCombat 2 (-turnRate)+ else setTurnCombat 2 0+ when (abs (myangle - angleToTarget) < 0.3) $ do+ val <- liftIO $ randomRIO (0, 15 :: Int)+ when (val == 0) $ shipNShoot 2+ accelerateCombat 2 (maxaccel $ shipprop $ ship2 state)++doShooter :: GLdouble -> StateT Combat IO ()+doShooter n = do+ state <- State.get+ let mpos = Entity.position (shipentity $ ship2 state)+ let epos = Entity.position (shipentity $ ship1 state)+ let evel = Entity.velocity (shipentity $ ship1 state)+ let estEnemyVel = evel *** n+ let mvel = Entity.velocity (shipentity $ ship2 state)+ let mtgtpos = findHitpoint (epos *-* mpos) (estEnemyVel *-* mvel) laserSpeed+ let angleToEnemy = case mtgtpos of+ Nothing -> angleFromToRad mpos epos+ Just tgtpos -> angleFromToRad glVector3Null tgtpos + chargeTarget angleToEnemy++drawCombat :: StateT Combat IO ()+drawCombat = do+ state <- State.get+ let (x1, y1, _) = Entity.position (shipentity $ ship1 state)+ (x2, y2, _) = Entity.position (shipentity $ ship2 state)+ ((minx', maxx'), (miny', maxy')) = boxThatIncludes (x1, x2) (y1, y2) 10 10 width height+ inOrthoBoxDraw minx' maxx' miny' maxy' (-10) 10+ (liftIO $ + drawGLScreen Nothing + ([shipentity (ship1 state), shipentity (ship2 state)] ++ (S.toList (lasers state))) + nullAObjTree)++updateCombatState :: StateT Combat IO Int+updateCombatState = do+ modify $ modLasers $ S.map (updateEntity 1)+ modify $ modShip1 $ modShipEntity (updateEntity 1)+ modify $ modShip2 $ modShipEntity (updateEntity 1)+ handleCombatCollisions+ state <- State.get+ if (health (ship1 state) <= 0)+ then return 1+ else if (health (ship2 state) <= 0)+ then return 2+ else return 0++handleCombatEvents :: StateT Combat IO Bool+handleCombatEvents = do+ events <- liftIO $ pollAllSDLEvents+ state <- State.get+ processEvents (combatMapping (shipprop $ ship1 state)) events+ return $ isQuit events++checkCollision ::+ ((GLdouble, GLdouble), (GLdouble, GLdouble))+ -> ((GLdouble, GLdouble), (GLdouble, GLdouble))+ -> Entity+ -> Either Int Entity+checkCollision plbox1 plbox2 las =+ if collides2d plbox1 ((minx, maxx), (miny, maxy))+ then Left 1+ else if collides2d plbox2 ((minx, maxx), (miny, maxy))+ then Left 2+ else Right las+ where (lposx, lposy, _) = Entity.position las+ lrot = degToRad $ Entity.rotation las+ lx1 = lposx - laserLength * cos lrot+ lx2 = lposx + laserLength * cos lrot+ ly1 = lposy - laserLength * sin lrot+ ly2 = lposy + laserLength * sin lrot+ minx = min lx1 lx2+ maxx = max lx1 lx2+ miny = min ly1 ly2+ maxy = max ly1 ly2++handleCombatCollisions :: StateT Combat IO ()+handleCombatCollisions = do+ state <- State.get+ let plbox1 = getShipBox (shipentity $ ship1 state)+ let plbox2 = getShipBox (shipentity $ ship2 state)+ let colls = map (checkCollision plbox1 plbox2) (S.toList $ lasers state)+ let (hits, newlasers) = partitionEithers colls+ let numhits1 = Prelude.length $ filter (==1) hits+ let numhits2 = Prelude.length $ filter (==2) hits+ -- when (numhits1 > 0) $ liftIO $ putStrLn "Ship 1 hit!"+ -- when (numhits2 > 0) $ liftIO $ putStrLn "Ship 2 hit!"+ modify $ modLasers $ const (S.fromList newlasers)+ modify $ modShipN 1 $ modHealth (subtract numhits1)+ modify $ modShipN 2 $ modHealth (subtract numhits2)++
+ src/Entity.hs view
@@ -0,0 +1,72 @@+module Entity+where++import Control.Monad.State++import Graphics.Rendering.OpenGL as OpenGL++import OpenGLUtils+import Utils++-- Entity stuff+data Entity = Entity {+ position :: GLvector3+ , velocity :: GLvector3+ , acceleration :: GLvector3+ , rotation :: GLdouble+ , angVelocity :: GLdouble+ , angAccel :: GLdouble+ , color :: Color4 GLfloat+ , primitive :: PrimitiveMode+ , vertices :: [GLvector3]+ , scale :: GLvector3+ }++newEntity :: GLvector3 -> GLdouble -> Color4 GLfloat -> PrimitiveMode -> [GLvector3] -> GLvector3 -> Entity+newEntity p rot c pr vrt scl = Entity p glVector3Null glVector3Null rot 0 0 c pr vrt scl++-- TODO: generate mod-functions using TH+modifyPosition :: (GLvector3 -> GLvector3) -> Entity -> Entity+modifyPosition f t = t{Entity.position = f (Entity.position t)}++modifyVelocity :: (GLvector3 -> GLvector3) -> Entity -> Entity+modifyVelocity f t = t{velocity = f (velocity t)}++modifyAcceleration :: (GLvector3 -> GLvector3) -> Entity -> Entity+modifyAcceleration f t = t{acceleration = f (acceleration t)}++modifyRotation :: (GLdouble -> GLdouble) -> Entity -> Entity+modifyRotation f t = t{rotation = f (rotation t)}++modifyAngVelocity :: (GLdouble -> GLdouble) -> Entity -> Entity+modifyAngVelocity f t = t{angVelocity = f (angVelocity t)}++modifyAngAccel :: (GLdouble -> GLdouble) -> Entity -> Entity+modifyAngAccel f t = t{angAccel = f (angAccel t)}++modifyColor :: (Color4 GLfloat -> Color4 GLfloat) -> Entity -> Entity+modifyColor f t = t{Entity.color = f (Entity.color t)}++modifyPrimitive :: (PrimitiveMode -> PrimitiveMode) -> Entity -> Entity+modifyPrimitive f t = t{primitive = f (primitive t)}++modifyScale :: (GLvector3 -> GLvector3) -> Entity -> Entity+modifyScale f t = t{Entity.scale = f (Entity.scale t)}++updateEntity :: GLdouble -> Entity -> Entity+updateEntity delta ent = flip execState ent $ do+ let (accx, accy, accz) = acceleration ent+ let rr = degToRad $ rotation ent+ let accVector = + (accx * cos rr - accy * sin rr,+ accx * sin rr + accy * cos rr,+ accz)+ modify $ modifyVelocity (*+* (accVector *** delta))+ modify $ modifyPosition (*+* ((velocity ent) *** delta))+ modify $ modifyAngVelocity (+ (angAccel ent) * delta)+ modify $ modifyRotation (wrapDegrees . (+ (angVelocity ent) * delta))++resetAcceleration :: Entity -> Entity+resetAcceleration = modifyAcceleration (const glVector3Null)++
+ src/Main.hs view
@@ -0,0 +1,174 @@+module Main()+where++import System.Directory+import System.IO (hPutStrLn, stderr)+import Text.Printf+import Data.List+import Data.Maybe+import Control.Monad+import Control.Monad.State as State+import System.IO.Error (mkIOError, doesNotExistErrorType)+import Control.Exception (throwIO, catch, IOException)+import Prelude hiding (catch)+import qualified Data.ByteString.Char8 as Str++import Graphics.Rendering.OpenGL as OpenGL+import Graphics.UI.SDL as SDL+import Graphics.Rendering.FTGL as FTGL++import Space+import SpaceState.Space+import Utils+import TextScreen+import SDLUtils++import Paths_starrover2++main = catch (withInit [InitVideo] $ do+ -- blendEquation $= FuncAdd+ -- blendFunc $= (OpenGL.SrcAlpha, OneMinusSrcAlpha)+ initAll)+ (\e -> hPutStrLn stderr $ "Exception: " ++ show (e :: IOException)) ++loadDataFont :: FilePath -> IO Font+loadDataFont fp = do+ fn <- getDataFileName fp+ exists <- doesFileExist fn+ when (not exists) $ do+ throwIO $ mkIOError doesNotExistErrorType "loading data font during initialization" Nothing (Just fn)+ f <- createTextureFont fn+ _ <- setFontFaceSize f 24 72+ return f++initAll = do+ _ <- setVideoMode width height 0 [OpenGL]+ depthFunc $= Just Less+ clearColor $= Color4 0 0 0 1+ viewport $= (Position 0 0, Size width height)+ f <- loadDataFont "share/DejaVuSans.ttf"+ f2 <- loadDataFont "share/DejaVuSansMono.ttf"+ mainMenu f f2++mainMenu f f2 = do+ n <- menu 1 (f, Color4 1.0 1.0 1.0 1.0, "Star Rover 2")+ [(f, Color4 1.0 1.0 1.0 1.0, "Start a new game"),+ (f, Color4 1.0 1.0 1.0 1.0, "High scores"),+ (f, Color4 1.0 1.0 1.0 1.0, "Help"),+ (f, Color4 1.0 1.0 1.0 1.0, "Quit")]+ (f, Color4 0.1 0.1 1.0 1.0, "=>")+ case n of+ 1 -> startGame f f2+ 2 -> do+ appdir <- getAppUserDataDirectory "starrover2"+ highscore <- loadHighscore appdir hiscorefilename+ showHighscore f f2 "High scores" highscore+ mainMenu f f2+ 3 -> helpScreen f >> mainMenu f f2+ _ -> return ()++helpScreen f = do+ let drawfunc = makeTextScreen (100, 520)+ [(f, Color4 1.0 1.0 1.0 1.0, "Controls in space:"),+ (f, Color4 1.0 1.0 1.0 1.0, "Arrows/W/A/S/D - control your ship"),+ (f, Color4 1.0 1.0 1.0 1.0, "Space - shoot (in combat)"),+ (f, Color4 1.0 1.0 1.0 1.0, "+ and - - zoom/unzoom"),+ (f, Color4 1.0 1.0 1.0 1.0, "M - star system map"),+ (f, Color4 1.0 1.0 1.0 1.0, "Q - retire"),+ (f, Color4 1.0 1.0 1.0 1.0, "\n"),+ (f, Color4 1.0 1.0 1.0 1.0, "Controls in menus:"),+ (f, Color4 1.0 1.0 1.0 1.0, "Arrows - move around in menus"),+ (f, Color4 1.0 1.0 1.0 1.0, "Enter or space - choose action")]+ (return ())+ pressAnyKeyScreen drawfunc++startGame f f2 = do+ (n, d) <- initGame f+ pts <- runGame n d f f2+ doHighscore f f2 pts n d+ mainMenu f f2++introText = intercalate "\n"+ ["Welcome, Adventurer!",+ "What is your name?"]++initGame :: Font -> IO (String, Difficulty)+initGame f = do+ n <- getNameInput introText f+ d <- menu 2 (f, Color4 1.0 1.0 1.0 1.0, "Choose your difficulty, " ++ capitalize n)+ (map (\s -> (f, Color4 1.0 1.0 1.0 1.0, show s)) (allEnums :: [Difficulty]))+ (f, Color4 0.1 0.1 1.0 1.0, "=>")+ return (capitalize n, toEnum (d - 1))++type Highscore a = [(Int, String, a)]++loadHighscore :: (Read a) => FilePath -> FilePath -> IO (Highscore a)+loadHighscore dir fn = do+ createDirectoryIfMissing False dir+ let fpath = dir ++ "/" ++ fn+ exists <- doesFileExist fpath+ if exists+ then do+ contents <- liftM Str.unpack $ Str.readFile fpath+ case safeRead contents of+ Nothing -> do+ hPutStrLn stderr $ "Corrupt high score file (" ++ fpath ++ ") - deleting"+ removeFile fpath+ return []+ Just h -> return h+ else return []++saveHighscore :: (Show a) => FilePath -> FilePath -> Highscore a -> IO ()+saveHighscore dir fn hs = do+ createDirectoryIfMissing False dir+ let fpath = dir ++ "/" ++ fn+ writeFile fpath (show hs)++displayHighscore :: (Show a) => Highscore a -> String+displayHighscore = concatMap (\(pts, n, v) -> printf "%-16s %-8s %8d\n" n (show v) pts)++getNameInput :: String -> Font -> IO String+getNameInput greet f = do+ Prelude.flip evalStateT "" $ do+ let drawfunc = do n <- State.get + liftIO $ makeTextScreen (100, 500)+ [(f, Color4 1.0 1.0 1.0 1.0, greet ++ "\n"),+ (f, Color4 1.0 1.0 1.0 1.0, n)] (return ())+ let getInput = do+ evts <- liftIO $ pollAllSDLEvents+ shift <- liftIO $ shiftDown+ s <- State.get+ let (s', fin) = inputLine shift evts s+ if fin && not (null s')+ then return (Just s')+ else put s' >> return Nothing+ loopTextScreen drawfunc getInput++hiscorefilename = "hiscore"++doHighscore :: Font -> Font -> Int -> String -> Difficulty -> IO ()+doHighscore f f2 pts n diff = do+ let numentries = 7+ appdir <- getAppUserDataDirectory "starrover2"+ highscore <- loadHighscore appdir hiscorefilename+ let madeit = if pts > 0 && length highscore < numentries+ then True+ else let (p, _, _) = last highscore in p < pts+ highscore' <- if madeit+ then do+ return $ take numentries $ insertRev (pts, n, diff) highscore+ else return highscore+ let inittext = if not madeit+ then "Unfortunately you didn't make it to the high score list."+ else "You made it to the high score list!\nPoints: " ++ show pts+ when (madeit) $ saveHighscore appdir hiscorefilename highscore'+ showHighscore f f2 inittext highscore'++showHighscore :: Font -> Font -> String -> Highscore Difficulty -> IO ()+showHighscore f f2 inittext hs = do+ let drawfunc = makeTextScreen (100, 520)+ [(f, Color4 1.0 1.0 1.0 1.0, inittext ++ "\n"),+ (f2, Color4 1.0 1.0 1.0 1.0, displayHighscore hs),+ (f, Color4 1.0 1.0 1.0 1.0, "\n\nPress any key")] (return ())+ pressAnyKeyScreen drawfunc+
+ src/Mission.hs view
@@ -0,0 +1,49 @@+module Mission+where++import Control.Monad (liftM)+import Data.Maybe (isJust)+import Data.List (find)++import qualified Data.Edison.Assoc.AssocList as M++type MissionMap = M.FM String Mission++data MissionCategory = Messenger+ | SecretMessage++data Mission = MessengerMission String+ | SecretMessageMission String++emptyMissionMap :: MissionMap+emptyMissionMap = M.empty++missionFor :: String -> MissionMap -> Maybe Mission+missionFor = M.lookupM++hasMissionFor :: String -> MissionMap -> Bool+hasMissionFor s m = isJust $ missionFor s m++setMission :: String -> Mission -> MissionMap -> MissionMap+setMission = M.insert++removeMission :: String -> MissionMap -> MissionMap+removeMission = M.delete++minRepForMission = 4++pointsForMessengerMission, pointsForSecretMessage, pointsUntilThePoliceArrives :: Int+pointsForMessengerMission = 2+pointsForSecretMessage = 5+pointsUntilThePoliceArrives = (-18)++missionRepNeeded :: [(Int, MissionCategory)]+missionRepNeeded = [(18, SecretMessage), (minRepForMission, Messenger)]++possibleMissionType :: Int -> Maybe MissionCategory+possibleMissionType thr = + liftM snd (find (\n -> fst n <= thr) missionRepNeeded)++missions :: MissionMap -> [(String, Mission)]+missions = M.toSeq+
+ src/OpenGLUtils.hs view
@@ -0,0 +1,67 @@+module OpenGLUtils+where++import Control.Monad.State++import Graphics.Rendering.OpenGL as OpenGL++type GLvector2 = (GLdouble, GLdouble)++type GLvector3 = (GLdouble, GLdouble, GLdouble)++(*+*) :: GLvector3 -> GLvector3 -> GLvector3+(*+*) (x0, y0, z0) (x1, y1, z1) = (x0 + x1, y0 + y1, z0 + z1)++(*-*) :: GLvector3 -> GLvector3 -> GLvector3+(*-*) (x0, y0, z0) (x1, y1, z1) = (x0 - x1, y0 - y1, z0 - z1)++(***) :: GLvector3 -> GLdouble -> GLvector3+(***) (x0, y0, z0) s = (x0 * s, y0 * s, z0 * s)++length2 :: GLvector3 -> GLdouble+length2 (x0, y0, z0) = x0 ** 2 + y0 ** 2 + z0 ** 2++length :: GLvector3 -> GLdouble+length = sqrt . length2++normalize :: GLvector3 -> GLvector3+normalize (0, 0, 0) = (0, 0, 0)+normalize v@(x, y, z) = + let l = OpenGLUtils.length v+ in (x / l, y / l, z / l)++glVector3Null :: GLvector3+glVector3Null = (0, 0, 0)++glVector3AllUnit :: GLvector3+glVector3AllUnit = (1, 1, 1)++glVector3UnitX :: GLvector3+glVector3UnitX = (1, 0, 0)++glVector3UnitY :: GLvector3+glVector3UnitY = (0, 1, 0)++glVector3UnitZ :: GLvector3+glVector3UnitZ = (0, 0, 1)++circlePoints :: Int -> [GLvector3]+circlePoints n = + let xs = map (sin . (2 * pi *) . (/(fromIntegral n)) . fromIntegral) [0..(n - 1)]+ ys = map (cos . (2 * pi *) . (/(fromIntegral n)) . fromIntegral) [0..(n - 1)]+ zs = repeat 0+ in zip3 xs ys zs++uniformScale :: (MatrixComponent c) => c -> IO ()+uniformScale x = OpenGL.scale x x x++inOrthoBoxDraw :: (MonadIO m) => GLdouble -> GLdouble -> GLdouble -> GLdouble -> GLdouble -> GLdouble -> m () -> m ()+inOrthoBoxDraw minx maxx miny maxy minz maxz f = do+ liftIO $ matrixMode $= Projection+ liftIO $ loadIdentity+ liftIO $ ortho minx maxx miny maxy minz maxz+ liftIO $ matrixMode $= Modelview 0+ f++vecToVec :: GLvector3 -> Vector3 GLdouble+vecToVec (x, y, z) = Vector3 x y z
+ src/Politics.hs view
@@ -0,0 +1,78 @@+module Politics(Relation(..), + RelationshipMap,+ mkRelationshipMap, Friendliness,+ AttitudeMap,+ modAttitude,+ nullAttitudes,+ attitude,+ consequences+ )+where++import Data.List++import qualified Data.Edison.Assoc.StandardMap as M++data Relation = Unknown+ | Peace+ | War+ | ColonyOf+ | Allied+ deriving (Show)++type Friendliness = Int+type RelationshipMap = M.FM (String, String) Relationship+type Relationship = (Relation, Friendliness)++emptyRelationshipMap :: RelationshipMap+emptyRelationshipMap = M.empty++defaultRelationship = (Unknown, 0)++setRelationship :: Relationship -> String -> String -> RelationshipMap -> RelationshipMap+setRelationship r s1 s2 = M.insert (s1, s2) r++setRelationship2 :: Relationship -> String -> String -> RelationshipMap -> RelationshipMap+setRelationship2 r s1 s2 = setRelationship r s1 s2 . setRelationship r s2 s1++modRelationship :: (Relationship -> Relationship) -> String -> String -> RelationshipMap -> RelationshipMap+modRelationship f s1 s2 = M.adjustOrInsert f (f defaultRelationship) (s1, s2)++modRelationship2 :: (Relationship -> Relationship) -> String -> String -> RelationshipMap -> RelationshipMap+modRelationship2 f s1 s2 = modRelationship f s1 s2 . modRelationship f s2 s1++mkRelationshipMap :: [((String, String), Relationship)] -> RelationshipMap+mkRelationshipMap = foldl' go emptyRelationshipMap+ where go acc ((s1, s2), r) = setRelationship2 r s1 s2 acc++type AttitudeMap = M.FM String Friendliness++nullAttitudes :: [String] -> AttitudeMap+nullAttitudes as = M.fromSeq $ zip as (repeat 0)++friendliness :: String -> String -> RelationshipMap -> Friendliness+friendliness s1 s2 = snd . M.lookupWithDefault defaultRelationship (s1, s2)++attitude :: String -> AttitudeMap -> Friendliness+attitude = M.lookupWithDefault 0++modAttitude :: (Friendliness -> Friendliness) -> String -> AttitudeMap -> AttitudeMap+modAttitude f = M.adjustOrInsert f (f 0)++setAttitude :: Friendliness -> String -> AttitudeMap -> AttitudeMap+setAttitude = flip M.insert++setAttitudes :: [(String, Friendliness)] -> AttitudeMap -> AttitudeMap+setAttitudes = flip (foldl' go)+ where go acc (s, a) = setAttitude a s acc++consequences :: Friendliness -- ^ Act done by an actor.+ -> String -- ^ Name of the state which was the target of the act.+ -> [String] -- ^ Observing states.+ -> RelationshipMap -- ^ Map of relationships.+ -> AttitudeMap -- ^ Map of attitudes.+ -> AttitudeMap -- ^ New attitudes towards the actor.+consequences act tgt obss rm atts = + let nas = map (\obs -> (attitude obs atts) + (act * (friendliness obs tgt rm))) obss+ in setAttitudes (zip obss nas) atts+
+ src/SDLUtils.hs view
@@ -0,0 +1,138 @@+module SDLUtils+where++import Control.Exception (throwIO)+import Data.Maybe+import Data.Char+import Data.List++import Graphics.UI.SDL as SDL+import qualified Graphics.UI.SDL.Utilities as SDLU+import qualified Data.Edison.Assoc.StandardMap as M++-- generic stuff+pollAllSDLEvents :: IO [SDL.Event]+pollAllSDLEvents = pollAllSDLEvents'' True++pollAllSDLEvents' :: IO [SDL.Event]+pollAllSDLEvents' = pollAllSDLEvents'' False++pollAllSDLEvents'' :: Bool -> IO [SDL.Event]+pollAllSDLEvents'' throwOnQuit = go []+ where go l = do+ e <- SDL.pollEvent+ if e == SDL.NoEvent+ then return l+ else if throwOnQuit && e == SDL.Quit+ then (throwIO $ userError "User wants to quit")+ else do+ es <- pollAllSDLEvents+ return (e:es)++hasEvent :: (SDL.Event -> Bool) -> [SDL.Event] -> Bool+hasEvent fun evts = or $ map fun evts++getSDLChar :: IO SDLKey+getSDLChar = do+ e <- waitEvent+ case e of+ KeyDown (Keysym n _ _) -> return n+ _ -> getSDLChar++getSpecificSDLChar :: SDLKey -> IO ()+getSpecificSDLChar c = do+ d <- getSDLChar+ if c == d+ then return ()+ else getSpecificSDLChar c++getSpecificSDLChars :: [SDLKey] -> IO SDLKey+getSpecificSDLChars cs = do+ d <- getSDLChar+ if d `elem` cs+ then return d+ else getSpecificSDLChars cs++keyDowns :: [SDL.Event] -> [SDLKey]+keyDowns = foldl' (\acc e -> case e of KeyDown (Keysym n _ _) -> (n:acc); _ -> acc) []++specificKeyPressed :: [SDLKey] -> [SDL.Event] -> Maybe SDLKey+specificKeyPressed ks evts = listToMaybe $ intersect ks (keyDowns evts)++processEvent :: (Monad m) => [(SDLKey, (m (), m ()))] -> Event -> m ()+processEvent n evt =+ let mk = case evt of+ KeyDown (Keysym k _ _) -> Just (True, k)+ KeyUp (Keysym k _ _) -> Just (False, k) + _ -> Nothing+ in case mk of+ Nothing -> return ()+ Just (e, k) -> case lookup k n of+ Nothing -> return ()+ Just (a1, a2) -> if e then a1 else a2++processEvents+ :: (Monad m) => [(SDLKey, (m (), m ()))] -> [Event] -> m ()+processEvents n = mapM_ (processEvent n)++isQuit :: [SDL.Event] -> Bool+isQuit = hasEvent isq+ where isq Quit = True+ isq (KeyDown (Keysym SDLK_q _ _)) = True+ isq _ = False++keyWasPressed :: SDLKey -> [SDL.Event] -> Bool+keyWasPressed j es = j `elem` keyDowns es++oneofKeyWasPressed :: [SDLKey] -> [SDL.Event] -> Bool+oneofKeyWasPressed j es = not . null $ j `intersect` keyDowns es++anyKeyOrMouseWasPressed :: [SDL.Event] -> Bool+anyKeyOrMouseWasPressed = hasEvent isk+ where isk (KeyDown _) = True+ isk (MouseButtonDown _ _ _) = True+ isk _ = False++anyKeyOrMouseWasPressedIO :: IO Bool+anyKeyOrMouseWasPressedIO = pollAllSDLEvents >>= return . anyKeyOrMouseWasPressed++inputLine :: Bool -> [SDL.Event] -> String -> (String, Bool)+inputLine shift es sd = (sd', entered)+ where sd' = osd ++ newInput+ osd = reverse . drop backspaces $ reverse sd+ backspaces = Data.List.length $ filter (== SDLK_BACKSPACE) keys+ keys = keyDowns es+ entered = keyWasPressed SDLK_RETURN es+ newInput = map up $ catMaybes $ map sdlkKeyToChar keys+ up = if shift then toUpper else id++shiftDown :: IO Bool+shiftDown = do+ mods <- getModState+ return (KeyModLeftShift `elem` mods || KeyModRightShift `elem` mods || KeyModShift `elem` mods)++-- TODO: add special characters+sdlkKeyToChar :: SDLKey -> Maybe Char+sdlkKeyToChar = Prelude.flip M.lookupM (M.fromSeq + (zip (SDLU.enumFromTo SDLK_a SDLK_z ++ SDLU.enumFromTo SDLK_0 SDLK_9 ++ [SDLK_SPACE]) + (['a'..'z'] ++ ['0'..'9'] ++ " ")))++mouseClickIn :: Int -> [SDL.MouseButton] -> ((Int, Int), (Int, Int)) -> [SDL.Event] -> Bool+mouseClickIn height buttons ((minx, miny), (diffx, diffy)) =+ hasEvent f+ where f (MouseButtonDown x y b) = + let x' = fromIntegral x+ y' = height - fromIntegral y+ in b `elem` buttons && + x' >= minx && + y' >= miny && + x' <= minx + diffx && + y' <= miny + diffy+ f _ = False++mouseClickInAny :: Int -> [SDL.MouseButton] -> [((Int, Int), (Int, Int))] -> [SDL.Event] -> Maybe ((Int, Int), (Int, Int))+mouseClickInAny height bs areas events = + foldr (\x acc -> if mouseClickIn height bs x events then Just x else acc) + Nothing areas++
+ src/Space.hs view
@@ -0,0 +1,125 @@+module Space(newStdShipEntity,+ playerShipColor,+ enemyShipColor,+ width,+ height,+ drawGLScreen,+ drawEntity,+ collides2d,+ getShipBox,+ angleFromTo,+ angleFromToRad,+ randPos+ )+where++import System.Random+import Data.Foldable+import Prelude hiding (mapM_)++import Graphics.Rendering.OpenGL as OpenGL+import Graphics.UI.SDL as SDL++import OpenGLUtils+import Entity+import AObject+import Tree+import Utils+import Collision++newStdShipEntity :: GLvector3 -> Color4 GLfloat -> GLdouble -> Entity+newStdShipEntity pos c rot = newEntity pos rot c TriangleFan trianglePoints glVector3AllUnit++playerShipColor, enemyShipColor :: Color4 GLfloat+playerShipColor = Color4 0.0 0.5 0.0 1.0+enemyShipColor = Color4 0.5 0.0 0.0 1.0++width :: (Num a) => a+width = 800++height :: (Num a) => a+height = 600++drawEntity :: Maybe GLdouble -> Entity -> IO ()+drawEntity mconstsize ent = do+ loadIdentity+ translate $ (\(x,y,z) -> Vector3 x y z) (Entity.position ent)+ rotate (Entity.rotation ent) $ Vector3 0 0 (1 :: GLdouble)+ case mconstsize of+ Nothing -> (\(x,y,z) -> OpenGL.scale x y z) (Entity.scale ent)+ Just n -> uniformScale n+ currentColor $= (Entity.color ent)+ renderPrimitive (primitive ent) $ forM_ (vertices ent) $ \(x,y,z) -> do+ vertex $ Vertex3 x y z++drawAObject :: Maybe GLdouble -> AObject -> IO ()+drawAObject mconstsize aobj = preservingMatrix $ do+ translate $ vecToVec $ AObject.getPosition aobj+ uniformScale $ case mconstsize of+ Nothing -> size aobj+ Just s -> s+ currentColor $= (AObject.color aobj)+ renderPrimitive Polygon $ forM_ aobjPoints $ \(x,y,z) -> do+ vertex $ Vertex3 x y z++drawAObjTree :: Maybe GLdouble -> AObjTree -> IO ()+drawAObjTree mconstsize (Leaf aobj) = do+ drawAObject mconstsize aobj + drawOrbit (orbitRadius aobj) (barycenter aobj)++drawAObjTree mconstsize (Node (_, rad) objs) = preservingMatrix $ do+ mapM_ (drawAObjTree mconstsize) objs+ drawOrbit rad glVector3Null++drawOrbit :: GLdouble -> GLvector3 -> IO ()+drawOrbit rad bary = preservingMatrix $ do+ translate $ vecToVec $ bary+ uniformScale rad+ currentColor $= aorbitColor+ renderPrimitive LineLoop $ forM_ aorbitPoints $ \(x,y,z) -> do+ vertex $ Vertex3 x y z++drawGLScreen :: Maybe GLdouble -> [Entity] -> AObjTree -> IO ()+drawGLScreen mconstsize ents objs = do+ clear [ColorBuffer,DepthBuffer]++ lineWidth $= 5+ forM_ ents (drawEntity mconstsize)+ lineWidth $= 1+ loadIdentity+ drawAObjTree mconstsize objs++ glSwapBuffers++angleFromTo :: (RealFloat t) => (t, t, t)+ -> (t, t, t)+ -> t+angleFromTo a b = radToDeg $ angleFromToRad a b++angleFromToRad :: (RealFloat t) => (t, t, t)+ -> (t, t, t)+ -> t+angleFromToRad (ax, ay, _) (bx, by, _) =+ atan2 (by - ay) (bx - ax)++randPos :: ((Int, Int), (Int, Int)) -> IO GLvector3+randPos ((minx, miny), (maxx, maxy)) = do+ x <- fromIntegral `fmap` randomRIO (minx, maxx)+ y <- fromIntegral `fmap` randomRIO (miny, maxy)+ return (x, y, 0)++getShipBox+ :: Entity -> ((GLdouble, GLdouble), (GLdouble, GLdouble))+getShipBox e = + let (x, y, _) = Entity.position e+ in boxArea (x, y) 1++trianglePoints :: [GLvector3]+trianglePoints =+ [ (0, 1, 0)+ ,(0.9, -1, 0)+ ,(0.0, -0.7, 0)+ ,(-0.9,-1, 0)+ ]++
+ src/SpaceState/City.hs view
@@ -0,0 +1,292 @@+module SpaceState.City(gotoCity, catapult)+where++import Data.List hiding (concat)+import Data.Maybe+import Data.Foldable+import Control.Monad hiding (mapM_)+import Control.Monad.State as State hiding (mapM_)+import Prelude hiding (catch, concat, mapM_)+import Text.Printf++import Graphics.Rendering.OpenGL as OpenGL+import Graphics.Rendering.FTGL as FTGL+import Graphics.UI.SDL as SDL hiding (flip)++import Statistics+import OpenGLUtils+import Politics+import Entity+import AObject+import Cargo+import Utils+import TextScreen+import Mission+import SpaceState.Game++updateAvailableMission :: AObject -> StateT SpaceState IO ()+updateAvailableMission lc = do+ state <- State.get+ let malleg = colonyOwner lc+ case malleg of+ Nothing -> return ()+ Just alleg -> do+ case possibleMissionType (allegAttitude alleg state) of+ Nothing -> return ()+ Just m -> createMission m alleg lc++createMission :: MissionCategory -> String -> AObject -> StateT SpaceState IO ()+createMission Messenger alleg lc = do+ let planetname = aobjName lc+ state <- State.get+ let otherplanets = fmap aobjName $ filter (hasOwner alleg) (toList $ aobjects state)+ when (not (null otherplanets)) $ do+ n <- liftIO $ chooseIO otherplanets+ when (n /= planetname) $ + modify $ modAvailMission $ const $ Just $ MessengerMission n++createMission SecretMessage alleg lc = do+ let planetname = aobjName lc+ state <- State.get+ let otherplanets = map aobjName $ filter (\a -> hasSomeOwner a && (not . hasOwner alleg) a) (toList $ aobjects state)+ when (not (null otherplanets)) $ do+ n <- liftIO $ chooseIO otherplanets+ when (n /= planetname) $ + modify $ modAvailMission $ const $ Just $ SecretMessageMission n++gotoCity :: AObject -> StateT SpaceState IO ()+gotoCity lc = do+ let planetname = aobjName lc+ state <- State.get+ nmarket <- if planetname == fst (lastmarket state)+ then return $ lastmarket state+ else do+ m <- liftIO $ randomMarket+ return (planetname, m)+ modify $ modMarket $ const nmarket+ handleArrival lc+ updateAvailableMission lc+ cityLoop lc+ catapult lc++cityLoop :: AObject -> StateT SpaceState IO ()+cityLoop lc = do+ let planetname = aobjName lc+ state <- State.get+ let f = gamefont state+ alleg = getAllegiance lc+ leave = "Leave " ++ planetname+ cangovernor = isJust $ possibleMissionType (allegAttitude alleg state)+ options = "Market" : "Shipyard" : "Foreign affairs" : (if cangovernor then "Governor" : [leave] else [leave])+ n <- liftIO $ menu 1 (f, Color4 1.0 1.0 1.0 1.0, + concat ["Starport on " ++ planetname,+ if alleg == planetname then "" else "\nThis planet belongs to the country of " ++ alleg ++ "."])+ (map (\s -> (f, Color4 1.0 1.0 0.0 1.0, s)) options)+ (f, Color4 1.0 1.0 0.0 1.0, "=>")+ case n of+ 1 -> gotoMarket planetname >> cityLoop lc+ 2 -> gotoShipyard >> cityLoop lc+ 3 -> liftIO (showForeignAffairs (colonyOwner lc) (gamefont state)) >> cityLoop lc+ 4 -> if cangovernor then gotoGovernor lc >> cityLoop lc else return ()+ _ -> return ()++showForeignAffairs :: Maybe String -> Font -> IO ()+showForeignAffairs mst f =+ let strs =+ case mst of+ Nothing -> ["This colony is in anarchy!"]+ Just st -> map relToStr rs+ where rs = relationshipsOf st+ relToStr (l, v) | v <= (-4) = printf "We despise the state of %s." l+ relToStr (l, v) | v <= (-1) = printf "We are not very fond of %s." l+ relToStr (l, v) | v <= 1 = printf "Our relationship with the state of %s is neutral." l+ relToStr (l, v) | v <= 4 = printf "%s is a friend of ours." l+ relToStr (l, _) | otherwise = printf "We are allied with the state of %s." l+ drawfunc = makeTextScreen (100, 420) + (map (\s -> (f, Color4 1.0 1.0 1.0 1.0, s)) + (strs ++ ["\n\nPress any key to continue"])) + (return ())+ in pressAnyKeyScreen drawfunc++gotoShipyard :: StateT SpaceState IO ()+gotoShipyard = do+ state <- State.get+ let f = gamefont state+ let damages = startPlHealth - plhealth state+ let cost = damages * 20+ let repairtext =+ if damages == 0+ then "Repair (no damages)"+ else "Repair ship (Cost: " ++ show cost ++ ")"+ n <- liftIO $ menu 1 (f, Color4 1.0 1.0 1.0 1.0, "Shipyard")+ [(f, Color4 1.0 1.0 0.0 1.0, repairtext),+ (f, Color4 1.0 1.0 0.0 1.0, "Exit")]+ (f, Color4 1.0 1.0 0.0 1.0, "=>")+ case n of+ 1 -> do+ when (cost > 0 && plcash state >= cost) $ do+ modify $ modPlCash $ (subtract cost)+ modify $ modPlHealth $ const startPlHealth+ gotoShipyard+ _ -> return ()++gotoMarket :: String -> StateT SpaceState IO ()+gotoMarket planetname = do+ state <- State.get+ let market = snd . lastmarket $ state+ (m', cargo', cash', hold') <- liftIO $ execStateT + (tradeScreen ("Market on " ++ planetname) + (gamefont state) (monofont state)) + (market, plcargo state, plcash state, plholdspace state)+ modify $ modMarket $ modSnd $ const m'+ modify $ modPlCargo $ const cargo'+ modify $ modPlCash $ const cash'+ modify $ modPlHoldspace $ const hold'++catapult :: AObject -> StateT SpaceState IO ()+catapult lc = do+ state <- State.get+ let objpos = AObject.getPosition lc+ dist = AObject.size lc+ plloc = Entity.position (tri state)+ pldir = OpenGLUtils.normalize (plloc *-* objpos)+ modify $ modTri $ modifyPosition $ const $ objpos *+* (pldir *** (dist + 5))+ modify $ modTri $ modifyVelocity $ const $ pldir *** 0.2+ modify $ modTri $ resetAcceleration+ modify $ modTri $ modifyRotation $ (+180)++gotoGovernor :: AObject -> StateT SpaceState IO ()+gotoGovernor lc = do+ state <- State.get+ let alleg = getAllegiance lc+ case missionFor alleg (plmissions state) of+ Nothing -> + case availmission state of+ Nothing -> noMissionsScreen+ Just mis -> offerMission mis lc+ Just currmission -> missionDisplay (gamefont state) alleg currmission++missionDisplay f alleg (MessengerMission tgt) = do+ missionDisplayGeneric f alleg ["You have an important message that you need to",+ "bring to the planet of " ++ tgt ++ "."]+missionDisplay f alleg (SecretMessageMission tgt) = do+ missionDisplayGeneric f alleg ["There's a spy of ours currently residing",+ "on the foreign planet of " ++ tgt ++ ".",+ "You must bring him a secret message."]++missionDisplayGeneric f alleg msg = + pressAnyKeyScreen + (liftIO $ makeTextScreen (100, 500) + [(f, Color4 1.0 0.2 0.2 1.0, + intercalate "\n" (["Your current mission for " ++ alleg ++ ":", ""]+ ++ msg ++ ["", "Press any key to continue"]))]+ (return ()))++handleArrival :: AObject -> StateT SpaceState IO ()+handleArrival lc = do+ state <- State.get+ mapM_ (flip handleArrival' lc) (missions (plmissions state))++noMissionsScreen :: StateT SpaceState IO ()+noMissionsScreen = do+ state <- State.get+ let plname = playername state+ pressAnyKeyScreen + (liftIO $ makeTextScreen (100, 500) + [(gamefont state, Color4 1.0 0.2 0.2 1.0, + intercalate "\n" ["\"Dear " ++ plname ++ ", we currently have",+ "no tasks for you.\"",+ "",+ "",+ "Press any key to continue"])]+ (return ()))++offerMission :: Mission -> AObject -> StateT SpaceState IO ()+offerMission mis@(MessengerMission tgt) lc = do+ state <- State.get+ let plname = playername state+ let txt = ["\"Dear " ++ plname ++ ", I welcome you to my",+ "residence. I have an important mission that",+ "needs to be taken care of by a trustworthy",+ "adventurer like yourself.", + "",+ "The mission requires you to deliver an",+ "important message from here to the planet",+ "of " ++ tgt ++ ".",+ "Will you accept?\" (y/n)"]+ offerMissionGeneric mis lc txt++offerMission mis@(SecretMessageMission tgt) lc = do+ state <- State.get+ let plname = playername state+ let txt = ["\"Dear " ++ plname ++ ", I welcome you to my",+ "residence. I have a very important mission that",+ "needs to be taken care of by a competent",+ "adventurer like yourself.", + "",+ "The mission requires you to deliver a message",+ "to a spy of ours hidden on the foreign planet",+ "of " ++ tgt ++ ".",+ "Will you accept?\" (y/n)"]+ offerMissionGeneric mis lc txt++offerMissionGeneric :: Mission -> AObject -> [String] -> StateT SpaceState IO ()+offerMissionGeneric mis lc msg = do+ state <- State.get+ let alleg = getAllegiance lc+ let txt = intercalate "\n" msg+ c <- pressOneOfScreen + (liftIO $ makeTextScreen (100, 500) + [(gamefont state, Color4 1.0 1.0 1.0 1.0, txt)]+ (return ()))+ [SDLK_y, SDLK_n, SDLK_ESCAPE]+ modify $ modAvailMission (const Nothing)+ case c of+ SDLK_y -> modify $ modPlMissions $ setMission alleg mis+ _ -> return ()++handleArrival' :: (String, Mission) -> AObject -> StateT SpaceState IO ()+handleArrival' (alleg, MessengerMission tgt) lc = do+ state <- State.get+ let plname = playername state+ planetname = aobjName lc+ checkArrived tgt planetname alleg pointsForMessengerMission+ ["\"Thank you, " ++ plname ++ ", for serving our great",+ "country of " ++ alleg ++ " by delivering this important",+ "message to us.\"",+ "",+ "Mission accomplished!",+ "",+ "",+ "Press Enter to continue"]++handleArrival' (alleg, SecretMessageMission tgt) lc = do+ state <- State.get+ let plname = playername state+ planetname = aobjName lc+ checkArrived tgt planetname alleg pointsForSecretMessage+ ["\"Thank you, " ++ plname ++ ", for serving our great",+ "country of " ++ alleg ++ " by delivering this important",+ "message to us here on " ++ planetname ++ ".\"",+ "",+ "Mission accomplished!",+ "",+ "",+ "Press Enter to continue"]++onActualArrival :: String -> Int -> [String] -> StateT SpaceState IO ()+onActualArrival alleg pts str = do+ state <- State.get+ let txt = intercalate "\n" str+ modify $ modAvailMission (const Nothing)+ modify $ modAllegAttitudes $ modAttitude (+pts) alleg+ modify $ modPlMissions $ removeMission alleg+ pressKeyScreen + (liftIO $ makeTextScreen (100, 500) + [(gamefont state, Color4 1.0 0.2 0.2 1.0, txt)]+ (return ())) SDLK_RETURN++checkArrived :: String -> String -> String -> Int -> [String] -> StateT SpaceState IO ()+checkArrived tgt planetname alleg pts str = + when (tgt == planetname) (onActualArrival alleg pts str)+
+ src/SpaceState/Combat.hs view
@@ -0,0 +1,95 @@+module SpaceState.Combat(startCombat)+where++import System.Random+import Data.List+import Data.Maybe+import Control.Monad+import Control.Monad.State as State+import Prelude hiding (catch)++import Graphics.Rendering.OpenGL as OpenGL+import Graphics.UI.SDL as SDL+import qualified Data.Edison.Assoc.StandardMap as M++import Combat+import Space+import Cargo+import TextScreen+import Politics+import SDLUtils+import Universe++import SpaceState.Common+import SpaceState.Game+import SpaceState.Init+import SpaceState.Difficulty++startCombat :: Maybe (String, Enemy, String) -- ^ If Nothing, use random enemy+ -- and standard message. Otherwise+ -- use given (msg, enemy, enemy allegiance).+ -> StateT SpaceState IO (Bool, Bool) -- ^ (gameOver?, combatWon?)+startCombat n = do+ state <- State.get+ (s, en, enalleg) <- case n of+ Nothing -> do+ en' <- liftIO $ randomEnemy $ difficultyAIshift $ difficulty state+ enalleg' <- liftIO $ randomAllegiance+ s' <- return $+ concat ["You spot another ship traveling nearby.\n",+ "It seems to be a " ++ (describeEnemy en') ++ ".\n",+ "The ship is part of the country of " ++ enalleg' ++ ".\n",+ "Press ENTER to start a battle against the foreign ship\n",+ "or ESCAPE to escape"]+ return (s', en', enalleg')+ Just m -> return m+ c <- pressOneOfScreen + (liftIO $ makeTextScreen (100, 400) + [(gamefont state, Color4 1.0 1.0 1.0 1.0, s)]+ (return ()))+ [SDLK_RETURN, SDLK_ESCAPE]+ if c == SDLK_RETURN+ then do+ enemyrot <- liftIO $ fromIntegral `fmap` randomRIO (-180, 180 :: Int)+ enpos <- liftIO $ randPos ((0, 0), (50, 100))+ plpos <- liftIO $ randPos ((100, 0), (150, 100))+ let plrot = angleFromTo plpos enpos - 90+ (newhealth, newpoints, mnewcargo) <- liftIO $ evalStateT combatLoop + (newCombat plalleg enalleg intermediate (plhealth state) plpos enpos plrot enemyrot en)+ if newhealth == 0+ then do+ releaseKeys+ gameover <- lostLife "You fought bravely, but your ship was blown to pieces." recoveryText+ return (gameover, False)+ else do+ modify $ modPlHealth $ const newhealth+ case mnewcargo of+ Nothing -> do+ liftIO $ makeTextScreen (100, 400) [(gamefont state, Color4 1.0 1.0 1.0 1.0, "The enemy is out of your sight.\n\n"),+ (gamefont state, Color4 1.0 1.0 1.0 1.0, "Press ENTER to continue")] (return ())+ liftIO $ getSpecificSDLChar SDLK_RETURN+ releaseKeys+ return (False, False)+ Just newcargo -> do+ when (not (M.null newcargo)) $ do+ modify $ modPoints (+(newpoints * (diffcoeff $ difficulty state)))+ (_, cargo', _, hold') <- liftIO $ execStateT + (takeScreen ("Captured cargo") + (gamefont state) (monofont state)) + (newcargo, plcargo state, plcash state, plholdspace state)+ modify $ modPlCargo (const cargo')+ modify $ modPlHoldspace (const hold')+ killed enalleg+ releaseKeys+ return (False, True)+ else do+ releaseKeys+ return (False, False)++internationalAction :: String -> Int -> StateT SpaceState IO ()+internationalAction s f = modify $ modAllegAttitudes $ consequences f s allegiances relations++killed :: String -> StateT SpaceState IO ()+killed enalleg = internationalAction enalleg (-1)++
+ src/SpaceState/Common.hs view
@@ -0,0 +1,39 @@+module SpaceState.Common+where++import Data.List+import Control.Monad.State as State+import Prelude hiding (catch)++import Entity+import Camera+import SpaceState.Game++releaseKeys :: StateT SpaceState IO ()+releaseKeys = do+ setTurn 0+ accelerate 0 -- prevent involuntary actions+ setZoomDelta 0++recoveryText :: String+recoveryText = + intercalate "\n" + ["After ejecting from your space ship, you drifted in space",+ "until a friendly alien picked you up and took you with him",+ "to a nearby trading post, where you recovered some of your",+ "strength.",+ "",+ "After a long search, you manage to find a used ",+ "space ship, and embark on a new adventure..."]++-- accelerate :: (MonadState SpaceState m) => GLdouble -> m ()+accelerate a = modify $ modTri $ modifyAcceleration (const (0.0, a, 0.0))++-- turn :: (MonadState SpaceState m) => GLdouble -> m ()+turn a = modify $ modTri $ modifyAngVelocity (+a)+setTurn a = modify $ modTri $ modifyAngVelocity (const a)++changeZoom a = modify $ modCameraState $ modCamZoomDelta (+a)+setZoomDelta a = modify $ modCameraState $ modCamZoomDelta (const a)++
+ src/SpaceState/Difficulty.hs view
@@ -0,0 +1,21 @@+module SpaceState.Difficulty+where++import Graphics.Rendering.OpenGL as OpenGL++data Difficulty = Easy+ | Medium+ | Hard+ deriving (Enum, Bounded, Show, Read, Ord, Eq)++diffcoeff :: Difficulty -> Int+diffcoeff Easy = 1+diffcoeff Medium = 2+diffcoeff Hard = 3++difficultyAIshift :: Difficulty -> GLdouble+difficultyAIshift Easy = (-0.3)+difficultyAIshift Medium = 0+difficultyAIshift Hard = 0.3++
+ src/SpaceState/Game.hs view
@@ -0,0 +1,182 @@+module SpaceState.Game+where++import Data.List+import Data.Maybe+import Control.Monad+import Control.Monad.State as State+import Prelude hiding (catch)++import Graphics.Rendering.OpenGL as OpenGL+import Graphics.UI.SDL as SDL+import Graphics.Rendering.FTGL as FTGL+import qualified Data.Edison.Assoc.StandardMap as M++import OpenGLUtils+import Entity+import Camera+import AObject+import Combat+import Space+import Cargo+import Utils+import TextScreen+import Politics+import Universe+import Mission+import SpaceState.Difficulty++startState :: String -> Difficulty -> Font -> Font -> SpaceState+startState plname d f f2 = SpaceState + (newStdShipEntity (50.0, 30.0, 0.0) playerShipColor 0)+ aobjs+ stdCamera+ False+ f+ f2+ M.empty+ maxHold+ startCash+ ("", M.empty)+ 0+ 3+ startPlHealth+ d+ initialAttitudes+ emptyMissionMap+ plname+ Nothing++data SpaceState = SpaceState {+ tri :: Entity+ , aobjects :: AObjTree+ , camstate :: CameraState+ , stopped :: Bool+ , gamefont :: Font+ , monofont :: Font+ , plcargo :: Cargo+ , plholdspace :: Int+ , plcash :: Int+ , lastmarket :: (String, Market)+ , points :: Int+ , lives :: Int+ , plhealth :: Int+ , difficulty :: Difficulty+ , allegattitudes :: AttitudeMap+ , plmissions :: MissionMap+ , playername :: String+ , availmission :: Maybe Mission+ }++-- TODO: generate mod-functions using TH+modTri :: (Entity -> Entity) -> SpaceState -> SpaceState+modTri f t = t{tri = f (tri t)}++modAObjects :: (AObjTree -> AObjTree) -> SpaceState -> SpaceState+modAObjects f t = t{aobjects = f (aobjects t)}++modCameraState :: (CameraState -> CameraState) -> SpaceState -> SpaceState+modCameraState f t = t{camstate = f (camstate t)}++modStopped :: (Bool -> Bool) -> SpaceState -> SpaceState+modStopped f t = t{stopped = f (stopped t)}++modPlCargo :: (Cargo -> Cargo) -> SpaceState -> SpaceState+modPlCargo f t = t{plcargo = f (plcargo t)}++modPlCash :: (Int -> Int) -> SpaceState -> SpaceState+modPlCash f t = t{plcash = f (plcash t)}++modPlHoldspace :: (Int -> Int) -> SpaceState -> SpaceState+modPlHoldspace f t = t{plholdspace = f (plholdspace t)}++modMarket :: ((String, Market) -> (String, Market)) -> SpaceState -> SpaceState+modMarket f t = t{lastmarket = f (lastmarket t)}++modPoints :: (Int -> Int) -> SpaceState -> SpaceState+modPoints f t = t{points = f (points t)}++modLives :: (Int -> Int) -> SpaceState -> SpaceState+modLives f t = t{lives = f (lives t)}++modPlHealth :: (Int -> Int) -> SpaceState -> SpaceState+modPlHealth f t = t{plhealth = f (plhealth t)}++modAllegAttitudes :: (AttitudeMap -> AttitudeMap) -> SpaceState -> SpaceState+modAllegAttitudes f t = t{allegattitudes = f (allegattitudes t)}++modPlMissions :: (MissionMap -> MissionMap) -> SpaceState -> SpaceState+modPlMissions f t = t{plmissions = f (plmissions t)}++modAvailMission :: (Maybe Mission -> Maybe Mission) -> SpaceState -> SpaceState+modAvailMission f t = t{availmission = f (availmission t)}++stdCamera :: CameraState+stdCamera = CameraState + ((-0.01 * width, -0.01 * height), (0.02 * width, 0.02 * height))+ 100+ 0++zoomChangeFactor :: (Floating a) => a+zoomChangeFactor = 1.0++drawSpace :: StateT SpaceState IO ()+drawSpace = do+ state <- State.get+ modify $ modCameraState $ modCamZoom $ (+ (camzoomdelta $ camstate state))+ modify $ modCameraState $ modCamera $ setZoom $ clamp 30 250 $ (camzoom $ camstate state) + (400 * (length2 $ velocity (tri state)))+ modify $ modCameraState $ modCamera $ setCentre $ Entity.position (tri state)+ liftIO $ setCamera (camera $ camstate state)+ liftIO $ drawGLScreen Nothing [tri state] (aobjects state)++gameoverText :: String+gameoverText = + intercalate "\n" + ["After escaping with your emergency capsule and",+ "returning to civilization, you realize your",+ "adventurous days are over."]++gameOver :: String -> String -> StateT SpaceState IO Bool+gameOver s s2 = do+ state <- State.get+ pressKeyScreen + (liftIO $ makeTextScreen (100, 500) + [(gamefont state, Color4 1.0 0.2 0.2 1.0, s ++ "\n\n" ++ s2 ++ "\n" ++ "\n"),+ (gamefont state, Color4 1.0 1.0 1.0 1.0, "Total points: " ++ show (finalPoints state)),+ (gamefont state, Color4 1.0 0.2 0.2 1.0, "Press ENTER to continue")]+ (return ())) SDLK_RETURN+ return True++maxHold = holdspace intermediate+startPlHealth = maxhealth intermediate+startCash = 10++finalPoints :: SpaceState -> Int+finalPoints s = + max 0 (10 * + (points s + + (diffcoeff (difficulty s)) * attitudesPoints (M.elements $ allegattitudes s) + + plcash s + + (lives s * 50) - 160))++attitudesPoints :: [Int] -> Int+attitudesPoints = floor . sum . map val+ where val n | n < 0 = fromIntegral n * 0.2 :: Double+ | otherwise = fromIntegral n * 50.0++allegAttitude :: String -> SpaceState -> Int+allegAttitude planetname state = + attitude (planetNameToAllegiance (aobjects state) planetname) $ + allegattitudes state++relationshipsOf :: String -> [(String, Int)]+relationshipsOf n = catMaybes $ map f relationsList+ where f ((n1, n2), (_, v)) = do+ if n1 == n2+ then Nothing+ else if n1 == n+ then Just (n2, v)+ else if n2 == n+ then Just (n1, v)+ else Nothing+
+ src/SpaceState/Init.hs view
@@ -0,0 +1,66 @@+module SpaceState.Init(lostLife, initState, die)+where++import Data.List+import Control.Monad+import Control.Monad.State as State+import Prelude hiding (catch)++import Graphics.Rendering.OpenGL as OpenGL+import Graphics.UI.SDL as SDL+import qualified Data.Edison.Assoc.StandardMap as M++import OpenGLUtils+import Statistics+import Entity+import AObject+import TextScreen+import Mission++import SpaceState.Game+import SpaceState.City+import SpaceState.Common++lostLife :: String -> String -> StateT SpaceState IO Bool+lostLife s1 s2 = do+ modify $ modLives pred+ modify $ modPlCash $ const 0 -- so that no points are given for cash+ state <- State.get+ if lives state <= 0+ then do+ gameOver s1 gameoverText+ else do+ pressKeyScreen (liftIO $ makeTextScreen (30, 550) [(gamefont state,+ Color4 1.0 0.2 0.2 1.0, s1 ++ "\n\n" ++ s2 ++ "\n\nPress ENTER to continue")] + (return ())) SDLK_RETURN+ initState+ return False++initState :: StateT SpaceState IO ()+initState = do+ modify $ modAObjects $ setupBarycenters+ lc <- getRandomPlanet+ modify $ modTri $ modifyPosition (const $ (getPosition lc *+* (glVector3UnitX *** (2 * AObject.size lc))))+ modify $ modPlCash $ const startCash+ modify $ modPlHoldspace $ const maxHold+ modify $ modPlCargo $ const M.empty+ modify $ modPlHealth $ const startPlHealth+ modify $ modPlMissions $ const emptyMissionMap+ modify $ modAvailMission $ const Nothing+ gotoCity lc+ releaseKeys++getRandomPlanet :: StateT SpaceState IO AObject+getRandomPlanet = do+ state <- State.get+ n <- liftIO $ chooseIO (aobjects state)+ if (aobjName n == "Star")+ then getRandomPlanet+ else return n++die :: StateT SpaceState IO (Maybe Int)+die = do+ state <- State.get+ return $ Just $ finalPoints state++
+ src/SpaceState/Input.hs view
@@ -0,0 +1,74 @@+module SpaceState.Input(handleEvents)+where++import Data.List hiding (maximum)+import Data.Foldable+import Control.Monad hiding (forM_)+import Control.Monad.State as State hiding (forM_)+import Prelude hiding (catch, until, maximum)++import Graphics.Rendering.OpenGL as OpenGL+import Graphics.UI.SDL as SDL++import Utils+import Space+import OpenGLUtils+import Entity+import Camera+import Tree+import AObject+import SDLUtils+import SpaceState.Common+import SpaceState.Game++inputMapping+ :: [(SDLKey,+ (StateT SpaceState IO (),+ StateT SpaceState IO ()))]+inputMapping = + [ (SDLK_w, (accelerate 0.002, accelerate 0))+ , (SDLK_s, (accelerate (-0.002), accelerate 0))+ , (SDLK_a, (turn 1.5, setTurn 0))+ , (SDLK_d, (turn (-1.5), setTurn 0))+ , (SDLK_UP, (accelerate 0.002, accelerate 0))+ , (SDLK_DOWN, (accelerate (-0.002), accelerate 0))+ , (SDLK_LEFT, (turn 1.5, setTurn 0))+ , (SDLK_RIGHT, (turn (-1.5), setTurn 0))+ , (SDLK_MINUS, (changeZoom zoomChangeFactor, setZoomDelta 0))+ , (SDLK_PLUS, (changeZoom (-zoomChangeFactor), setZoomDelta 0))+ , (SDLK_i, (showInfo, return ()))+ , (SDLK_p, (modify $ modStopped not, return ()))+ , (SDLK_m, (showMap, return ()))+ ]++showMap :: StateT SpaceState IO ()+showMap = do+ state <- State.get+ let maxrad = maxDistance $ aobjects state+ let ((minx', maxx'), (miny', maxy')) = boxThatIncludes (-maxrad, maxrad) (-maxrad, maxrad) 10 10 width height+ let objrad = 0.01 * (min (maxx' - minx') (maxy' - miny'))+ liftIO $ until anyKeyOrMouseWasPressedIO $ + inOrthoBoxDraw minx' maxx' miny' maxy' (-10) 10 $ do+ delay 10+ drawGLScreen (Just objrad) [tri state] (aobjects state)++maxDistance :: AObjTree -> GLdouble+maxDistance s = go 0 s+ where go disp (Leaf aobj) = disp + orbitRadius aobj+ go disp (Node (_, r) ts) = maximum $ map (go (disp + r)) ts++showInfo = do+ s <- State.get+ liftIO . putStrLn $ "Zoom: " ++ show (camzoom $ camstate s)+ liftIO . putStrLn $ "Player position: " ++ show (Entity.position $ tri s)+ forM_ (aobjects s) $ \aobj -> do+ liftIO . putStrLn $ "Astronomical body position: " ++ show (AObject.getPosition aobj)+ liftIO . putStrLn $ show $ allegattitudes s++handleEvents :: StateT SpaceState IO Bool+handleEvents = do+ events <- liftIO $ pollAllSDLEvents+ processEvents inputMapping events+ return $ isQuit events++
+ src/SpaceState/Space.hs view
@@ -0,0 +1,113 @@+module SpaceState.Space(runGame, Difficulty(..))+where++import System.Random+import Data.List+import Data.Maybe+import Control.Monad+import Control.Monad.State as State+import Prelude hiding (catch)++import Graphics.UI.SDL as SDL+import Graphics.Rendering.FTGL as FTGL++import Entity+import Camera+import AObject+import Combat+import Space+import Utils+import Mission+import Tree++import SpaceState.Common+import SpaceState.Input+import SpaceState.Game+import SpaceState.City+import SpaceState.Init+import SpaceState.Difficulty+import SpaceState.Combat++runGame :: String -> Difficulty -> Font -> Font -> IO Int+runGame plname d f f2 = do+ let is = startState plname d f f2+ setCamera (camera $ camstate is)+ evalStateT (do+ initState+ loop)+ is++loop :: StateT SpaceState IO Int+loop = untilDoneR $ do + liftIO $ delay 10+ state <- State.get+ drawSpace+ dead <- if stopped state+ then return False+ else updateSpaceState+ if not dead+ then do+ quits <- handleEvents+ if quits+ then gameOver "You decided to retire." "" >> die+ else return Nothing+ else die++updateSpaceState :: StateT SpaceState IO Bool+updateSpaceState = do+ state <- State.get+ modify $ modTri (updateEntity 1)+ modify $ modAObjects $+ mapInner (\(ang, rad) -> if ang == 0 + then (ang, rad)+ else (ang + 10 * recip rad, rad))+ modify $ modAObjects $ + fmap (\a -> if orbitRadius a == 0 + then a + else modifyAngle (+ (10 * orbitalSpeedcoeff a * recip (orbitRadius a))) a)+ modify $ modAObjects $ setupBarycenters+ let mlanded = findCollisions (getShipBox $ tri state) (aobjects state)+ case mlanded of+ Nothing -> do+ val <- liftIO $ randomRIO (0, 500 :: Int)+ if (val == 0) + then startCombat Nothing >>= return . fst+ else return False+ Just lc -> do+ if aobjName lc == "Star"+ then lostLife "You flew too close to the star!" recoveryText+ else do+ diedInCity <- enteringCity lc+ releaseKeys+ return diedInCity++-- returns: nothing -> no police contact+-- or Just (gameover?, combatwon?)+survivedPolice :: AObject -> StateT SpaceState IO (Maybe (Bool, Bool))+survivedPolice lc = do+ let alleg = getAllegiance lc+ state <- State.get+ let attid = allegAttitude alleg state+ if attid >= pointsUntilThePoliceArrives+ then return Nothing+ else do+ let s = concat ["Approacing the planet, you suddenly spot a police ship\"\n",+ "approaching you! Your recent activities seem to have\n",+ "alarmed the local authorities! What to do?\n\n",+ "Press ENTER to fight your way to the starport\n",+ "or ESCAPE to escape"]+ pship <- liftIO $ randomPolice $ difficultyAIshift $ difficulty state+ startCombat (Just (s, pship, getAllegiance lc)) >>= return . Just++enteringCity :: AObject -> StateT SpaceState IO Bool+enteringCity lc = do+ n <- survivedPolice lc+ case n of+ Nothing -> gotoCity lc >> return False+ Just (gameover, combatwon) -> do+ if combatwon+ then gotoCity lc+ else catapult lc+ return gameover++
+ src/Statistics.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE Rank2Types #-} +module Statistics+where++import Data.Foldable+import Control.Monad.State+import System.Random+import Data.List++type Rnd a = (RandomGen g) => State g a++randomRM :: (Random a) => (a, a) -> Rnd a+randomRM v = do+ g <- get+ (x, g') <- return $ randomR v g+ put g'+ return x++choose :: [a] -> Rnd a+choose l = do+ let n = length l+ i <- randomRM (0, n - 1)+ return (l !! i)++chooseIO :: (Foldable f) => f a -> IO a+chooseIO l = do+ let l' = toList l+ n = length l'+ i <- randomRIO (0, n - 1)+ return (l' !! i)++stdNormal :: (Random a, Ord a, Floating a) => Rnd a+stdNormal = do+ u1 <- randomRM (-1, 1)+ u2 <- randomRM (-1, 1)+ let m = stdNormalMarsaglia u1 u2+ case m of+ Nothing -> stdNormal+ Just (z1, _) -> return z1++stdNormalMarsaglia :: (Ord a, Floating a) => a -> a -> Maybe (a, a)+stdNormalMarsaglia y1 y2 = + if q > 1 then Nothing else Just (z1, z2)+ where z1 = y1 * p+ z2 = y2 * p+ q = y1 * y1 + y2 * y2+ p = sqrt ((-2) * log q / q)++normal :: (Random a, Ord a, Floating a) => a -> a -> Rnd a+normal mu sigma = do+ n <- stdNormal+ return $ mu + n * sigma++normalR :: (Random a, Ord a, Floating a) => (a, a) -> a -> a -> Rnd a+normalR (mn, mx) mu sigma = do+ n <- normal mu sigma+ if n < mn + then return mn + else if n > mx+ then return mx else return n++normalIO :: (Random a, Ord a, Floating a) => a -> a -> IO a+normalIO mu sigma = newStdGen >>= return . evalState (normal mu sigma)++normalRIO :: (Random a, Ord a, Floating a) => (a, a) -> a -> a -> IO a+normalRIO limits mu sigma = newStdGen >>= return . evalState (normalR limits mu sigma)++average :: (Fractional a) => [a] -> a+average l = go 0 0 l+ where go acc len [] = acc / len+ go acc len (x:xs) = go (acc + x) (len + 1) xs++averageInt :: [Int] -> Int+averageInt l = go 0 0 l+ where go acc len [] = acc `div` len+ go acc len (x:xs) = go (acc + x) (len + 1) xs++median :: (Ord a, Num a) => [a] -> a+median [] = error "Median on empty list"+median l = (sort l) !! (length l `div` 2)++-- chance of a to b+chance :: Int -> Int -> Rnd Bool+chance a b = do+ v <- randomRM (1, b)+ if a <= v - 1+ then return True+ else return False++-- shuffle :: [a] -> Rnd [a]+shuffle l = shuffle' l [] -- >>= reverse >>= flip shuffle' []+ where shuffle' [] bs = return bs+ shuffle' as bs = do+ el <- choose as+ shuffle' (delete el as) (el : bs)+
+ src/TextScreen.hs view
@@ -0,0 +1,113 @@+module TextScreen(loopTextScreen,+ makeTextScreen,+ drawButton,+ pressOneOfScreen,+ pressKeyScreen,+ pressAnyKeyScreen,+ menu)+where++import Data.List+import Control.Monad+import Control.Monad.State as State+import Prelude hiding (catch)++import Graphics.Rendering.OpenGL as OpenGL+import Graphics.UI.SDL as SDL+import Graphics.Rendering.FTGL as FTGL++import Camera+import Space+import SDLUtils+import Utils++writeLine :: (GLdouble, GLdouble) -> (Font, Color4 GLfloat, String) -> IO ()+writeLine (xstart, ystart) (f, c, s) = do+ loadIdentity+ translate (Vector3 xstart ystart (0 :: GLdouble))+ currentColor $= c+ forM_ (lines s) $ \str -> do+ renderFont f str FTGL.Front+ translate (Vector3 0 (-50) (0 :: GLdouble))++makeTextScreen :: (GLdouble, GLdouble) -> [(Font, Color4 GLfloat, String)] -> IO () -> IO ()+makeTextScreen (xstart, ystart) instructions additional = do+ clear [ColorBuffer,DepthBuffer]+ loadIdentity+ setCamera ((0, 0), (width, height))+ translate (Vector3 xstart ystart (0 :: GLdouble))+ forM_ instructions $ \(f, c, s) -> do+ currentColor $= c+ forM_ (lines s) $ \str -> do+ renderFont f str FTGL.Front+ translate (Vector3 0 (-50) (0 :: GLdouble))+ additional+ glSwapBuffers++-- TODO: write another version of this based on FPS+-- and another one with m Bool as event function+loopTextScreen :: (MonadIO m) => m () -> m (Maybe a) -> m a+loopTextScreen drawScreenFunc handleEventsFunc = untilDoneR $ do+ liftIO $ delay 10+ drawScreenFunc+ handleEventsFunc++drawButton :: Maybe (String, Font) -> ((GLdouble, GLdouble), (GLdouble, GLdouble)) -> IO ()+drawButton ms ((tlx, tly), (diffx, diffy)) = do+ loadIdentity+ translate $ Vector3 tlx (tly + 2) (0 :: GLdouble)+ currentColor $= Color4 1.0 1.0 1.0 1.0+ renderPrimitive LineLoop $+ mapM_ vertex [Vertex3 (0 :: GLdouble) 0 0, Vertex3 0 diffy 0, Vertex3 diffx diffy 0, Vertex3 diffx 0 0]+ case ms of+ Nothing -> return ()+ Just (str, f) -> do+ translate $ Vector3 10 8 (0 :: GLdouble)+ renderFont f str FTGL.Front++menu :: Int -> (Font, Color4 GLfloat, String) -> [(Font, Color4 GLfloat, String)] -> (Font, Color4 GLfloat, String) -> IO Int+menu defval (titlef, titlec, titlestr) options cursor = do+ let numitems = length options+ let title = (titlef, titlec, titlestr ++ replicate (4 - length (lines titlestr)) '\n')+ let drawCursor n = liftIO $ writeLine (130, 400 - 50 * fromIntegral n) cursor+ let buttoncoords :: (Num a) => [((a, a), (a, a))]+ buttoncoords = [((180, 385 - 50 * fromIntegral i), (300, 40)) | i <- [1..numitems]]+ let drawButtons = forM_ buttoncoords $ \b -> do+ drawButton Nothing b+ if numitems == 0+ then return 0+ else do+ n <- Prelude.flip evalStateT (clamp 1 numitems defval) $ do+ let drawfunc = do n <- State.get + liftIO $ makeTextScreen (200, 500)+ (title:options)+ (drawButtons >> drawCursor n)+ let getInput = do+ evts <- liftIO $ pollAllSDLEvents+ when (keyWasPressed SDLK_DOWN evts) $+ modify (\p -> min numitems $ p + 1)+ when (keyWasPressed SDLK_UP evts) $+ modify (\p -> max 1 $ p - 1)+ if oneofKeyWasPressed [SDLK_RETURN, SDLK_SPACE] evts+ then State.get >>= return . Just + else do+ let mbutton = mouseClickInAny height [ButtonLeft] buttoncoords evts+ return $ mbutton >>= (fmap . fmap) (+1) (Prelude.flip elemIndex buttoncoords)+ loopTextScreen drawfunc getInput+ return n++pressOneOfScreen :: (MonadIO m) => m () -> [SDLKey] -> m SDLKey+pressOneOfScreen scr keys = + loopTextScreen scr+ (liftIO $ pollAllSDLEvents >>= return . specificKeyPressed keys)++pressKeyScreen :: (MonadIO m) => m () -> SDLKey -> m ()+pressKeyScreen scr k =+ loopTextScreen scr+ (liftIO $ pollAllSDLEvents >>= return . boolToMaybe . keyWasPressed k)++pressAnyKeyScreen :: (MonadIO m) => m () -> m ()+pressAnyKeyScreen scr =+ loopTextScreen scr+ (liftIO $ pollAllSDLEvents >>= return . boolToMaybe . anyKeyOrMouseWasPressed)+
+ src/Tree.hs view
@@ -0,0 +1,27 @@+module Tree(Tree(..), mapInner)+where++import Data.Foldable++data Tree a b = Leaf b | Node a [Tree a b]+ deriving (Eq, Read, Show)++mapTree :: (b -> c) -> Tree a b -> Tree a c+mapTree f (Leaf b) = Leaf (f b)+mapTree f (Node a ts) = Node a (map (mapTree f) ts)++mapInner :: (a -> c) -> Tree a b -> Tree c b+mapInner _ (Leaf b) = Leaf b+mapInner f (Node a ts) = Node (f a) (map (mapInner f) ts)++instance Functor (Tree a) where+ fmap = mapTree++foldTreer :: (a -> b -> b) -> b -> Tree c a -> b+foldTreer f v (Leaf a) = f a v+foldTreer _ v (Node _ []) = v+foldTreer f v (Node c (t:ts)) = foldTreer f (foldTreer f v t) (Node c ts)++instance Foldable (Tree a) where+ foldr = foldTreer+
+ src/Universe.hs view
@@ -0,0 +1,52 @@+module Universe+where++import Graphics.Rendering.OpenGL as OpenGL++import AObject+import Politics+import Statistics+import Tree+import OpenGLUtils++aobjs :: AObjTree+aobjs = Node (0.0, 0.0)+ [ Leaf $ AObject "Star" 0 (Color4 0.9 0.0 0.0 1.0) 6.0 1.0 0 glVector3Null Nothing+ , Leaf $ AObject "Murphy's" 10 (Color4 0.5 0.5 1.0 1.0) 2.0 1.0 28 glVector3Null (Just "Murphy")+ , Leaf $ AObject "Loki" 250 (Color4 0.0 0.4 0.5 1.0) 4.0 1.0 55 glVector3Null (Just "Harju")+ , Node (30, 115) $ + [Leaf $ AObject "Harju" 30 (Color4 0.6 0.6 0.6 1.0) 9.0 1.0 0 glVector3Null (Just "Harju")+ , Leaf $ AObject "Harju's Moon" 30 (Color4 0.2 0.9 0.6 1.0) 0.8 1.0 25 glVector3Null (Just "Harju")]+ , Leaf $ AObject "Riesenland" 80 (Color4 0.1 0.8 0.8 1.0) 2.0 1.0 230 glVector3Null (Just "Riesenland")+ , Leaf $ AObject "Riesenland" 80 (Color4 0.1 0.8 0.8 1.0) 2.0 1.0 230 glVector3Null (Just "Riesenland")+ , Node (180, 480) $ + [Leaf $ AObject "Natail" 180 (Color4 0.2 0.2 0.9 1.0) 1.0 1.5 60 glVector3Null (Just "Natail")+ , Leaf $ AObject "Mammoth" 0 (Color4 0.3 0.0 0.6 1.0) 1.5 1.0 40 glVector3Null (Just "Natail")]+ ]++relations = mkRelationshipMap relationsList++relationsList =+ [(("Murphy", "Harju"), (Peace, -5)),+ (("Murphy", "Riesenland"), (Peace, 1)),+ (("Murphy", "Natail"), (Peace, -3)),+ (("Harju", "Riesenland"), (Peace, -1)),+ (("Harju", "Natail"), (Peace, 2)),+ (("Riesenland", "Natail"), (Peace, 0)),+ (("Murphy", "Murphy"), (Peace, 10)),+ (("Harju", "Harju"), (Peace, 10)),+ (("Riesenland", "Riesenland"), (Peace, 10)),+ (("Natail", "Natail"), (Peace, 10))]++randomAllegiance :: IO String+randomAllegiance = chooseIO allegiances++allegiances = ["Murphy", "Harju", "Riesenland", "Natail"]++plalleg :: String+plalleg = ""++initialAttitudes :: AttitudeMap+initialAttitudes = nullAttitudes allegiances++
+ src/Utils.hs view
@@ -0,0 +1,191 @@+module Utils+where++import System.IO+import Data.List hiding (foldl')+import Data.Foldable+import Data.Char+import Control.Monad+import System.Random+import Control.Monad.State++import Collision++getOneChar :: IO Char+getOneChar = do+ b <- hGetBuffering stdin+ hSetBuffering stdin NoBuffering+ c <- getChar+ putStrLn ""+ hSetBuffering stdin b+ return c++readInt :: String -> Maybe Int+readInt = safeRead++safeRead :: (Read a) => String -> Maybe a+safeRead s = case reads s of+ [(n, _)] -> Just n+ _ -> Nothing++putStrGetDigit :: String -> IO Int+putStrGetDigit s = do+ when (not (null s)) $ putStrLn s+ n <- getOneChar+ case readInt [n] of+ Just p -> return p+ Nothing -> putStrGetDigit s++getDigit :: IO Int+getDigit = putStrGetDigit ""++putStrGetNumber :: String -> IO Int+putStrGetNumber s = do+ when (not (null s)) $ putStrLn s+ n <- getLine+ if null n+ then putStrGetNumber s+ else case readInt n of+ Just p -> return p+ Nothing -> putStrGetNumber s++getNumber :: IO Int+getNumber = putStrGetNumber ""++pick :: [(a -> Bool, b)] -> a -> Maybe b+pick [] _ = Nothing+pick ((f, s):ns) x = if f x+ then Just s + else pick ns x++getFromTable :: String -> [(String, a)] -> Maybe a+getFromTable _ [] = Nothing+getFromTable c ((d, h):ds) = if c `isPrefixOf` d then Just h else getFromTable c ds++type RndS = State Rnd++type Rnd = StdGen++randomThingR :: (Random t, RandomGen s, MonadState s m) => (t, t) -> m t+randomThingR range = do+ r <- get+ let (a, g) = randomR range r+ put g+ return a++randomPair :: (Random t, RandomGen s, MonadState s m) => (t, t) -> m (t, t)+randomPair range = do+ a <- randomThingR range+ a' <- randomThingR range+ return (a, a')++capitalize [] = []+capitalize (h:hs) = toUpper h : hs++untilDoneR :: (Monad m) => m (Maybe a) -> m a+untilDoneR f = do+ done <- f+ case done of+ Nothing -> untilDoneR f+ Just x -> return x++boolToMaybe :: Bool -> Maybe ()+boolToMaybe True = Just ()+boolToMaybe False = Nothing++untilDone :: (Monad m) => m Bool -> m ()+untilDone f = untilDoneR (f >>= return . boolToMaybe)++while :: (Monad m) => m Bool -> m () -> m ()+while n m = do+ r <- n+ if r+ then m >> while n m+ else return ()++until :: (Monad m) => m Bool -> m () -> m ()+until n m = while (liftM not n) m++radToDeg :: (Floating a) => a -> a+radToDeg r = r * 180 / pi++degToRad :: (Floating a) => a -> a+degToRad d = d * pi / 180++lengthF :: (Foldable f) => f a -> Int+lengthF = foldl' (\acc _ -> acc + 1) 0++wrap :: (Num a, Ord a) => a -> a -> a -> a+wrap mn mx v =+ if v < mn + then wrap mn mx (v + diff)+ else if v > mx+ then wrap mn mx (v - diff)+ else v+ where diff = mx - mn++wrapDegrees :: (Num a, Ord a) => a -> a+wrapDegrees = wrap (-180) 180++clamp :: (Ord a) => a -> a -> a -> a+clamp mn mx n = if mn > n then mn else if mx < n then mx else n++insertRev :: (Ord a) => a -> [a] -> [a]+insertRev x xs = insertBy f x xs+ where f a b = case compare a b of+ LT -> GT+ EQ -> EQ+ GT -> LT++modFst :: (a -> a) -> (a, b) -> (a, b)+modFst f (a, b) = (f a, b)++modSnd :: (b -> b) -> (a, b) -> (a, b)+modSnd f (a, b) = (a, f b)++safeIndex :: [a] -> Int -> Maybe a+safeIndex [] _ = Nothing+safeIndex (x:xs) n | n < 0 = Nothing+ | n == 0 = Just x+ | otherwise = safeIndex xs (n - 1)++allEnums :: (Enum a, Bounded a) => [a]+allEnums = [minBound..maxBound]++boxThatIncludes :: (Ord a, Floating a) => + (a, a) -- ^ coords of first pos+ -> (a, a) -- ^ coords of second pos+ -> a -- ^ size of first box+ -> a -- ^ size of second box+ -> a -- ^ width+ -> a -- ^ height+ -> ((a, a), (a, a)) -- ^ box that includes both first and second box+boxThatIncludes (x1, x2) (y1, y2) inc1 inc2 w h =+ let ((minx1, maxx1), (miny1, maxy1)) = boxArea (x1, y1) inc1+ ((minx2, maxx2), (miny2, maxy2)) = boxArea (x2, y2) inc2+ minx = min minx1 minx2+ maxx = max maxx1 maxx2+ miny = min miny1 miny2+ maxy = max maxy1 maxy2+ ratio = w / h+ (midx, midy) = ((maxx + minx) / 2, (maxy + miny) / 2)+ dx = midx - minx+ dy = midy - miny+ dx' = max dx (dy * ratio)+ dy' = max dy (dx * (1/ratio))+ minx' = midx - dx'+ miny' = midy - dy'+ maxx' = midx + dx'+ maxy' = midy + dy'+ in ((minx', maxx'), (miny', maxy'))++{-+randomThing :: (Random t, RandomGen s, MonadState s m) => m t+randomThing = do+ r <- get+ let (a, g) = random r+ put g+ return a+-}++
+ starrover2.cabal view
@@ -0,0 +1,61 @@+Name: starrover2+Version: 0.0.9+Cabal-Version: >= 1.6+License: OtherLicense+License-File: LICENSE+Author: Antti Salonen<ajsalonen at gmail dot com>+Maintainer: Antti Salonen<ajsalonen at gmail dot com>+Copyright: Antti Salonen 2009+Stability: Unstable+Homepage: http://github.com/anttisalonen/starrover2+Category: Game+Synopsis: Space simulation game+Description: Space simulation game.+Build-type: Simple++data-files: share/DejaVuSans.ttf, share/DejaVuSansMono.ttf++extra-source-files: src/AObject.hs,+ src/Camera.hs,+ src/Cargo.hs,+ src/Collision.hs,+ src/Combat.hs,+ src/Entity.hs,+ src/Main.hs,+ src/Mission.hs,+ src/OpenGLUtils.hs,+ src/Politics.hs,+ src/SDLUtils.hs,+ src/Space.hs,+ src/Statistics.hs,+ src/TextScreen.hs,+ src/Tree.hs,+ src/Universe.hs,+ src/Utils.hs,+ src/SpaceState/City.hs,+ src/SpaceState/Combat.hs,+ src/SpaceState/Common.hs,+ src/SpaceState/Difficulty.hs,+ src/SpaceState/Game.hs,+ src/SpaceState/Init.hs,+ src/SpaceState/Input.hs,+ src/SpaceState/Space.hs++source-repository head+ type: git+ location: git://github.com/anttisalonen/starrover2.git++Executable starrover2+ Build-Depends: base > 3 && < 5, haskell98,+ OpenGL>=2.1.0.0,+ mtl>=1.1.0.0,+ SDL>=0.5.5,+ EdisonCore>=1.2.1.0,+ random>=1.0.0.0,+ FTGL>=1.333,+ directory>=1.0.0.0,+ bytestring>=0.9.0.0+ Main-is: Main.hs+ Hs-Source-Dirs: src+ Ghc-options: -Wall -fno-warn-missing-signatures+