--{-# LANGUAGE TupleSections #-} -- | Actions performed by creatures within the world module Dodge.Creature.Action ( performActions, -- setMinInvSize, dropExcept, dropItem, blinkActionMousePos, blinkActionFail, unsafeBlinkAction, -- sizeSelf, youDropItem, ) where import Dodge.Creature.MoveType import Dodge.Creature.Radius import Dodge.Item.BackgroundEffect import Control.Applicative 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.FloatFunction import Dodge.FloorItem import Dodge.Inventory import Dodge.Path import Dodge.SoundLogic 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 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 | otherwise = p performPathTo :: Creature -> World -> Point2 -> OutAction performPathTo cr w p | dist cpos p <= crRad (cr ^. crType) = ([], 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 -- why not a cid (Int)? dropItem :: Creature -> Int -> World -> World dropItem cr invid = doanyitemdropeffect . maybeshiftseldown . rmInvItem (_crID cr) invid . copyItemToFloor (_crPos cr) itm -- . mayberemoveequip . soundStart (CrSound (_crID cr)) (_crPos cr) whiteNoiseFadeOutS Nothing 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") $ cr ^? crInv . ix invid maybeshiftseldown w = fromMaybe w $ do 3 <- w ^? hud . hudElement . diSelection . _Just . _1 return $ w & hud . hudElement . diSelection . _Just . _2 +~ 1 -- | Get your creature to drop the item under the cursor. youDropItem :: World -> World youDropItem w = fromMaybe w $ do curpos <- cr ^? crManipulation . manObject . imSelectedItem <|> fmap fst (IM.lookupMax (cr ^. crInv)) --guard $ not $ _crInvLock cr 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 --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