297 lines
11 KiB
Haskell
297 lines
11 KiB
Haskell
{-# LANGUAGE TupleSections #-}
|
|
{- | Actions performed by creatures within the world
|
|
-}
|
|
module Dodge.Creature.Action
|
|
( performActionsR
|
|
, stripNoItems
|
|
, setMinInvSize
|
|
, dropUnselected
|
|
, dropExcept
|
|
, startReloadingWeapon
|
|
, blinkAction
|
|
, sizeSelf
|
|
, crAutoReload
|
|
, copyInvItemToFloor
|
|
, youDropItem
|
|
, pickUpItem
|
|
)
|
|
where
|
|
import Dodge.Path
|
|
import Dodge.Default
|
|
import Dodge.WallCreatureCollisions
|
|
import Dodge.Creature.Stance.Data
|
|
import Dodge.WorldEvent.Shockwave
|
|
import Dodge.Data
|
|
import Dodge.Base
|
|
import Dodge.Zone
|
|
import Dodge.Base.Collide
|
|
import Dodge.SoundLogic
|
|
--import Dodge.WorldEvent
|
|
import Dodge.Inventory
|
|
import Dodge.FloorItem
|
|
--import Dodge.LightSources
|
|
import Geometry
|
|
import Picture
|
|
import qualified IntMapHelp as IM
|
|
|
|
import Control.Lens
|
|
--import Control.Monad
|
|
--import Control.Applicative
|
|
import Data.Maybe
|
|
import Data.List (findIndex)
|
|
import Control.Monad.Reader
|
|
--import qualified Data.Map as M
|
|
performActions :: World -> Creature -> Creature
|
|
performActions w cr = cr
|
|
& crActionPlan . crImpulse .~ concat iss
|
|
& crActionPlan . crAction .~ catMaybes mayas
|
|
where
|
|
(iss, mayas) = unzip $ map (performAction cr w) $ cr ^. crActionPlan . crAction
|
|
|
|
performActionsR :: Creature -> Reader World Creature
|
|
performActionsR cr = reader $ \w -> performActions w cr
|
|
|
|
type OutAction = ( [Impulse] , Maybe Action )
|
|
|
|
performAimAt :: Creature -> World -> Int -> Point2 -> OutAction
|
|
performAimAt cr w tcid p = ([TurnToward tpos aimSp], Just $ AimAt tcid tpos)
|
|
where
|
|
cdir = _crDir cr
|
|
cpos = _crPos cr
|
|
canSee' = canSee (_crID cr) tcid w
|
|
aimSp = case cr ^? crMvType . mvAimSpeed of
|
|
Just f -> f $ safeAngleVV (unitVectorAtAngle cdir) (tpos - cpos)
|
|
Nothing -> error "creature without aiming type"
|
|
tpos | canSee' = _crPos (_creatures w IM.! tcid)
|
|
| otherwise = p
|
|
|
|
performPathTo :: Creature -> World -> Point2 -> OutAction
|
|
performPathTo cr w p
|
|
| dist cpos p < 5 = ([], Nothing)
|
|
| hasLOS cpos p w = ([MvTurnToward p,MvForward,RandomTurn jit] , Just (PathTo p))
|
|
| otherwise = case pointTowardsImpulse cpos p w of
|
|
Just q -> ([MvTurnToward q,MvForward,RandomTurn jit] , Just (PathTo p))
|
|
_ -> ([],Nothing)
|
|
where
|
|
cpos = _crPos cr
|
|
jit = _mvTurnJit $ _crMvType cr
|
|
|
|
performTurnToA :: Creature -> Point2 -> OutAction
|
|
performTurnToA cr p
|
|
| angleVV cdirv dirv < 0.1 = ([], Nothing)
|
|
| otherwise = ([MvTurnToward p,RandomTurn jit] , Just (TurnToA p))
|
|
where
|
|
cpos = _crPos cr
|
|
cdirv = unitVectorAtAngle (_crDir cr)
|
|
dirv = p -.- cpos
|
|
jit = _mvTurnJit $ _crMvType cr
|
|
|
|
{- | Performing an action means that a creature has some impulses for a frame, and
|
|
updates or deletes the action itself.
|
|
-- doAction -}
|
|
performAction
|
|
:: Creature
|
|
-> World
|
|
-> Action
|
|
-> OutAction
|
|
performAction cr w ac = case ac of
|
|
AimAt tcid p -> performAimAt cr w tcid p
|
|
WaitThen 0 newAc -> ([] , Just newAc)
|
|
WaitThen t newAc -> ([] , Just (WaitThen (t-1) newAc))
|
|
ImpulsesList (xs:xss) -> (xs, Just $ ImpulsesList xss)
|
|
ImpulsesList _ -> ([], Nothing)
|
|
DoImpulses imps -> (imps, Nothing)
|
|
DoActionThen fsta afta -> case performAction cr w fsta of
|
|
(imps , Just nxta) -> (imps, Just (DoActionThen nxta afta))
|
|
(imps , Nothing ) -> (imps, Just afta)
|
|
DoActionWhile f act -> performAction cr w $ DoActionWhilePartial act f act
|
|
DoActionWhilePartial partAc f resetAc
|
|
| f (w,cr) -> case performAction cr w partAc of
|
|
(imps, Just nxta) -> (imps, Just $ DoActionWhilePartial nxta f resetAc)
|
|
(imps, Nothing) -> (imps, Just $ DoActionWhilePartial resetAc f resetAc)
|
|
| otherwise -> performAction cr w partAc
|
|
DoActionIf f ifa
|
|
| f (w,cr) -> performAction cr w ifa
|
|
| otherwise -> ([],Nothing)
|
|
DoActionIfElse ifa f elsea
|
|
| f (w,cr) -> performAction cr w ifa
|
|
| otherwise -> performAction cr w elsea
|
|
DoActionWhileInterrupt repa f afta
|
|
| f (w,cr) -> (fst $ performAction cr w repa, Just $ DoActionWhileInterrupt repa f afta)
|
|
| otherwise -> performAction cr w afta
|
|
DoActions [] -> ([], Nothing)
|
|
DoActions acs ->
|
|
let (imps, newAcs) = unzip $ map (performAction cr w) acs
|
|
in (concat imps, Just . DoActions $ catMaybes newAcs)
|
|
StartSentinelPost -> ([AddGoal $ SentinelAt (_crPos cr) (_crDir cr)], Nothing)
|
|
PathTo p -> performPathTo cr w p
|
|
TurnToA p -> performTurnToA cr p
|
|
LeadTarget p -> case cr ^? crIntention . targetCr . _Just of
|
|
Just tcr -> ([TurnTo (_crPos tcr +.+ rotateV (_crDir tcr) p)], Nothing)
|
|
_ -> ([], Nothing)
|
|
UseTarget f -> performAction cr w $ f $ cr ^? crIntention . targetCr . _Just
|
|
UseSelf f -> performAction cr w $ f cr
|
|
UseAheadPos f -> performAction cr w (f (_crPos cr +.+ 20 *.* unitVectorAtAngle (_crDir cr)))
|
|
UseMvTargetPos f -> performAction cr w $ f $ _mvToPoint $ _crIntention cr
|
|
ArbitraryAction f -> performAction cr w (f cr w)
|
|
DoImpulsesAlongside sideImp mainAc -> case performAction cr w mainAc of
|
|
(imp, Just nxtac) -> (sideImp ++ imp, Just $ DoImpulsesAlongside sideImp nxtac)
|
|
(imp, _) -> (sideImp ++ imp, Nothing)
|
|
DoReplicate t nxtac -> performAction cr w $ DoReplicatePartial nxtac t nxtac
|
|
DoReplicatePartial _ 0 pac -> performAction cr w pac
|
|
DoReplicatePartial sac t pac -> case performAction cr w pac of
|
|
(imps , Just nac) -> (imps, Just $ DoReplicatePartial sac t nac)
|
|
(imps , _) -> (imps, Just $ DoReplicatePartial sac (t-1) sac)
|
|
NoAction -> ([],Nothing)
|
|
|
|
startReloadingWeapon
|
|
:: Creature
|
|
-> World
|
|
-> Maybe World
|
|
startReloadingWeapon cr w =
|
|
let cid = _crID cr
|
|
it = _crInv cr IM.! _crInvSel cr
|
|
itRef = creatures . ix cid . crInv . ix (_crInvSel cr)
|
|
in case it of
|
|
Weapon {_wpAmmo = LoadableAmmo {_wpMaxAmmo=maxA,_wpLoadedAmmo=lA ,_wpReloadState=rS,_wpReloadTime=rT}}
|
|
| lA < maxA && rS == 0 -> Just $ set ( itRef . wpAmmo . wpLoadedAmmo) maxA
|
|
$ set ( itRef . wpAmmo . wpReloadState) rT w
|
|
_ -> Nothing
|
|
{- | Start reloading if clip is empty. -}
|
|
crAutoReload :: Creature -> Creature
|
|
crAutoReload cr = case cr ^? crInv . ix (_crInvSel cr) . wpAmmo . wpLoadedAmmo of
|
|
Just 0 | _posture (_crStance cr) /= Aiming
|
|
-> cr & crInv . ix (_crInvSel cr) . wpAmmo . wpReloadState %~ (`fromMaybe` reloadT)
|
|
& crInv . ix (_crInvSel cr) . wpAmmo . wpLoadedAmmo %~ (`fromMaybe` maxA)
|
|
_ -> cr
|
|
where
|
|
reloadT = cr ^? crInv . ix (_crInvSel cr) . wpAmmo . wpReloadTime
|
|
maxA = cr ^? crInv . ix (_crInvSel cr) . wpAmmo . wpMaxAmmo
|
|
{- | Teleport a creature to the mouse position -}
|
|
blinkAction
|
|
:: Creature
|
|
-> World
|
|
-> World
|
|
blinkAction cr w
|
|
= soundMultiFrom [TeleSound 0,TeleSound 1] p3 teleS Nothing
|
|
. over distortions (distortionBulge ++)
|
|
. set (creatures . ix cid . crPos) p3
|
|
. blinkShockwave cid p3
|
|
$ inverseShockwaveAt cpos 40 2 2 w
|
|
where
|
|
distR = 120
|
|
distortionBulge =
|
|
[RadialDistortion p3 (p3 +.+ V2 distR 0) (p3 +.+ V2 0 distR) 0.1
|
|
,RadialDistortion cpos (cpos +.+ V2 distR 0) (cpos +.+ V2 0 distR) 1.9
|
|
]
|
|
cid = _crID cr
|
|
p1 = mouseWorldPos w
|
|
cpos = _crPos cr
|
|
p2 = reflectPointWalls cpos p1 $ wallsAlongLine cpos p1 w
|
|
r = 1.5 * _crRad cr
|
|
p3 = maybe p1 (mvPointTowardAtSpeed r cpos . fst) p2
|
|
|
|
blinkShockwave
|
|
:: Int -- ^ Blinking creature ID.
|
|
-> Point2
|
|
-> World
|
|
-> World
|
|
blinkShockwave i p = makeShockwaveAt [i] p 60 1 2 cyan
|
|
|
|
setMinInvSize :: Int -> Creature -> World -> World
|
|
setMinInvSize n cr = creatures . ix (_crID cr) . crInv %~ f
|
|
where
|
|
f inv = IM.unionWith const inv $ IM.fromList $ [0..n-1] <&> (, NoItem)
|
|
|
|
stripNoItems :: Creature -> World -> World
|
|
stripNoItems cr = organiseInvKeys (_crID cr) .
|
|
( creatures . ix (_crID cr) . crInv %~ IM.mapMaybe f )
|
|
where
|
|
f NoItem = Nothing
|
|
f x = Just x
|
|
|
|
organiseInvKeys :: Int -> World -> World
|
|
organiseInvKeys cid w = w & creatures . ix cid %~
|
|
( ( crInvSel .~ newSelKey ) . (crInv .~ newInv ) )
|
|
where
|
|
cr = _creatures w IM.! cid
|
|
pairs = IM.toList (_crInv cr)
|
|
newSelKey = fromMaybe 0 $ findIndex ( (== _crInvSel cr) . fst) pairs
|
|
newInv = IM.fromAscList $ zip [0..] $ map snd pairs
|
|
|
|
dropUnselected :: Creature -> World -> World
|
|
dropUnselected cr w = foldr (dropItem cr) w . IM.keys
|
|
$ _crInvSel cr `IM.delete` _crInv cr
|
|
|
|
dropExcept :: Creature -> Int -> World -> World
|
|
dropExcept cr invid w = foldr (dropItem cr) w . IM.keys
|
|
$ invid `IM.delete` _crInv cr
|
|
|
|
dropItem :: Creature -> Int -> World -> World
|
|
dropItem cr invid = rmInvItem cid invid . copyInvItemToFloor cr invid . mayberemoveequip
|
|
where
|
|
cid = _crID cr
|
|
mayberemoveequip = case _crLeftInvSel cr of
|
|
Just i | i == invid -> creatures . ix cid . crLeftInvSel .~ Nothing
|
|
_ -> id
|
|
|
|
{- | Get your creature to drop the item under the cursor. -}
|
|
youDropItem :: World -> World
|
|
youDropItem w = case yourItem w ^? itCurseStatus of
|
|
Just Uncursed -> w
|
|
& dropItem cr (_crInvSel cr)
|
|
& soundStart (CrSound (_crID cr)) (_crPos cr) whiteNoiseFadeOutS Nothing
|
|
_ -> w
|
|
where
|
|
cr = you w
|
|
{- | Copy an inventory item to the floor. -}
|
|
copyInvItemToFloor :: Creature -> Int -> World -> World
|
|
copyInvItemToFloor cr i w = case _crInv cr IM.! i of
|
|
NoItem -> w
|
|
it -> copyItemToFloor (_crPos cr) it w
|
|
|
|
|
|
|
|
{- | Pick up a specific item. -}
|
|
pickUpItem
|
|
:: Int -- ^ Creature id
|
|
-> FloorItem
|
|
-> World
|
|
-> World
|
|
pickUpItem cid flit w = case maybeInvSlot of
|
|
Nothing -> w
|
|
Just i -> w
|
|
& soundStart (CrSound cid) (_flItPos flit) pickUpS Nothing
|
|
& updateItLocation i
|
|
& floorItems %~ IM.delete (_flItID flit)
|
|
& creatures . ix cid . 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
|
|
|
|
sizeSelf :: Float -> Creature -> World -> Maybe World
|
|
sizeSelf x cr w
|
|
-- | _crPos cr1 == _crPos cr2 = Just $ w
|
|
| not (crOnWall cr1 w) = Just $ w
|
|
& soundMultiFrom [TeleSound 0,TeleSound 1] cpos teleS Nothing
|
|
& over distortions (distortionBulge :)
|
|
& creatures . ix cid %~
|
|
( (crRad .~ 10 * x)
|
|
. (crMvType . mvSpeed .~ yourDefaultSpeed * x)
|
|
. (crStance . strideLength .~ ceiling (fromIntegral yourDefaultStrideLength * x))
|
|
)
|
|
| otherwise = Nothing
|
|
where
|
|
cr1 = colCrWall w (cr {_crRad = 10* x})
|
|
--cr2 = colCrWall w cr1
|
|
distR = 120
|
|
distortionBulge
|
|
| _crRad cr < 10*x = raddist 1.9
|
|
| otherwise = raddist 0.1
|
|
raddist = RadialDistortion cpos (cpos +.+ V2 distR 0) (cpos +.+ V2 0 distR)
|
|
cid = _crID cr
|
|
cpos = _crPos cr
|