328 lines
12 KiB
Haskell
328 lines
12 KiB
Haskell
module Dodge.Creature.State (
|
|
stateUpdate,
|
|
doDamage,
|
|
) where
|
|
|
|
import qualified Data.Map.Strict as M
|
|
import Data.Maybe
|
|
import Data.Monoid
|
|
import Dodge.Base
|
|
import Dodge.Corpse.Make
|
|
import Dodge.Creature.Action
|
|
import Dodge.Creature.Damage
|
|
import Dodge.Creature.Impulse.Movement
|
|
import Dodge.Creature.State.WalkCycle
|
|
import Dodge.Creature.Test
|
|
import Dodge.Damage
|
|
import Dodge.Data.ComposedItem
|
|
import Dodge.Data.DoubleTree
|
|
import Dodge.Data.World
|
|
import Dodge.DoubleTree
|
|
import Dodge.Euse
|
|
import Dodge.Hammer
|
|
import Dodge.ItEffect
|
|
import Dodge.Item.Grammar
|
|
import Dodge.Item.HeldOffset
|
|
import Dodge.LightSource
|
|
import Dodge.Prop.Gib
|
|
import Dodge.SoundLogic
|
|
import Dodge.Zoning.Creature
|
|
import FoldableHelp
|
|
import Geometry
|
|
import qualified IntMapHelp as IM
|
|
import LensHelp
|
|
import Picture
|
|
import qualified Quaternion as Q
|
|
import RandomHelp
|
|
import qualified SDL
|
|
import Shape
|
|
import ShapePicture
|
|
|
|
-- this can almost certainly be made more efficient
|
|
foldCr ::
|
|
[Creature -> World -> World] ->
|
|
Creature ->
|
|
World ->
|
|
World
|
|
foldCr xs cr w = foldl' f w xs
|
|
where
|
|
f w' g = case w' ^? cWorld . lWorld . creatures . ix (_crID cr) of
|
|
Just cr' -> g cr' w'
|
|
Nothing -> w'
|
|
|
|
{- | this seems to work, but I am not sure about the ordering:
|
|
previously, the movement was updated before the ai in order to correctly set the oldpos.
|
|
This should be made more sensible: should the movement side effects apply to
|
|
the creature before or after it has moved?
|
|
at what point invSideEffects is applied wrt to when the creature moves
|
|
may affect whether the shield moves correctly
|
|
-}
|
|
stateUpdate :: (Creature -> World -> World) -> Creature -> World -> World
|
|
stateUpdate f =
|
|
foldCr
|
|
[ doDamage -- these two
|
|
, checkDeath -- must be in this order 24/7/22
|
|
, internalCreatureUpdate
|
|
, f
|
|
, footstepSideEffect
|
|
, updateInv -- upInv must be called before invSideEff 22.05.23
|
|
, invSideEff
|
|
, equipmentEffects
|
|
]
|
|
|
|
checkDeath :: Creature -> World -> World
|
|
checkDeath cr
|
|
| _crHP cr > 0 =
|
|
cWorld . lWorld . creatures . ix (_crID cr) . crState . csDamage .~ []
|
|
| otherwise =
|
|
dropByState cr
|
|
. removecr
|
|
. stopSoundFrom (CrWeaponSound (_crID cr) 0)
|
|
. corpseOrGib cr
|
|
where
|
|
removecr
|
|
| _crID cr == 0 =
|
|
(cWorld . lWorld . creatures . ix (_crID cr) . crType .~ NonDrawnCreature)
|
|
. (cWorld . lWorld . creatures . ix (_crID cr) . crHP .~ 0)
|
|
-- hack to get around player creature being killed but left with more than 0 hp
|
|
| otherwise = cWorld . lWorld . creatures . at (_crID cr) .~ Nothing
|
|
|
|
corpseOrGib :: Creature -> World -> World
|
|
corpseOrGib cr = case maxDamageType (_csDamage (_crState cr)) of
|
|
Just (FLAMING, _) -> plNew (cWorld . lWorld . corpses) cpID (thecorpse & cpSPic %~ scorchSPic)
|
|
Just (ELECTRICAL, _) -> plNew (cWorld . lWorld . corpses) cpID thecorpse
|
|
Just (POISONDAM, _) -> plNew (cWorld . lWorld . corpses) cpID (thecorpse & cpSPic %~ poisonSPic)
|
|
_ | _crPastDamage cr > 200 -> addCrGibs cr
|
|
_ -> plNew (cWorld . lWorld . corpses) cpID thecorpse
|
|
where
|
|
thecorpse = makeDefaultCorpse cr
|
|
|
|
scorchSPic :: SPic -> SPic
|
|
scorchSPic = over _1 $ overColSH (mixColors 0.9 0.1 black . normalizeColor)
|
|
|
|
poisonSPic :: SPic -> SPic
|
|
poisonSPic = over _1 $ overColSH (mixColors 0.5 0.5 green . normalizeColor)
|
|
|
|
internalCreatureUpdate :: Creature -> World -> World
|
|
internalCreatureUpdate cr =
|
|
cWorld . lWorld . creatures . ix (_crID cr)
|
|
%~ ( (crHammerPosition %~ moveHammerUp)
|
|
. updateMovement
|
|
)
|
|
|
|
{- | Drop items according to the creature state.
|
|
TODO make sure this doesn't mess up any ItemPosition
|
|
-}
|
|
dropByState :: Creature -> World -> World
|
|
dropByState cr w = foldr (dropItem cr) w $ case cr ^. crState . csDropsOnDeath of
|
|
DropAll -> IM.keys $ _crInv cr
|
|
DropSpecific xs -> xs
|
|
DropAmount n -> take n $ evalState (shuffle $ IM.keys $ _crInv cr) (_randGen w)
|
|
|
|
doDamage :: Creature -> World -> World
|
|
doDamage cr = applyPastDamages cr . applyCreatureDamage dams cr
|
|
where
|
|
dams = _csDamage $ _crState cr
|
|
|
|
-- TODO generalise shake to arbitrary damage amounts
|
|
applyPastDamages :: Creature -> World -> World
|
|
applyPastDamages cr w
|
|
| _crPastDamage cr > 200 =
|
|
let (p, g) = runState (randInCirc 3) (_randGen w)
|
|
in w & cWorld . lWorld . creatures . ix (_crID cr) %~ (crMvBy p . (crPastDamage -~ 100))
|
|
& randGen .~ g
|
|
| _crPastDamage cr > 20 =
|
|
let (p, g) = runState (randInCirc 2) (_randGen w)
|
|
in w & cWorld . lWorld . creatures . ix (_crID cr) %~ (crMvBy p . (crPastDamage -~ 10))
|
|
& randGen .~ g
|
|
| _crPastDamage cr > 0 =
|
|
let (p, g) = runState (randInCirc 1) (_randGen w)
|
|
in w & cWorld . lWorld . creatures . ix (_crID cr) %~ (crMvBy p . (crPastDamage -~ 1))
|
|
& randGen .~ g
|
|
| otherwise = w
|
|
|
|
useEquipment :: Creature -> Int -> World -> World
|
|
useEquipment cr i = useE (_eeUse (_equipEffect $ _itUse itm)) itm cr
|
|
where
|
|
itm = _crInv cr IM.! i
|
|
|
|
-- a map updating all inventory items
|
|
updateInv :: Creature -> World -> World
|
|
updateInv cr = cWorld . lWorld . creatures . ix (_crID cr) . crInv %~ IM.map itemUpdate
|
|
|
|
-- a loop going over equipped items
|
|
-- maybe this should be done during a different loop (invSideEff)?
|
|
equipmentEffects :: Creature -> World -> World
|
|
--equipmentEffects cr = flip (foldl' $ flip $ useEquipment cr) (IM.keys $ _crInvEquipped cr)
|
|
equipmentEffects cr = alaf Endo foldMap (useEquipment cr) (IM.keys $ _crInvEquipped cr)
|
|
|
|
-- a loop going over all inventory items
|
|
invSideEff :: Creature -> World -> World
|
|
invSideEff cr = alaf Endo foldMap f (_crInv cr) . updateRootItem cr
|
|
where
|
|
f it =
|
|
itemInvSideEffect cr it
|
|
. maybe id (\g -> doInvEffect g it cr) (it ^? itEffect . ieInv)
|
|
|
|
updateRootItem :: Creature -> World -> World
|
|
updateRootItem cr = fromMaybe id $ do
|
|
invid <- cr ^? crManipulation . manObject . imRootItem
|
|
itmtree <- invTrees' (_crInv cr) ^? ix invid
|
|
return $ updateRootItem' itmtree cr
|
|
|
|
updateRootItem' :: LabelDoubleTree ItemLink Item -> Creature -> World -> World
|
|
updateRootItem' itmtree cr =
|
|
ldtPropagateFoldTree
|
|
chainLinkOrientation
|
|
chainLinkOrientation
|
|
(updateItemWithOrientation cr)
|
|
(heldItemRelativeOrient (_ldtValue itmtree) cr (0, Q.qID))
|
|
itmtree
|
|
|
|
-- need to check rotation
|
|
chainLinkOrientation ::
|
|
(Point3, Q.Quaternion Float) ->
|
|
Item ->
|
|
ItemLink ->
|
|
Item ->
|
|
(Point3, Q.Quaternion Float)
|
|
chainLinkOrientation mo par (ILink lt f) child = (p + Q.rotate q p1, q * q1)
|
|
where
|
|
(p, q) = mo
|
|
(p1, q1) = f par lt child
|
|
|
|
updateItemWithOrientation ::
|
|
Creature ->
|
|
(Point3, Q.Quaternion Float) ->
|
|
LabelDoubleTree ItemLink Item ->
|
|
World ->
|
|
World
|
|
updateItemWithOrientation cr m itmtree = case _itType itm of
|
|
HELD TORCH -> shineTorch cr itmtree m
|
|
_ -> id
|
|
where
|
|
itm = itmtree ^. ldtValue
|
|
|
|
shineTorch :: Creature -> LabelDoubleTree ItemLink Item -> (Point3, Q.Quaternion Float) -> World -> World
|
|
shineTorch cr itmtree (p, q) = fromMaybe id $ do
|
|
(_, mag) <- find (isammolink . _iatType . fst) (itmtree ^. ldtLeft)
|
|
i <- mag ^? ldtValue . itUse . amagLoadStatus . iaLoaded
|
|
guard $ i >= x
|
|
invid <- mag ^? ldtValue . itLocation . ilInvID
|
|
return $
|
|
(cWorld . lWorld . tempLightSources .:~ tlsTimeRadColPos 1 250 0.7 pos'')
|
|
. (cWorld . lWorld . creatures . ix (_crID cr) . crInv . ix invid . itUse . amagLoadStatus . iaLoaded -~ x)
|
|
where
|
|
x = 10
|
|
isammolink AmmoInLink{} = True
|
|
isammolink _ = False
|
|
pos = (_crPos cr `v2z` 0 + rotate3 cdir p)
|
|
pos'' = pos + rotate3 d (V3 8 0 1.5)
|
|
cdir = _crDir cr
|
|
d = _crDir cr + argV (Q.qToV2 q)
|
|
|
|
itemInvSideEffect :: Creature -> Item -> World -> World
|
|
itemInvSideEffect cr itm = case _itType itm of
|
|
TARGETING tt -> updateItemTargeting tt cr itm
|
|
_ -> id
|
|
|
|
-- this probably needs to be set to null when dropped as well?
|
|
updateItemTargeting :: TargetingType -> Creature -> Item -> World -> World
|
|
updateItemTargeting tt cr itm w = case tt of
|
|
_
|
|
| not isattached ->
|
|
w
|
|
& pointItUse . tgPos .~ Nothing
|
|
& pointItUse . tgActive .~ False
|
|
TARGETLASER
|
|
| crIsAiming cr ->
|
|
w
|
|
& cWorld . lWorld . lasers
|
|
.:~ LaserStart
|
|
{ _lpPhaseV = 1
|
|
, _lpDir = _crDir cr
|
|
, _lpPos = sp
|
|
, _lpColor = col
|
|
, _lpType = TargetingLaser (_itID itm)
|
|
}
|
|
TARGETLASER -> w & pointItUse . tgPos .~ Nothing
|
|
TargetRBPress
|
|
| rbpressed ->
|
|
w
|
|
& pointItUse . tgPos %~ maybe (Just $ mouseWorldPos (w ^. input) (w ^. wCam)) Just
|
|
& pointItUse . tgActive .~ True
|
|
TargetRBPress ->
|
|
w
|
|
& pointItUse . tgPos .~ Nothing
|
|
& pointItUse . tgActive .~ False
|
|
TargetRBCreature -> w & pointItUse %~ setRBCreatureTargeting cr w
|
|
TargetCursor ->
|
|
w & pointItUse
|
|
.~ TargetingUse
|
|
(Just (mouseWorldPos (w ^. input) (w ^. wCam)))
|
|
Nothing
|
|
True
|
|
where
|
|
pointItUse = cWorld . lWorld . creatures . ix cid . crInv . ix invid . itUse
|
|
cid = _crID cr
|
|
invid = _ilInvID $ _itLocation itm
|
|
isattached = itm ^?! itLocation . ilIsAttached
|
|
rbpressed = SDL.ButtonRight `M.member` _mouseButtons (_input w)
|
|
sp = _crPos cr +.+ 15 *.* unitVectorAtAngle (_crDir cr)
|
|
col = blue -- mixColors reloadFrac (1-reloadFrac) blue red
|
|
|
|
setRBCreatureTargeting :: Creature -> World -> ItemUse -> ItemUse
|
|
setRBCreatureTargeting cr w ituse
|
|
| SDL.ButtonRight `M.member` _mouseButtons (_input w) && isJust (ituse ^? tgID . _Just)
|
|
&& canSeeTarget =
|
|
ituse & updatePos & tgActive .~ True
|
|
| otherwise = ituse & tgID .~ fmap _crID newtarg & updatePos & tgActive .~ False
|
|
where
|
|
newtarg =
|
|
safeMinimumOn (dist mwp . _crPos)
|
|
. filter (canseepos . _crPos)
|
|
$ crsNearCirc mwp 40 w
|
|
canseepos p = hasLOS (_crPos cr) p w
|
|
mwp = mouseWorldPos (w ^. input) (w ^. wCam)
|
|
updatePos t' = t' & tgPos .~ posFromMaybeID (_tgID t')
|
|
posFromMaybeID Nothing = Nothing
|
|
posFromMaybeID (Just i) = w ^? cWorld . lWorld . creatures . ix i . crPos
|
|
canSeeTarget = fromMaybe False $ do
|
|
cid <- ituse ^? tgID . _Just
|
|
cpos <- w ^? cWorld . lWorld . creatures . ix cid . crPos
|
|
Just $ hasLOS cpos (_crPos cr) w
|
|
|
|
itemUpdate :: Item -> Item
|
|
itemUpdate = updateAutoRecharge . (itUse %~ useUpdate)
|
|
|
|
useUpdate :: ItemUse -> ItemUse
|
|
useUpdate =
|
|
(heldHammer %~ moveHammerUp)
|
|
. (leftHammer %~ moveHammerUp)
|
|
. (leftDelay . rateTime %~ decreaseToZero)
|
|
. (heldDelay . warmTime %~ decreaseToZero)
|
|
. (heldDelay . rateTime %~ decreaseToZero)
|
|
|
|
updateAutoRecharge :: Item -> Item
|
|
updateAutoRecharge it = case it ^? itUse . leftConsumption of
|
|
Just (AutoRecharging l m t p)
|
|
| l < m && p <= 0 -> it & itUse . leftConsumption .~ AutoRecharging (l + 1) m t t
|
|
| l < m -> it & itUse . leftConsumption . arProgress -~ 1
|
|
_ -> it
|
|
|
|
updateMovement :: Creature -> Creature
|
|
updateMovement cr
|
|
| isFrictionless cr = over crPos (+.+ momentum) cr
|
|
| otherwise = updateWalkCycle cr
|
|
where
|
|
momentum' = 0.98 *.* (_crPos cr -.- _crOldPos cr)
|
|
momentum
|
|
| magV momentum' > 1 = 1 *.* normalizeV momentum'
|
|
| otherwise = momentum'
|
|
|
|
isFrictionless :: Creature -> Bool
|
|
isFrictionless cr = case cr ^? crStance . carriage of
|
|
Just (Boosting _) -> True
|
|
Just Floating -> True
|
|
_ -> False
|