494 lines
18 KiB
Haskell
494 lines
18 KiB
Haskell
module Dodge.Creature.State (
|
|
crUpdate,
|
|
doDamage,
|
|
) where
|
|
|
|
import Dodge.HeldUse
|
|
import Dodge.BaseTriggerType
|
|
import Dodge.Data.DoubleTree
|
|
import Dodge.Item.Orientation
|
|
import Control.Applicative
|
|
import Control.Monad
|
|
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.Damage.Type
|
|
--import Dodge.Data.DoubleTree
|
|
import Dodge.Data.World
|
|
import Dodge.DoubleTree
|
|
import Dodge.Euse
|
|
import Dodge.HeldUse
|
|
import Dodge.Inventory.SelectionList
|
|
import Dodge.Item.BackgroundEffect
|
|
import Dodge.Item.Grammar
|
|
import Dodge.Item.HeldOffset
|
|
import Dodge.Item.Location
|
|
import Dodge.Item.MaxAmmo
|
|
import Dodge.Prop.Gib
|
|
import Dodge.SoundLogic
|
|
import Dodge.Targeting.Draw
|
|
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
|
|
-}
|
|
crUpdate :: (Creature -> World -> World) -> Creature -> World -> World
|
|
crUpdate f =
|
|
foldCr
|
|
[ doDamage -- these two
|
|
, checkDeath -- must be in this order 24/7/22
|
|
, updateWalkCycle
|
|
, f
|
|
, invRootItemEffs
|
|
, updateHeldRootItem
|
|
]
|
|
|
|
-- I have changed the ordering of item/equipment effects, which may have
|
|
-- unforseen consequences, be aware
|
|
|
|
checkDeath :: Creature -> World -> World
|
|
checkDeath cr w
|
|
| _crHP cr > 0 =
|
|
w
|
|
& cWorld . lWorld . creatures . ix (_crID cr) . crDamage .~ []
|
|
| _crHP cr <= -200 =
|
|
w
|
|
& dropAll cr -- the order of
|
|
& removecr -- these is important
|
|
& stopSoundFrom (CrWeaponSound (_crID cr) 0)
|
|
& addCrGibs cr
|
|
| _crHP cr > -200 && _crDeathTimer cr < 5 =
|
|
w
|
|
& cWorld . lWorld . creatures . ix (_crID cr) . crDamage .~ []
|
|
& cWorld . lWorld . creatures . ix (_crID cr) . crDeathTimer +~ 1
|
|
| otherwise =
|
|
w
|
|
& dropAll cr -- the order of
|
|
& removecr -- these is important
|
|
& stopSoundFrom (CrWeaponSound (_crID cr) 0)
|
|
& corpseOrGib cr
|
|
where
|
|
removecr
|
|
| _crID cr == 0 = id
|
|
-- 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
|
|
|
|
-- could look at the amount of damage here (given by maxDamage) too
|
|
corpseOrGib :: Creature -> World -> World
|
|
corpseOrGib cr = case cr ^? crDamage . to maxDamageType . _Just . _1 of
|
|
Just CookingDamage -> addcorpse (thecorpse & cpSPic %~ scorchSPic)
|
|
Just PoisonDamage -> addcorpse (thecorpse & cpSPic %~ poisonSPic)
|
|
Just PhysicalDamage | _crPain cr > 200 -> addCrGibs cr
|
|
_ -> addcorpse thecorpse
|
|
where
|
|
addcorpse ctype = plNew (cWorld . lWorld . corpses) cpID ctype
|
|
thecorpse = makeCorpse cr
|
|
|
|
scorchSPic :: SPic -> SPic
|
|
scorchSPic = _1 %~ overColSH (mixColors 0.9 0.1 black . normalizeColor)
|
|
|
|
poisonSPic :: SPic -> SPic
|
|
poisonSPic = _1 %~ overColSH (mixColors 0.5 0.5 green . normalizeColor)
|
|
|
|
{- | Drop items according to the creature state.
|
|
TODO make sure this doesn't mess up any ItemPosition
|
|
-}
|
|
dropAll :: Creature -> World -> World
|
|
dropAll cr w = foldl' (flip (dropItem cr)) w $ IM.keys $ _crInv cr
|
|
|
|
doDamage :: Creature -> World -> World
|
|
doDamage cr = applyPastDamages cr . applyCreatureDamage (cr ^. crDamage) cr
|
|
|
|
-- TODO generalise shake to arbitrary damage amounts
|
|
applyPastDamages :: Creature -> World -> World
|
|
applyPastDamages cr w
|
|
| _crPain cr > 200 = dojitter 3 100
|
|
| _crPain cr > 20 = dojitter 2 10
|
|
| _crPain cr > 0 = dojitter 1 1
|
|
| otherwise = w
|
|
where
|
|
dojitter x y =
|
|
let (p, g) = runState (randInCirc x) (_randGen w)
|
|
in w & cWorld . lWorld . creatures . ix (_crID cr) %~ crMvBy p
|
|
& cWorld . lWorld . creatures . ix (_crID cr) . crPain -~ y
|
|
& randGen .~ g
|
|
|
|
-- a loop going over all root inventory items
|
|
invRootItemEffs :: Creature -> World -> World
|
|
invRootItemEffs cr =
|
|
appEndo $
|
|
foldMap
|
|
(reduceLocLDT (Endo . invItemLocUpdate cr) . LocLDT TopLDT)
|
|
(invLDT' (_crInv cr))
|
|
|
|
invItemLocUpdate :: Creature -> LocationLDT ItemLink OItem -> World -> World
|
|
invItemLocUpdate cr loc w = doAnyEquipmentEffect loc cr $ case itm ^. itType of
|
|
ATTACH BULLETSYNTH -> trySynthBullet loc w
|
|
EQUIP WRIST_ECG | haspulse -> tryUseParent loc w
|
|
COPIER _ -> copierItemUpdate itm cr w
|
|
HELD FLATSHIELD -> rootNotrootEff createShieldWall removeShieldWall itm cr w
|
|
HELD MINIGUNX{}
|
|
| itm ^? itParams . isWarming == Just True ->
|
|
w
|
|
& pointerToItem itm . itParams . isWarming .~ False
|
|
| otherwise ->
|
|
w & pointerToItem itm . itParams . wTime
|
|
%~ (max 0 . subtract 1)
|
|
HELD MACHINEPISTOL{}
|
|
| fromMaybe 0 (itm ^? itParams . wTime) >= _coolEnd (itemTriggerType itm) ->
|
|
w & pointerToItem itm . itParams . wTime
|
|
.~ 0
|
|
& pointerToItem itm . itParams . coolSound .~ Nothing
|
|
| fromMaybe 0 (itm ^? itParams . wTime) == _coolStart (itemTriggerType itm) ->
|
|
w
|
|
& randGen .~ g
|
|
& pointerToItem itm . itParams . wTime +~ 1
|
|
& pointerToItem itm . itParams . coolSound ?~ sid
|
|
& soundContinue (CrWeaponSound (_crID cr) (fromIntegral $ _itID itm)) (_crPos cr) sid (Just 1)
|
|
| fromMaybe 0 (itm ^? itParams . wTime) > _coolStart (itemTriggerType itm) ->
|
|
w
|
|
& pointerToItem itm . itParams . wTime +~ 1
|
|
& soundContinue (CrWeaponSound (_crID cr) (fromIntegral $ _itID itm)) (_crPos cr) (fromMaybe undefined (itm ^? itParams . coolSound . _Just)) (Just 1)
|
|
| itm ^? itParams . isWarming == Just True ->
|
|
w
|
|
& pointerToItem itm . itParams . isWarming .~ False
|
|
| fromMaybe 0 (itm ^? itParams . wTime) >= _warmStart (itemTriggerType itm) ->
|
|
w & pointerToItem itm . itParams . wTime
|
|
.~ _coolStart (itemTriggerType itm)
|
|
| otherwise ->
|
|
w & pointerToItem itm . itParams . wTime
|
|
.~ 0
|
|
_ -> w
|
|
where
|
|
haspulse =
|
|
w ^? cWorld . lWorld . creatures . ix 0 . crType . avatarPulse . pulseProgress
|
|
== Just 0
|
|
itm = loc ^. locLDT . ldtValue . _1
|
|
(sid, g) = runState (takeOne [whirdownSmall1S,whirdownSmall2S]) (w ^. randGen)
|
|
|
|
copierItemUpdate :: Item -> Creature -> World -> World
|
|
copierItemUpdate itm cr w = fromMaybe w $ do
|
|
x <- itm ^? itScroll . itsInt
|
|
invid <- itm ^? itLocation . ilInvID
|
|
ip <- itm ^? itType . ibtPathing
|
|
i <- getInventoryPath x ip invid cr
|
|
itm' <- cr ^? crInv . ix i
|
|
v <- getItemValue itm' w cr
|
|
return $ w & pointerToItem itm . itUse . uValue .~ v
|
|
|
|
doAnyEquipmentEffect :: LocationLDT ItemLink OItem -> Creature -> World -> World
|
|
doAnyEquipmentEffect loc cr = case itm ^? itLocation . ilEquipSite . _Just of
|
|
Just _ -> equipBackgroundEffect loc cr
|
|
_ -> id
|
|
where
|
|
itm = loc ^. locLDT . ldtValue . _1
|
|
|
|
tryUseParent :: LocationLDT ItemLink OItem -> World -> World
|
|
tryUseParent loc w = fromMaybe w $ do
|
|
t <- locUp loc
|
|
let t' = t ^. locLDT
|
|
cr <- w ^? cWorld . lWorld . creatures . ix 0
|
|
return $ heldEffect InitialPress t' cr w
|
|
|
|
trySynthBullet :: LocationLDT ItemLink OItem -> World -> World
|
|
trySynthBullet loc w = fromMaybe w $ do
|
|
i <- itm ^? itLocation . ilInvID
|
|
x <- itm ^? itUse . uaParams . apInt
|
|
if x < 100
|
|
then do
|
|
bat <- loc ^? locLDT . ldtLeft . ix 0 . _2 . ldtValue . _1
|
|
j <- bat ^? itLocation . ilInvID
|
|
y <- bat ^. itConsumables
|
|
guard $ y > 0
|
|
return $
|
|
w
|
|
& cWorld . lWorld . creatures
|
|
. ix 0
|
|
. crInv
|
|
. ix i
|
|
. itUse
|
|
. uaParams
|
|
. apInt
|
|
+~ 1
|
|
& cWorld . lWorld . creatures
|
|
. ix 0
|
|
. crInv
|
|
. ix j
|
|
. itConsumables
|
|
. _Just
|
|
-~ 1
|
|
else do
|
|
mag <- loc ^? locLdtContext . cldtParent . _1
|
|
j <- mag ^? itLocation . ilInvID
|
|
y <- mag ^. itConsumables
|
|
ymax <- maxAmmo mag
|
|
guard $ y < ymax
|
|
return $
|
|
w
|
|
& cWorld . lWorld . creatures
|
|
. ix 0
|
|
. crInv
|
|
. ix i
|
|
. itUse
|
|
. uaParams
|
|
. apInt
|
|
.~ 0
|
|
& cWorld . lWorld . creatures
|
|
. ix 0
|
|
. crInv
|
|
. ix j
|
|
. itConsumables
|
|
. _Just
|
|
+~ 1
|
|
where
|
|
itm = loc ^. locLDT . ldtValue . _1
|
|
|
|
updateHeldRootItem :: Creature -> World -> World
|
|
updateHeldRootItem cr = fromMaybe id $ do
|
|
invid <- cr ^? crManipulation . manObject . imRootSelectedItem
|
|
itmtree <- invRootTrees' (_crInv cr) ^? ix invid
|
|
return $ updateAttachedItems itmtree cr
|
|
|
|
updateAttachedItems :: LDTree ItemLink CItem -> Creature -> World -> World
|
|
updateAttachedItems itmtree cr =
|
|
cldtPropagateFold
|
|
chainLinkOrientation
|
|
chainLinkOrientation
|
|
(updateItemWithOrientation cr)
|
|
(heldItemRelativeOrient (itmtree ^. ldtValue . _1) cr (0, Q.qID))
|
|
(LocLDT TopLDT itmtree)
|
|
|
|
-- need to check rotation
|
|
chainLinkOrientation ::
|
|
(Point3, Q.Quaternion Float) ->
|
|
CItem ->
|
|
ItemLink ->
|
|
CItem ->
|
|
(Point3, Q.Quaternion Float)
|
|
chainLinkOrientation (p, q) par lt child = (p + Q.rotate q p1, q * q1)
|
|
where
|
|
(p1, q1) = orientAttachment (par ^. _1) lt (child ^. _1)
|
|
|
|
updateItemWithOrientation ::
|
|
Creature ->
|
|
(Point3, Q.Quaternion Float) ->
|
|
LocationLDT ItemLink CItem ->
|
|
World ->
|
|
World
|
|
updateItemWithOrientation cr m loc@(LocLDT _ itmtree) w =
|
|
case (ci ^. _1 . itType, ci ^. _2) of
|
|
(HELD TORCH, _) -> shineTorch cr itmtree m w
|
|
--(HELD LASER, WeaponTargetingSF) -> shineTargetLaser cr itmtree m w
|
|
(HELD LASER, WeaponTargetingSF) -> shineTargetLaser cr loc w
|
|
(TARGETING tt, _) -> updateItemTargeting tt cr itm w
|
|
(ARHUD, _) -> drawARHUD loc w
|
|
_ -> w
|
|
where
|
|
ci = itmtree ^. ldtValue
|
|
itm = ci ^. _1
|
|
|
|
drawARHUD :: LocationLDT ItemLink CItem -> World -> World
|
|
drawARHUD (LocLDT con _) w = fromMaybe w $ do
|
|
itm <- con ^? cldtParent . _1
|
|
return $
|
|
w & cWorld . lWorld . flares
|
|
<>~ fold
|
|
(drawTargetingAR itm w <|> drawMapperAR itm w)
|
|
|
|
shineTargetLaser :: Creature -> LocationLDT ItemLink CItem -> World -> World
|
|
shineTargetLaser cr loc w = fromMaybe (w & pointittarg . itTgPos .~ Nothing) $ do
|
|
guard (crIsAiming cr)
|
|
(_, mag) <- find (isammolink . fst) (itmtree ^. ldtLeft)
|
|
i <- mag ^. ldtValue . _1 . itConsumables
|
|
guard $ i >= x
|
|
maginvid <- mag ^? ldtValue . _1 . itLocation . ilInvID
|
|
return $
|
|
w
|
|
& worldEventFlags . at InventoryChange ?~ ()
|
|
& cWorld . lWorld . creatures . ix (_crID cr)
|
|
. crInv
|
|
. ix maginvid
|
|
. itConsumables
|
|
. _Just
|
|
-~ x
|
|
& cWorld . lWorld . lasers
|
|
.:~ Laser
|
|
{ _lpPhaseV = 1
|
|
, _lpDir = _crDir cr + argV (Q.qToV2 q)
|
|
, _lpPos = pos
|
|
, _lpColor = col
|
|
, _lpType = TargetingLaser (_itID itm)
|
|
}
|
|
where
|
|
itmtree = loc ^. locLDT
|
|
(p,q) = heldItemRelativeOrient (locToTop loc ^. locLDT . ldtValue . _1) cr
|
|
$ orientLocation (V3 0 0 0,Q.qID) (fmap fst loc) (V3 5 0 0,Q.qID)
|
|
x = 1
|
|
isammolink AmmoInLink{} = True
|
|
isammolink _ = False
|
|
pos = _crPos cr + xyV3 (rotate3 cdir p)
|
|
cdir = _crDir cr
|
|
itm = itmtree ^. ldtValue . _1
|
|
pointittarg = cWorld . lWorld . creatures . ix cid . crInv . ix invid . itTargeting
|
|
cid = _crID cr
|
|
invid = _ilInvID $ _itLocation itm
|
|
col = blue -- mixColors reloadFrac (1-reloadFrac) blue red
|
|
|
|
--shineTargetLaser ::
|
|
-- Creature ->
|
|
-- LDTree ItemLink CItem ->
|
|
-- (Point3, Q.Quaternion Float) ->
|
|
-- World ->
|
|
-- World
|
|
--shineTargetLaser cr itmtree (p, q) w = fromMaybe (w & pointittarg . itTgPos .~ Nothing) $ do
|
|
-- guard (crIsAiming cr)
|
|
-- (_, mag) <- find (isammolink . fst) (itmtree ^. ldtLeft)
|
|
-- i <- mag ^. ldtValue . _1 . itConsumables
|
|
-- guard $ i >= x
|
|
-- maginvid <- mag ^? ldtValue . _1 . itLocation . ilInvID
|
|
-- return $
|
|
-- w
|
|
-- & worldEventFlags . at InventoryChange ?~ ()
|
|
-- & cWorld . lWorld . creatures . ix (_crID cr)
|
|
-- . crInv
|
|
-- . ix maginvid
|
|
-- . itConsumables
|
|
-- . _Just
|
|
-- -~ x
|
|
-- & cWorld . lWorld . lasers
|
|
-- .:~ Laser
|
|
-- { _lpPhaseV = 1
|
|
-- , _lpDir = _crDir cr + argV (Q.qToV2 q)
|
|
-- , _lpPos = pos
|
|
-- , _lpColor = col
|
|
-- , _lpType = TargetingLaser (_itID itm)
|
|
-- }
|
|
-- where
|
|
-- x = 1
|
|
-- isammolink AmmoInLink{} = True
|
|
-- isammolink _ = False
|
|
-- pos = _crPos cr + xyV3 (rotate3 cdir (p + V3 5 0 0))
|
|
-- cdir = _crDir cr
|
|
-- itm = itmtree ^. ldtValue . _1
|
|
-- pointittarg = cWorld . lWorld . creatures . ix cid . crInv . ix invid . itTargeting
|
|
-- cid = _crID cr
|
|
-- invid = _ilInvID $ _itLocation itm
|
|
-- col = blue -- mixColors reloadFrac (1-reloadFrac) blue red
|
|
|
|
shineTorch ::
|
|
Creature ->
|
|
LDTree ItemLink CItem ->
|
|
(Point3, Q.Quaternion Float) ->
|
|
World ->
|
|
World
|
|
shineTorch cr itmtree (p, q) = fromMaybe id $ do
|
|
(_, mag) <- find (isammolink . fst) (itmtree ^. ldtLeft)
|
|
i <- mag ^. ldtValue . _1 . itConsumables
|
|
guard $ crIsAiming cr
|
|
guard $ i >= x
|
|
invid <- mag ^? ldtValue . _1 . itLocation . ilInvID
|
|
return $
|
|
(cWorld . lWorld . lights .:~ LSParam pos'' 250 0.7)
|
|
. (cWorld . lWorld . creatures . ix (_crID cr) . crInv . ix invid . itConsumables . _Just -~ 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)
|
|
|
|
-- this probably needs to be set to null when dropped as well?
|
|
-- does this need to be updated if it is not attached to the used root item?
|
|
updateItemTargeting :: TargetingType -> Creature -> Item -> World -> World
|
|
updateItemTargeting tt cr itm w = case tt of
|
|
_
|
|
| not isattached ->
|
|
w
|
|
& pointittarg . itTgPos .~ Nothing
|
|
& pointittarg . itTgActive .~ False
|
|
TargetRBPress
|
|
| rbpressed ->
|
|
w
|
|
& pointittarg . itTgPos %~ maybe (Just $ w ^. cWorld . lWorld . lAimPos) Just
|
|
& pointittarg . itTgActive .~ True
|
|
TargetRBPress ->
|
|
w
|
|
& pointittarg . itTgPos .~ Nothing
|
|
& pointittarg . itTgActive .~ False
|
|
TargetRBCreature -> w & pointittarg %~ setRBCreatureTargeting cr w
|
|
TargetCursor ->
|
|
w
|
|
& pointittarg
|
|
.~ ItTargeting
|
|
(Just (w ^. cWorld . lWorld . lAimPos))
|
|
Nothing
|
|
True
|
|
where
|
|
pointittarg = cWorld . lWorld . creatures . ix cid . crInv . ix invid . itTargeting
|
|
cid = _crID cr
|
|
invid = _ilInvID $ _itLocation itm
|
|
isattached = itm ^?! itLocation . ilIsAttached
|
|
rbpressed = SDL.ButtonRight `M.member` _mouseButtons (_input w)
|
|
|
|
setRBCreatureTargeting :: Creature -> World -> ItemTargeting -> ItemTargeting
|
|
setRBCreatureTargeting cr w ituse
|
|
| SDL.ButtonRight `M.member` _mouseButtons (_input w)
|
|
, isJust (ituse ^? itTgID . _Just)
|
|
, canSeeTarget =
|
|
ituse & updatePos & itTgActive .~ True
|
|
| otherwise = ituse & itTgID .~ fmap _crID newtarg & updatePos & itTgActive .~ False
|
|
where
|
|
newtarg =
|
|
safeMinimumOn (dist mwp . _crPos)
|
|
. filter (canseepos . _crPos)
|
|
$ crsNearCirc mwp 40 w
|
|
canseepos p = hasLOS (_crPos cr) p w
|
|
mwp = w ^. cWorld . lWorld . lAimPos
|
|
updatePos t' = t' & itTgPos .~ posFromMaybeID (_itTgID t')
|
|
posFromMaybeID Nothing = Nothing
|
|
posFromMaybeID (Just i) = w ^? cWorld . lWorld . creatures . ix i . crPos
|
|
canSeeTarget = fromMaybe False $ do
|
|
cid <- ituse ^? itTgID . _Just
|
|
cpos <- w ^? cWorld . lWorld . creatures . ix cid . crPos
|
|
Just $ hasLOS cpos (_crPos cr) w
|
|
|
|
--isFrictionless :: Creature -> Bool
|
|
--isFrictionless cr = case cr ^? crStance . carriage of
|
|
-- Just (Boosting _) -> True
|
|
-- Just Floating -> True
|
|
-- _ -> False
|