diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain + diff --git a/share/DejaVuSans.ttf b/share/DejaVuSans.ttf new file mode 100644 Binary files /dev/null and b/share/DejaVuSans.ttf differ diff --git a/share/DejaVuSansMono.ttf b/share/DejaVuSansMono.ttf new file mode 100644 Binary files /dev/null and b/share/DejaVuSansMono.ttf differ diff --git a/src/AObject.hs b/src/AObject.hs new file mode 100644 --- /dev/null +++ b/src/AObject.hs @@ -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 diff --git a/src/Camera.hs b/src/Camera.hs new file mode 100644 --- /dev/null +++ b/src/Camera.hs @@ -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)} + + diff --git a/src/Cargo.hs b/src/Cargo.hs new file mode 100644 --- /dev/null +++ b/src/Cargo.hs @@ -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') diff --git a/src/Collision.hs b/src/Collision.hs new file mode 100644 --- /dev/null +++ b/src/Collision.hs @@ -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 + + diff --git a/src/Combat.hs b/src/Combat.hs new file mode 100644 --- /dev/null +++ b/src/Combat.hs @@ -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) + + diff --git a/src/Entity.hs b/src/Entity.hs new file mode 100644 --- /dev/null +++ b/src/Entity.hs @@ -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) + + diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -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 + diff --git a/src/Mission.hs b/src/Mission.hs new file mode 100644 --- /dev/null +++ b/src/Mission.hs @@ -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 + diff --git a/src/OpenGLUtils.hs b/src/OpenGLUtils.hs new file mode 100644 --- /dev/null +++ b/src/OpenGLUtils.hs @@ -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 diff --git a/src/Politics.hs b/src/Politics.hs new file mode 100644 --- /dev/null +++ b/src/Politics.hs @@ -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 + diff --git a/src/SDLUtils.hs b/src/SDLUtils.hs new file mode 100644 --- /dev/null +++ b/src/SDLUtils.hs @@ -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 + + diff --git a/src/Space.hs b/src/Space.hs new file mode 100644 --- /dev/null +++ b/src/Space.hs @@ -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) + ] + + diff --git a/src/SpaceState/City.hs b/src/SpaceState/City.hs new file mode 100644 --- /dev/null +++ b/src/SpaceState/City.hs @@ -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) + diff --git a/src/SpaceState/Combat.hs b/src/SpaceState/Combat.hs new file mode 100644 --- /dev/null +++ b/src/SpaceState/Combat.hs @@ -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) + + diff --git a/src/SpaceState/Common.hs b/src/SpaceState/Common.hs new file mode 100644 --- /dev/null +++ b/src/SpaceState/Common.hs @@ -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) + + diff --git a/src/SpaceState/Difficulty.hs b/src/SpaceState/Difficulty.hs new file mode 100644 --- /dev/null +++ b/src/SpaceState/Difficulty.hs @@ -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 + + diff --git a/src/SpaceState/Game.hs b/src/SpaceState/Game.hs new file mode 100644 --- /dev/null +++ b/src/SpaceState/Game.hs @@ -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 + diff --git a/src/SpaceState/Init.hs b/src/SpaceState/Init.hs new file mode 100644 --- /dev/null +++ b/src/SpaceState/Init.hs @@ -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 + + diff --git a/src/SpaceState/Input.hs b/src/SpaceState/Input.hs new file mode 100644 --- /dev/null +++ b/src/SpaceState/Input.hs @@ -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 + + diff --git a/src/SpaceState/Space.hs b/src/SpaceState/Space.hs new file mode 100644 --- /dev/null +++ b/src/SpaceState/Space.hs @@ -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 + + diff --git a/src/Statistics.hs b/src/Statistics.hs new file mode 100644 --- /dev/null +++ b/src/Statistics.hs @@ -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) + diff --git a/src/TextScreen.hs b/src/TextScreen.hs new file mode 100644 --- /dev/null +++ b/src/TextScreen.hs @@ -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) + diff --git a/src/Tree.hs b/src/Tree.hs new file mode 100644 --- /dev/null +++ b/src/Tree.hs @@ -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 + diff --git a/src/Universe.hs b/src/Universe.hs new file mode 100644 --- /dev/null +++ b/src/Universe.hs @@ -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 + + diff --git a/src/Utils.hs b/src/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Utils.hs @@ -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 +-} + + diff --git a/starrover2.cabal b/starrover2.cabal new file mode 100644 --- /dev/null +++ b/starrover2.cabal @@ -0,0 +1,61 @@ +Name: starrover2 +Version: 0.0.9 +Cabal-Version: >= 1.6 +License: OtherLicense +License-File: LICENSE +Author: Antti Salonen +Maintainer: Antti Salonen +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 +