399 lines
12 KiB
Haskell
399 lines
12 KiB
Haskell
{- | Actions performed by creatures within the world
|
|
-}
|
|
{-# LANGUAGE BangPatterns #-}
|
|
module Dodge.Creature.Action
|
|
( module Dodge.Creature.Action
|
|
, module Dodge.Creature.Action.UseItem
|
|
, module Dodge.Creature.Action.Movement
|
|
)
|
|
where
|
|
import Dodge.Creature.Action.UseItem
|
|
import Dodge.Creature.Action.Movement
|
|
import Dodge.Creature.Stance.Data
|
|
import Dodge.Creature.State.Data
|
|
import Dodge.WorldEvent.Shockwave
|
|
import Dodge.Data hiding (carriage)
|
|
import Dodge.Base
|
|
import Dodge.SoundLogic
|
|
import Dodge.WorldEvent
|
|
import Dodge.Inventory
|
|
import Dodge.LightSources
|
|
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 -- ^ Speed
|
|
-> Int -- ^ Creature id
|
|
-> World
|
|
-> World
|
|
moveForwardSpeed x n w = over (creatures . ix n . crPos) (+.+ p) w
|
|
where
|
|
p = (*.*) x $ unitVectorAtAngle $ _crDir $ _creatures w IM.! n
|
|
|
|
crStrafeLeft
|
|
:: Float -- ^ Speed
|
|
-> 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 -- ^ Speed
|
|
-> 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 -- ^ Speed
|
|
-> 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 -- ^ Movement translation vector
|
|
-> 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 $ _crStance cr) == Aiming
|
|
= fromMaybe 1 $ it ^? itAimingSpeed
|
|
| otherwise = 1
|
|
it = _crInv cr IM.! _crInvSel cr
|
|
|
|
stepForward
|
|
:: Float -- ^ Speed
|
|
-> Creature
|
|
-> Creature
|
|
stepForward speed cr = over (crStance . carriage) f cr
|
|
where
|
|
f (w@Walking {}) = w {_stepToAdd = ceiling speed}
|
|
f s = s
|
|
|
|
|
|
turnTo
|
|
:: Point2 -- ^ Target point
|
|
-> Int -- ^ Creature id
|
|
-> World
|
|
-> World
|
|
turnTo p n w = set (creatures . ix n . crDir) dirToTarget w
|
|
where
|
|
cr = _creatures w IM.! n
|
|
dirToTarget = argV (p -.- _crPos cr)
|
|
|
|
turnTowardRandomise
|
|
:: Point2 -- ^ Target point
|
|
-> Int -- ^ Creature id
|
|
-> World
|
|
-> World
|
|
turnTowardRandomise 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 -- ^ Angle
|
|
-> Int -- ^ Creature id
|
|
-> 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
|
|
|
|
turnTowardWithSpeed
|
|
:: Float -- ^ Turn speed
|
|
-> Point2 -- ^ Target point
|
|
-> Int -- ^ Creature id
|
|
-> World
|
|
-> World
|
|
turnTowardWithSpeed 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 -- ^ Strafe speed
|
|
-> Float -- ^ Turn speed
|
|
-> Point2 -- ^ Target position
|
|
-> 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 -- ^ Target position
|
|
-> Creature
|
|
-> Creature
|
|
crTurnTo p cr = set crDir dirToTarget cr
|
|
where dirToTarget = argV (p -.- _crPos cr)
|
|
|
|
crRandomTurn
|
|
:: RandomGen g
|
|
=> Float -- ^ Max possible angle, supposed to be positive
|
|
-> Creature
|
|
-> g
|
|
-> (Creature, g)
|
|
crRandomTurn a cr g =
|
|
let (r, g') = randomR (negate a, a) g
|
|
in (cr & crDir +~ r, g')
|
|
|
|
crTurnTowardSpeed
|
|
:: Float -- ^ Turn speed
|
|
-> Point2 -- ^ Target position
|
|
-> 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 -- ^ Turn speed
|
|
-> Point2 -- ^ Target position
|
|
-> Int -- ^ Creature id
|
|
-> 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
|
|
|
|
turnToward
|
|
:: Point2 -- ^ Target position
|
|
-> Int -- ^ Creature id
|
|
-> 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)
|
|
|
|
{- Move a creature forward in the direction it is facing. -}
|
|
moveForward
|
|
:: Int -- ^ Creature id
|
|
-> World
|
|
-> World
|
|
moveForward n w = over (creatures . ix n . crPos) (+.+ p) w
|
|
where
|
|
p = unitVectorAtAngle $ _crDir $ _creatures w IM.! n
|
|
|
|
{- Move a creature forward, faster if it is facing a target point -}
|
|
moveToward
|
|
:: Point2 -- ^ Target point
|
|
-> Int -- ^ Creature id
|
|
-> 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)
|
|
|
|
{- Translate a creature. -}
|
|
moveBy
|
|
:: Int -- ^ Creature id
|
|
-> Point2 -- ^ Translation
|
|
-> World
|
|
-> World
|
|
moveBy n v = over (creatures . ix n . crPos) (+.+ v)
|
|
|
|
reloadWeapon
|
|
:: Int -- ^ Creature id
|
|
-> 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
|
|
|
|
{- Start reloading if clip is empty. -}
|
|
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
|
|
|
|
{- Teleport a creature to the mouse position -}
|
|
blinkAction
|
|
:: Int -- ^ Creature id
|
|
-> World
|
|
-> World
|
|
blinkAction n w
|
|
= soundOnce teleSound
|
|
. set (creatures . ix n . crPos) p3
|
|
. blinkShockwave n 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 = reflectPointWalls 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
|
|
:: Int -- ^ Blinking creature ID.
|
|
-> Point2
|
|
-> World
|
|
-> World
|
|
blinkShockwave i p = makeShockwaveAt [i] p 60 1 2 cyan
|
|
|
|
moveAmountToward
|
|
:: Point2 -- ^ Start point
|
|
-> Float -- ^ Fraction to move along
|
|
-> Point2 -- ^ End point
|
|
-> Point2
|
|
moveAmountToward p1 am p2
|
|
= p1 +.+ am *.* errorNormalizeV 44 (p2 -.- p1)
|
|
|
|
reverseDir
|
|
:: Int -- ^ Creature id
|
|
-> World
|
|
-> World
|
|
reverseDir n = over (creatures . ix n . crDir) (+ pi)
|
|
|
|
turnBy
|
|
:: Float -- ^ Angle change
|
|
-> Int -- ^ Creature id
|
|
-> World
|
|
-> World
|
|
turnBy a n = over (creatures . ix n . crDir) (+ a)
|
|
|
|
{-
|
|
Get your creature to drop the item under the cursor.
|
|
-}
|
|
youDropItem :: World -> World
|
|
youDropItem w = case yourItem w of
|
|
NoItem -> w
|
|
it -> rmSelectedInvItem (_yourID w)
|
|
. copyItemToFloor (you w) (_crInvSel $ you w)
|
|
$ soundOnce putDownSound
|
|
w
|
|
|
|
{- Copy an inventory item to the floor. -}
|
|
copyItemToFloor
|
|
:: Creature
|
|
-> Int -- ^ Inventory position
|
|
-> World
|
|
-> World
|
|
copyItemToFloor cr i w = case _crInv cr IM.! i of
|
|
NoItem -> w
|
|
it -> over floorItems (IM.insert flid theflit)
|
|
. updateLocation
|
|
$ set randGen g w
|
|
where
|
|
(rot, g) = randomR (-pi,pi) $ _randGen w
|
|
offset = (_crRad cr + 2) *.* 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 = it
|
|
,_flItPos = offset +.+ _crPos cr
|
|
,_flItRot = rot
|
|
,_flItID = flid
|
|
}
|
|
|
|
{- Pick up a specific item. -}
|
|
pickUpItem :: FloorItem -> World -> World
|
|
pickUpItem flit w = case maybeInvSlot of
|
|
Nothing -> w
|
|
Just i -> w
|
|
& soundOnce pickUpSound
|
|
& updateItLocation i
|
|
& 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
|
|
|
|
{- | A creature attempts to move under its own steam.
|
|
The idea is that this may or may not work, depending on the status of the creature.
|
|
For now, though, this cannot fail. -}
|
|
creatureMove :: Point2 -> Creature -> Creature
|
|
creatureMove p = crPos %~ (+.+ p)
|
|
|
|
creatureTurn :: Float -> Creature -> Creature
|
|
creatureTurn a = crDir +~ a
|
|
|