284 lines
12 KiB
Haskell
284 lines
12 KiB
Haskell
{-# LANGUAGE BangPatterns #-}
|
|
module Dodge.CreatureAction
|
|
( module Dodge.CreatureAction
|
|
, useItem
|
|
, tryUseItem
|
|
)
|
|
where
|
|
-- imports {{{
|
|
import Dodge.CreatureAction.UseItem
|
|
|
|
import Dodge.Data
|
|
import Dodge.Base
|
|
import Dodge.SoundLogic
|
|
import Dodge.WorldEvent
|
|
import Dodge.Inventory
|
|
|
|
import Geometry
|
|
import Picture
|
|
|
|
import Control.Lens
|
|
import Control.Monad
|
|
import Control.Applicative
|
|
|
|
import Data.Maybe
|
|
import Data.List
|
|
|
|
import System.Random
|
|
|
|
import qualified Data.IntMap.Strict as IM
|
|
import qualified Data.Map as M
|
|
-- }}}
|
|
|
|
moveForwardSpeed :: Float -> Int -> World -> World
|
|
moveForwardSpeed x n w = over (creatures . ix n . crPos) (+.+ p) w
|
|
where p = (*.*) x $ unitVectorAtAngle $ _crDir $ _creatures w IM.! n
|
|
|
|
mvForward :: Float -> Int -> World -> World
|
|
mvForward speed cid w = stepForward cid speed $ over (creatures . ix cid . crPos) (+.+ p) w
|
|
where p = (*.*) (speed * equipFactor) $ unitVectorAtAngle $ _crDir $ _creatures w IM.! cid
|
|
equipFactor = product $ map equipSpeed $ IM.elems $ _crInv $ _creatures w IM.! cid
|
|
|
|
crStrafeLeft :: Float -> Creature -> Creature
|
|
crStrafeLeft speed cr = stepForward' s2 $ over crPos (+.+ p) cr
|
|
where p = (*.*) s2 $ unitVectorAtAngle $ (_crDir cr + pi/2)
|
|
equipFactor = product $ map equipSpeed $ IM.elems $ _crInv cr
|
|
s2 = (speed * equipFactor)
|
|
crStrafeRight :: Float -> Creature -> Creature
|
|
crStrafeRight speed cr = stepForward' s2 $ over crPos (+.+ p) cr
|
|
where p = (*.*) s2 $ unitVectorAtAngle $ (_crDir cr - pi/2)
|
|
equipFactor = product $ map equipSpeed $ IM.elems $ _crInv cr
|
|
s2 = (speed * equipFactor)
|
|
|
|
crMvForward :: Float -> Creature -> Creature
|
|
crMvForward speed cr = over crPos (+.+ p) cr
|
|
where p = (*.*) (speed * equipFactor) $ unitVectorAtAngle $ _crDir cr
|
|
equipFactor = product $ map equipSpeed $ IM.elems $ _crInv cr
|
|
|
|
crMvBy :: Point2 -> Creature -> Creature
|
|
crMvBy p' cr = stepForward' (magV p) $ over crPos (+.+ p) cr
|
|
where p = (*.*) (equipFactor * aimingFactor) $ rotateV (_crDir cr) p'
|
|
equipFactor = product $ map equipSpeed $ IM.elems $ _crInv cr
|
|
aimingFactor | (_posture $ _stance $ _crState cr) == Aiming
|
|
= fromMaybe 1 $ it ^? itAimingSpeed
|
|
| otherwise = 1
|
|
it = _crInv cr IM.! _crInvSel cr
|
|
|
|
stepForward :: Int -> Float -> World -> World
|
|
stepForward cid speed = over (creatures . ix cid . crState . stance . carriage) f
|
|
where f (w@Walking {}) = w {_stepToAdd = ceiling speed}
|
|
f s = s
|
|
|
|
stepForward' :: Float -> Creature -> Creature
|
|
stepForward' speed cr = over (crState . stance . carriage) f cr
|
|
where f (w@Walking {}) = w {_stepToAdd = ceiling speed}
|
|
f s = s
|
|
|
|
equipSpeed NoItem = 1
|
|
equipSpeed it | _itIdentity it == FrontArmour = 0.75
|
|
| _itIdentity it == FlameShield = 0.75
|
|
| otherwise = 1
|
|
|
|
turnTo :: Point2 -> Int -> World -> World
|
|
turnTo p n w = set (creatures . ix n . crDir) dirToTarget w
|
|
where cr = _creatures w IM.! n
|
|
dirToTarget = argV (p -.- _crPos cr)
|
|
|
|
turnToward :: Point2 -> Int -> World -> World
|
|
turnToward p n w | isLeftOfA dirToTarget (_crDir cr)
|
|
= f $ over (creatures . ix n . crDir)
|
|
(normalizeAngle . (+ (0.03 + r*m))) w
|
|
| otherwise = f $ over (creatures . ix n . crDir)
|
|
(\x->normalizeAngle (x - (0.03 + r*m))) w
|
|
where cr = _creatures w IM.! n
|
|
dirToTarget = argV (p -.- _crPos cr)
|
|
(r,g) = randomR (-0.1,0.1) (_randGen w)
|
|
m = diffAngles dirToTarget (_crDir cr)
|
|
f = set randGen g
|
|
|
|
turnTowardAngle :: Float -> Int -> World -> World
|
|
turnTowardAngle a n w
|
|
| isLeftOfA a (_crDir cr) = f $ over (creatures . ix n . crDir)
|
|
(normalizeAngle . (+ (0.03 + r*m))) w
|
|
| otherwise = f $ over (creatures . ix n . crDir)
|
|
(\x->normalizeAngle (x - (0.03 + r*m))) w
|
|
where cr = _creatures w IM.! n
|
|
(r,g) = randomR (-0.1,0.1) (_randGen w)
|
|
m = diffAngles a (_crDir cr)
|
|
f = set randGen g
|
|
|
|
turnToward'' :: Float -> Point2 -> Int -> World -> World
|
|
turnToward'' turnSpeed p n w
|
|
| isLeftOfA dirToTarget (_crDir cr)
|
|
= f $ over (creatures . ix n . crDir) (normalizeAngle. (+ (turnSpeed + r))) w
|
|
| otherwise = f $ over (creatures . ix n . crDir) (\x->normalizeAngle (x - (turnSpeed + r))) w
|
|
where cr = _creatures w IM.! n
|
|
dirToTarget = argV (p -.- _crPos cr)
|
|
(r,g) = randomR (-0.1,0.1) (_randGen w)
|
|
f = set randGen g
|
|
|
|
crTurnAndStrafeIn :: Float -> Float -> Point2 -> Creature -> Creature
|
|
crTurnAndStrafeIn strafeSpeed turnSpeed p cr
|
|
| vToTarg == (0,0) = cr -- this should deal with the angleVV error
|
|
| errorAngleVV 3 vToTarg (unitVectorAtAngle (_crDir cr)) <= turnSpeed
|
|
= set crDir dirToTarget cr
|
|
| isLeftOfA dirToTarget (_crDir cr)
|
|
= over crDir (normalizeAngle . (+ turnAmount ))
|
|
$ crStrafeLeft strafeSpeed cr
|
|
| otherwise = over crDir (\x->normalizeAngle (x - turnAmount))
|
|
$ crStrafeRight strafeSpeed cr
|
|
where vToTarg = p -.- _crPos cr
|
|
dirToTarget = argV vToTarg
|
|
turnAmount = turnSpeed
|
|
|
|
crTurnTo :: Point2 -> Creature -> Creature
|
|
crTurnTo p cr = set crDir dirToTarget cr
|
|
where dirToTarget = argV (p -.- _crPos cr)
|
|
|
|
crTurnTowardSpeed :: Float -> Point2 -> Creature -> Creature
|
|
crTurnTowardSpeed turnSpeed p cr
|
|
| vToTarg == (0,0) = cr -- this should deal with the angleVV error
|
|
| errorAngleVV 3 vToTarg (unitVectorAtAngle (_crDir cr)) <= turnSpeed
|
|
= set crDir dirToTarget cr
|
|
| isLeftOfA dirToTarget (_crDir cr)
|
|
= over crDir (normalizeAngle . (+ turnAmount )) cr
|
|
| otherwise = over crDir (\x->normalizeAngle (x - turnAmount)) cr
|
|
where vToTarg = p -.- _crPos cr
|
|
dirToTarget = argV vToTarg
|
|
turnAmount = turnSpeed
|
|
|
|
turnTowardSpeed :: Float -> Point2 -> Int -> World -> World
|
|
turnTowardSpeed turnSpeed p n w
|
|
| vToTarg == (0,0) = w -- this should deal with the angleVV error
|
|
| errorAngleVV 3 vToTarg (unitVectorAtAngle (_crDir cr)) <= turnSpeed
|
|
= set (creatures . ix n . crDir) dirToTarget w
|
|
| isLeftOfA dirToTarget (_crDir cr)
|
|
= over (creatures . ix n . crDir) (normalizeAngle . (+ turnAmount )) w
|
|
| otherwise = over (creatures . ix n . crDir) (\x->normalizeAngle (x - turnAmount)) w
|
|
where cr = _creatures w IM.! n
|
|
vToTarg = p -.- _crPos cr
|
|
dirToTarget = argV vToTarg
|
|
turnAmount = turnSpeed
|
|
|
|
turnLRS :: Int -> World -> World
|
|
turnLRS n w = f $ over (creatures . ix n . crDir) (+ (fromIntegral r * pi / 2)) w
|
|
where (r,g) = randomR (negate 1::Int,1) (_randGen w)
|
|
f = set randGen g
|
|
|
|
turnToward' :: Point2 -> Int -> World -> World
|
|
turnToward' p n w | isLeftOfA dirToTarget (_crDir cr)
|
|
= over (creatures . ix n . crDir) (+ 0.03) w
|
|
| otherwise = over (creatures . ix n . crDir) (\x-> x - 0.03) w
|
|
where cr = _creatures w IM.! n
|
|
dirToTarget = argV (p -.- _crPos cr)
|
|
|
|
overturnToward :: Point2 -> Int -> World -> World
|
|
overturnToward p n w
|
|
| isLeftOfA dirToTarget (_crDir cr)
|
|
= over (creatures . ix n . crDir) (normalizeAngle. (+ 0.03 )) w
|
|
| otherwise = over (creatures . ix n . crDir) (\x->normalizeAngle (x - 0.03 )) w
|
|
where cr = _creatures w IM.! n
|
|
dirToTarget = argV (p -.- _crPos cr)
|
|
|
|
moveForward :: Int -> World -> World
|
|
moveForward n w = over (creatures . ix n . crPos) (+.+ p) w
|
|
where p = unitVectorAtAngle $ _crDir $ _creatures w IM.! n
|
|
|
|
moveToward :: Point2 -> Int -> World -> World
|
|
moveToward p n w
|
|
| angle < 10 = moveForwardSpeed 0.1 n w
|
|
| angle < 20 = moveForwardSpeed 0.02 n w
|
|
| angle < 40 = moveForwardSpeed 0.01 n w
|
|
| otherwise = w
|
|
where angle = errorAngleVV 5 (p -.- curPos) (unitVectorAtAngle (_crDir (_creatures w IM.! n)))
|
|
curPos = _crPos (_creatures w IM.! n)
|
|
|
|
moveBy :: Int -> Point2 -> World -> World
|
|
moveBy n v = over (creatures . ix n . crPos) (+.+ v)
|
|
|
|
reloadWeapon :: Int -> World -> Maybe World
|
|
reloadWeapon cid w =
|
|
let cr = _creatures w IM.! cid
|
|
it = _crInv cr IM.! _crInvSel cr
|
|
itRef = creatures . ix cid . crInv . ix (_crInvSel cr)
|
|
in case it of
|
|
Weapon {_wpMaxAmmo=maxA,_wpLoadedAmmo=lA,_wpReloadState=rS,_wpReloadTime=rT}
|
|
| lA < maxA && rS == 0 -> Just $ set ( itRef . wpLoadedAmmo) maxA
|
|
$ set ( itRef . wpReloadState) rT w
|
|
_ -> Nothing
|
|
|
|
crAutoReload :: Creature -> Creature
|
|
crAutoReload cr = case cr ^? crInv . ix (_crInvSel cr) . wpLoadedAmmo of
|
|
Just 0 -> cr & crInv . ix (_crInvSel cr) . wpReloadState %~ (`fromMaybe` reloadT)
|
|
& crInv . ix (_crInvSel cr) . wpLoadedAmmo %~ (`fromMaybe` maxA)
|
|
_ -> cr
|
|
where reloadT = cr ^? crInv . ix (_crInvSel cr) . wpReloadTime
|
|
maxA = cr ^? crInv . ix (_crInvSel cr) . wpMaxAmmo
|
|
|
|
createItemAt :: Point2 -> FloorItem -> World -> World
|
|
createItemAt p it w = over floorItems (IM.insert i (set flItPos p
|
|
$ set flItID i it)) w
|
|
where i = newKey (_floorItems w)
|
|
|
|
blinkAction :: Int -> World -> World
|
|
blinkAction n w = soundOnce teleSound $ set (creatures . ix n . crPos) p3
|
|
$ blinkShockwave p3
|
|
$ inverseShockwaveAt cp 40 2 2 2
|
|
w
|
|
where p1 = _cameraCenter w +.+ (1 / _cameraZoom w) *.* rotateV (_cameraRot w) (_mousePos w)
|
|
cp = _crPos $ _creatures w IM.! n
|
|
p2 = collidePointWalls cp p1 $ wallsAlongLine cp p1 w
|
|
r = 1.5 * _crRad (_creatures w IM.! n)
|
|
p3 = fromMaybe p1 (fmap ((\p -> moveAmountToward p r cp) . fst) p2)
|
|
|
|
blinkShockwave :: Point2 -> World -> World
|
|
blinkShockwave p = makeShockwaveAt p 40 1 2 cyan
|
|
|
|
moveAmountToward :: Point2 -> Float -> Point2 -> Point2
|
|
moveAmountToward p1 am p2
|
|
= p1 +.+ am *.* errorNormalizeV 44 (p2 -.- p1)
|
|
|
|
facePointAI :: Point2 -> Int -> World -> World
|
|
facePointAI p n w = set (creatures . ix n . crDir)
|
|
(argV (p -.- _crPos (_creatures w IM.! n)) )
|
|
w
|
|
|
|
reverseDir :: Int -> World -> World
|
|
reverseDir n = over (creatures . ix n . crDir) (+ pi)
|
|
|
|
turnBy :: Float -> Int -> World -> World
|
|
turnBy a n = over (creatures . ix n . crDir) (+ a)
|
|
|
|
dropItem :: World -> World
|
|
dropItem w = case yourItem w of
|
|
NoItem -> w
|
|
it -> rmInvItem (_yourID w) $ over floorItems (IM.insert flid theflit)
|
|
$ updateLocation
|
|
$ soundOnce putDownSound
|
|
$ set randGen g w
|
|
where (rot, g) = randomR (-pi,pi) $ _randGen w
|
|
offset = _crRad (you w) *.* unitVectorAtAngle rot
|
|
updateLocation w = case it ^? itID of
|
|
Just (Just i) -> w & itemPositions . ix i .~ OnFloor flid
|
|
_ -> w
|
|
flid = newKey $ _floorItems w
|
|
theflit = FlIt {_flIt = set itAmount 1 it
|
|
,_flItPos = offset +.+ _crPos (you w)
|
|
,_flItRot = rot
|
|
,_flItID = flid}
|
|
|
|
pickUpItem' :: FloorItem -> World -> World
|
|
pickUpItem' flit w = case maybeInvSlot of
|
|
Nothing -> w
|
|
Just i -> soundOnce pickUpSound
|
|
$ updateItLocation i
|
|
$ w & floorItems %~ IM.delete (_flItID flit)
|
|
& creatures . ix 0 . crInv . ix i %~ addItem it
|
|
where
|
|
it = _flIt flit
|
|
maybeInvSlot = checkInvSlotsYou it w
|
|
updateItLocation invid w'
|
|
= case _itID it of Nothing -> w'
|
|
Just j -> w' & itemPositions . ix j .~ InInv 0 invid
|
|
|