218 lines
8.6 KiB
Haskell
218 lines
8.6 KiB
Haskell
--{-# LANGUAGE TupleSections #-}
|
|
|
|
-- | Actions performed by creatures within the world
|
|
module Dodge.Creature.Action (
|
|
performActions,
|
|
dropItem,
|
|
blinkActionMousePos,
|
|
blinkActionFail,
|
|
unsafeBlinkAction,
|
|
youDropItem,
|
|
) where
|
|
|
|
import RandomHelp
|
|
import Dodge.WorldEvent.ThingsHit
|
|
import Control.Applicative
|
|
import Control.Monad
|
|
import Data.Foldable
|
|
import Data.Maybe
|
|
import Dodge.Base
|
|
import Dodge.Creature.Action.Blink
|
|
import Dodge.Creature.Impulse
|
|
import Dodge.Creature.MoveType
|
|
import Dodge.Creature.Radius
|
|
import Dodge.CreatureEffect
|
|
import Dodge.Data.World
|
|
import Dodge.FloatFunction
|
|
import Dodge.FloorItem
|
|
import Dodge.Inventory
|
|
import Dodge.Item.BackgroundEffect
|
|
import Dodge.Path
|
|
import Dodge.SoundLogic
|
|
import Geometry
|
|
import qualified IntMapHelp as IM
|
|
import LensHelp
|
|
import Linear
|
|
import NewInt
|
|
import qualified Data.Set as S
|
|
|
|
-- it is desirable to be able to determine when an action is finished,
|
|
-- so that DoActionThen and the like are easy to define
|
|
performActions :: Int -> World -> World
|
|
performActions cid w =
|
|
foldl'
|
|
(followImpulse cid)
|
|
(w & cWorld . lWorld . creatures . ix cid . crActionPlan . apAction .~ mayas)
|
|
iss
|
|
where
|
|
cr = w ^?! cWorld . lWorld . creatures . ix cid
|
|
(iss, mayas) = fromMaybe ([],NoAction) $ performAction cr w <$> cr ^? crActionPlan . apAction
|
|
|
|
type ActionUpdate = ([Impulse], Action)
|
|
|
|
{- | Performing an action on a frame creates an ActionUpdate:
|
|
gives impulses and updates/deletes the action itself.
|
|
-}
|
|
performAction :: Creature -> World -> Action -> ActionUpdate
|
|
performAction cr w ac = case ac of
|
|
AimAt tcid p -> performAimAt cr w tcid p
|
|
WaitThen 0 newAc -> ([], newAc)
|
|
WaitThen t newAc -> ([], WaitThen (t -1) newAc)
|
|
ImpulsesList (xs : xss) a -> performAction cr w a & _1 <>~ xs
|
|
& _2 %~ ImpulsesList xss
|
|
ImpulsesList _ a -> performAction cr w a
|
|
DoImpulses imps -> (imps, NoAction)
|
|
DoActionThen fsta afta -> case performAction cr w fsta of
|
|
(imps, NoAction) -> (imps, afta)
|
|
(imps, nxta) -> (imps, DoActionThen nxta afta)
|
|
DoActionWhile f act -> performAction cr w $ DoActionWhilePartial act f act
|
|
DoActionWhilePartial partAc f resetAc
|
|
| doWdCrBl f w cr -> case performAction cr w partAc of
|
|
(imps, NoAction) -> (imps, DoActionWhilePartial resetAc f resetAc)
|
|
(imps, nxta ) -> (imps, DoActionWhilePartial nxta f resetAc)
|
|
| otherwise -> performAction cr w partAc
|
|
DoActionIf f ifa
|
|
| doWdCrBl f w cr -> performAction cr w ifa
|
|
| otherwise -> ([], NoAction)
|
|
DoActionIfElse ifa f elsea
|
|
| doWdCrBl f w cr -> performAction cr w ifa
|
|
| otherwise -> performAction cr w elsea
|
|
DoActionWhileInterrupt repa f afta
|
|
| doWdCrBl f w cr -> (fst $ performAction cr w repa, DoActionWhileInterrupt repa f afta)
|
|
| otherwise -> performAction cr w afta
|
|
-- DoActions [] -> ([], NoAction)
|
|
-- DoActions acs ->
|
|
-- let (imps, newAcs) = foldMap (performAction cr w) acs
|
|
-- in (imps, newAcs)
|
|
-- StartSentinelPost -> ([AddGoal $ SentinelAt (cr ^. crPos . _xy) (_crDir cr)], NoAction)
|
|
PathTo p a -> performPathTo a cr w p
|
|
EvadeAim -> tryEvadeSideways cr w
|
|
TurnToPoint p -> performTurnToA cr p
|
|
LeadTarget p -> fromMaybe ([], NoAction) $ do
|
|
i <- cr ^? crIntention . targetCr . _Just
|
|
tcr <- w ^? cWorld . lWorld . creatures . ix i
|
|
return ([TurnTo (tcr ^. crPos . _xy +.+ rotateV (_crDir tcr) p)], NoAction)
|
|
-- UseSelf f -> performAction cr w $ doCrAc f cr
|
|
-- ArbitraryAction f -> performAction cr w (doCrWdAc f cr w)
|
|
DoImpulsesAlongside sideImp mainAc -> performAction cr w mainAc & _1 <>~ sideImp
|
|
DoReplicate t nxtac -> performAction cr w $ DoReplicatePartial nxtac t nxtac
|
|
DoReplicatePartial _ 0 pac -> performAction cr w pac
|
|
DoReplicatePartial startac t partac -> case performAction cr w partac of
|
|
(imps, NoAction) -> (imps, DoReplicatePartial startac (t -1) startac)
|
|
(imps, nextac) -> (imps, DoReplicatePartial startac t nextac)
|
|
NoAction -> ([], NoAction)
|
|
|
|
tryEvadeSideways :: Creature -> World -> ActionUpdate
|
|
tryEvadeSideways _ w = jumpleft -- (mv,mempty)
|
|
where
|
|
jumpleft = (mv,DoReplicate 5 (DoImpulses mv))
|
|
mv = [Walk (V2 0 d),UpdateRandGen]
|
|
d = evalState (takeOne [3,-3]) (w ^. randGen)
|
|
|
|
performAimAt :: Creature -> World -> Int -> Point2 -> ActionUpdate
|
|
performAimAt cr w tcid p = ([TurnToward tpos aimSp], AimAt tcid tpos)
|
|
where
|
|
cdir = _crDir cr
|
|
cpos = cr ^. crPos . _xy
|
|
canSee' = canSee (_crID cr) tcid w
|
|
aimSp = case crMvType cr ^? mvTurnRad of
|
|
Just f -> doFloatFloat f $ safeAngleVV (unitVectorAtAngle cdir) (tpos - cpos)
|
|
Nothing -> error "creature without aiming type"
|
|
-- aimSp = case crMvType cr ^? mvAimSpeed of
|
|
-- Just f -> doFloatFloat f $ safeAngleVV (unitVectorAtAngle cdir) (tpos - cpos)
|
|
-- Nothing -> error "creature without aiming type"
|
|
tpos
|
|
| canSee' = w ^?! cWorld . lWorld . creatures . ix tcid . crPos . _xy
|
|
| otherwise = p
|
|
|
|
crPathing :: Creature -> (Point2 -> Point2 -> World -> Bool,S.Set EdgeObstacle -> Bool)
|
|
crPathing cr = case cr ^. crStance . carriage of
|
|
Flying {} -> (isFlyable, not . S.member (WallObstacle WallNotAutoOpen))
|
|
_ -> (isWalkable, not . pathEdgeObstructed)
|
|
|
|
performPathTo :: Action -> Creature -> World -> Point2 -> ActionUpdate
|
|
performPathTo a cr w p
|
|
| dist cpos p <= crRad (cr ^. crType) = (mempty,NoAction)
|
|
| fst (crPathing cr) cpos p w = gotowards p
|
|
| otherwise = case uncurry pointTowardsImpulse' (crPathing cr) cpos p w of
|
|
Just q -> gotowards q
|
|
_ -> ([], a)
|
|
where
|
|
gotowards q = ( crMoveImpulses cr q , PathTo p a)
|
|
cpos = cr ^. crPos . _xy
|
|
|
|
crMoveImpulses :: Creature -> Point2 -> [Impulse]
|
|
crMoveImpulses cr p = case crMvType cr of
|
|
NoMvType -> [MvTurnToward p, MvForward]
|
|
MvWalking {} -> [MvTurnToward p, MvForward]
|
|
JitMvType {_mvTurnJit = x} -> [MvTurnToward p, MvForward, RandomTurn x]
|
|
StartStopMvType {} -> [MvTurnToward p, MvForward]
|
|
BeeMvType {} | cr ^?! crType . startStopMv == 0 -> [SetBeeRandomMovement, MvForward, MvTurnToward p]
|
|
BeeMvType {} -> [MvTurnToward p, MvForward]
|
|
|
|
performTurnToA :: Creature -> Point2 -> ActionUpdate
|
|
performTurnToA cr p
|
|
| angleVV cdirv dirv < 0.1 = (mempty,NoAction)
|
|
| otherwise = ([MvTurnToward p, RandomTurn jit], TurnToPoint p)
|
|
where
|
|
cpos = cr ^. crPos . _xy
|
|
cdirv = unitVectorAtAngle (_crDir cr)
|
|
dirv = p -.- cpos
|
|
jit = _mvTurnJit $ crMvType cr
|
|
|
|
--setMinInvSize :: Int -> Creature -> World -> World
|
|
--setMinInvSize n cr = cWorld . lWorld . creatures . ix (_crID cr) . crInvCapacity .~ n
|
|
|
|
--organiseInvKeys :: Int -> World -> World
|
|
--organiseInvKeys cid w =
|
|
-- w & cWorld . lWorld . creatures . ix cid
|
|
-- %~ ( (crInvSel . iselPos .~ newSelKey)
|
|
-- . (crInv .~ newInv)
|
|
-- . (crInvSel . iselAction .~ NoInvSelAction)
|
|
-- )
|
|
-- where
|
|
-- cr = w ^?! cWorld . lWorld . creatures . ix cid -- _creatures (_cWorld w) IM.! cid
|
|
-- pairs = IM.toList (_crInv cr)
|
|
-- newSelKey = fromMaybe 0 $ findIndex ((== crSel cr) . fst) pairs
|
|
-- newInv = IM.fromAscList $ zip [0 ..] $ map snd pairs
|
|
|
|
-- why not a cid (Int)?
|
|
dropItem :: Creature -> Int -> World -> World
|
|
dropItem cr invid w' =
|
|
doanyitemdropeffect
|
|
. maybeshiftseldown
|
|
. copyItemToFloor (cr ^. crPos . _xy) itm -- . mayberemoveequip
|
|
. rmInvItem (_crID cr) (NInt invid) -- it is important
|
|
-- to do this before copying the item to the floor!
|
|
. soundStart (CrSound (_crID cr)) (cr ^. crPos . _xy) whiteNoiseFadeOutS Nothing
|
|
$ w'
|
|
where
|
|
--doanyitemdropeffect = fromMaybe id $ do
|
|
-- rmf <- itm ^? itEffect . ieOnDrop
|
|
-- return $ doInvEffect rmf itm cr
|
|
doanyitemdropeffect = itEffectOnDrop itm cr
|
|
itm = fromMaybe (error "dropItem cannot find item") $ do
|
|
itid <- cr ^? crInv . ix (NInt invid)
|
|
w' ^? cWorld . lWorld . items . ix itid
|
|
maybeshiftseldown w = fromMaybe w $ do
|
|
3 <- w ^? hud . diSelection . _Just . slSec
|
|
return $ w & hud . diSelection . _Just . slInt +~ 1
|
|
|
|
-- | Get your creature to drop the item under the cursor.
|
|
youDropItem :: World -> World
|
|
youDropItem w = fromMaybe w $ do
|
|
curpos <-
|
|
cr ^? crManipulation . manObject . imSelectedItem . unNInt
|
|
<|> fmap fst (IM.lookupMax (cr ^. crInv . unNIntMap))
|
|
guard $ not $ w ^. cWorld . lWorld . lInvLock
|
|
return $ case cr ^. crStance . posture of
|
|
Aiming{} -> throwItem w
|
|
AtEase -> dropItem cr curpos w
|
|
where
|
|
cr = you w
|
|
|
|
-- placeholder, remember to deal with two handed weapon twist
|
|
-- should throw all attached items?
|
|
throwItem :: World -> World
|
|
throwItem = id
|