220 lines
8.3 KiB
Haskell
220 lines
8.3 KiB
Haskell
--{-# LANGUAGE TupleSections #-}
|
|
|
|
-- | Actions performed by creatures within the world
|
|
module Dodge.Creature.Action (
|
|
performActions,
|
|
-- stripNoItems,
|
|
setMinInvSize,
|
|
-- dropUnselected,
|
|
dropExcept,
|
|
dropItem,
|
|
blinkActionMousePos,
|
|
blinkActionFail,
|
|
unsafeBlinkAction,
|
|
sizeSelf,
|
|
youDropItem,
|
|
pickUpItem,
|
|
-- pickUpItemID,
|
|
) where
|
|
|
|
import Control.Applicative
|
|
--import Data.List (findIndex)
|
|
|
|
import Control.Monad
|
|
import Data.Bifunctor
|
|
import Data.Maybe
|
|
import Dodge.Base
|
|
import Dodge.Creature.Action.Blink
|
|
import Dodge.CreatureEffect
|
|
import Dodge.Data.SelectionList
|
|
import Dodge.Data.World
|
|
import Dodge.Default
|
|
import Dodge.FloatFunction
|
|
import Dodge.FloorItem
|
|
import Dodge.Inventory
|
|
import Dodge.Inventory.Add
|
|
import Dodge.Path
|
|
import Dodge.SoundLogic
|
|
import Dodge.WallCreatureCollisions
|
|
import Geometry
|
|
import qualified IntMapHelp as IM
|
|
import LensHelp
|
|
|
|
performActions :: World -> Creature -> Creature
|
|
performActions w cr =
|
|
cr
|
|
& crActionPlan . apImpulse .~ concat iss
|
|
& crActionPlan . apAction .~ catMaybes mayas
|
|
where
|
|
(iss, mayas) = unzip $ map (performAction cr w) $ cr ^. crActionPlan . apAction
|
|
|
|
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 -> doFloatFloat f $ safeAngleVV (unitVectorAtAngle cdir) (tpos - cpos)
|
|
Nothing -> error "creature without aiming type"
|
|
tpos
|
|
| canSee' = w ^?! cWorld . lWorld . creatures . ix tcid . crPos
|
|
| otherwise = p
|
|
|
|
performPathTo :: Creature -> World -> Point2 -> OutAction
|
|
performPathTo cr w p
|
|
| dist cpos p <= _crRad cr = ([], Nothing)
|
|
| isWalkable cpos p w = ([MvTurnToward p, MvForward, RandomTurn jit], Just (PathTo p))
|
|
| otherwise = case pointTowardsImpulse p cpos 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 (TurnToPoint p))
|
|
where
|
|
cpos = _crPos cr
|
|
cdirv = unitVectorAtAngle (_crDir cr)
|
|
dirv = p -.- cpos
|
|
jit = _mvTurnJit $ _crMvType cr
|
|
|
|
{- | Performing an action on a frame creates an OutAction:
|
|
adds impulses and updates or deletes the action itself.
|
|
-}
|
|
performAction :: Creature -> World -> Action -> OutAction
|
|
performAction cr w ac = case ac of
|
|
ActionNothing -> ([], Nothing)
|
|
LabelAction str subAc -> second (fmap (LabelAction str)) $ performAction cr w subAc
|
|
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
|
|
| doWdCrBl 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
|
|
| doWdCrBl f w cr -> performAction cr w ifa
|
|
| otherwise -> ([], Nothing)
|
|
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, 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
|
|
TurnToPoint 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 $ doMCrAc f $ cr ^? crIntention . targetCr . _Just
|
|
UseSelf f -> performAction cr w $ doCrAc f cr
|
|
UseAheadPos f -> performAction cr w (doP2Ac f (_crPos cr +.+ 20 *.* unitVectorAtAngle (_crDir cr)))
|
|
UseMvTargetPos f -> performAction cr w $ doMP2Ac f $ _mvToPoint $ _crIntention cr
|
|
ArbitraryAction f -> performAction cr w (doCrWdAc 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 startac t partac -> case performAction cr w partac of
|
|
(imps, Just nextac) -> (imps, Just $ DoReplicatePartial startac t nextac)
|
|
(imps, _) -> (imps, Just $ DoReplicatePartial startac (t -1) startac)
|
|
NoAction -> ([], Nothing)
|
|
|
|
setMinInvSize :: Int -> Creature -> World -> World
|
|
setMinInvSize n cr = cWorld . lWorld . creatures . ix (_crID cr) . crInvCapacity .~ n
|
|
|
|
---- maybe this should be removed...
|
|
--stripNoItems :: Creature -> World -> World
|
|
--stripNoItems cr =
|
|
-- organiseInvKeys (_crID cr)
|
|
-- . (cWorld . lWorld . creatures . ix (_crID cr) . crInv %~ IM.mapMaybe Just)
|
|
--
|
|
--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
|
|
|
|
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 (_crID cr) invid .
|
|
copyItemToFloor (_crPos cr) itm -- . mayberemoveequip
|
|
where
|
|
itm = fromMaybe (error "dropItem cannot find item") $ cr ^? crInv . ix invid
|
|
|
|
-- | Get your creature to drop the item under the cursor.
|
|
youDropItem :: World -> World
|
|
youDropItem w = fromMaybe w $ do
|
|
curpos <-
|
|
you w ^? crManipulation . manObject . imSelectedItem
|
|
<|> fmap fst (IM.lookupMax =<< w ^? hud . hudElement . diSections . ix 0 . ssItems)
|
|
guard $ not $ _crInvLock (you w)
|
|
return $
|
|
w
|
|
& dropItem cr curpos
|
|
& soundStart (CrSound (_crID cr)) (_crPos cr) whiteNoiseFadeOutS Nothing
|
|
where
|
|
cr = you w
|
|
|
|
sizeSelf :: Float -> Creature -> World -> Maybe World
|
|
sizeSelf x cr w
|
|
| not (crOnWall cr1 w) =
|
|
Just $
|
|
w
|
|
& soundMultiFrom [TeleSound 0, TeleSound 1] cpos teleS Nothing
|
|
& cWorld . lWorld . distortions .:~ distortionBulge
|
|
& cWorld . lWorld . 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})
|
|
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
|
|
|