starrover2-0.0.9: src/Combat.hs

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)