diff --git a/src/Dodge/Creature/Impulse.hs b/src/Dodge/Creature/Impulse.hs new file mode 100644 index 000000000..b69dfe346 --- /dev/null +++ b/src/Dodge/Creature/Impulse.hs @@ -0,0 +1,85 @@ +module Dodge.Creature.Impulse + ( impulsiveAIR + ) + where +import Dodge.Data +import Dodge.Creature.Impulse.Movement +import Dodge.Creature.Impulse.UseItem +--import Dodge.Creature.Action.UseItem +import Dodge.Creature.State.Data +import Dodge.Creature.Stance.Data +import Dodge.SoundLogic +import Dodge.SoundLogic.Synonyms +import Geometry + +import qualified Data.IntMap.Strict as IM +import System.Random +import Control.Lens +import Control.Monad.Reader +import Data.Monoid +import Data.Bifunctor + +impulsiveAIR + :: (Creature -> Reader World Creature) + -> Creature + -> World + -> (Endo World , Maybe Creature) +impulsiveAIR impf cr w = bimap Endo Just $ followImpulses w . ($ w) . runReader $ impf cr + +followImpulses + :: World + -> Creature + -> (World -> World, Creature) +followImpulses w cr + = foldr + foldf + (id, cr) + (_crImpulse $ _crActionPlan cr) + where + foldf imp (f,cr') = first ( . f) $ followImpulse cr' w imp + +followImpulse + :: Creature + -> World + -> Impulse + -> (World -> World , Creature) +followImpulse cr w imp = case imp of + Move p -> (id, crMvBy p cr) + MoveForward x -> (id, crMvForward x cr) + Turn a -> (id, creatureTurn a cr) + TurnToward p a -> (id, creatureTurnToward p a cr) + TurnTo p -> (id, creatureTurnTo p cr) + ChangePosture post -> (id, cr & crStance . posture .~ post) + UseItem -> (tryUseItem cr, cr) + SwitchToItem i -> (id, cr & crInvSel .~ i) + Melee cid -> + (hitCr cid + , crMvBy (10 *.* normalizeV (posFromID cid -.- cpos)) $ cr & crMeleeCooldown .~ 20) -- randomise cooldown? + RandomTurn a -> (id, creatureTurn (rr a) cr) + MakeSound sid -> ( soundOnceOrigin sid (CrSound (_crID cr)) (_crPos cr) , cr ) + DropItem -> undefined + ChangeStrategy strat -> (id, cr & crActionPlan . crStrategy .~ strat) + AddGoal gl -> (id, cr & crActionPlan . crGoal %~ (gl :) ) + ArbitraryImpulseFunction f -> (id, f w cr) + ArbitraryImpulse f -> followImpulse cr w (f cr w) + ImpulseUseTargetCID f -> case cr ^? crTarget . _Just of + Just tcr -> followImpulse cr w (f $ _crID tcr) + _ -> (id,cr) + ImpulseUseTarget f -> case cr ^? crTarget . _Just of + Just tcr -> followImpulse cr w (f tcr) + _ -> (id,cr) + ImpulseUseAheadPos f -> followImpulse cr w (f (_crPos cr +.+ 20 *.* unitVectorAtAngle (_crDir cr))) + MvForward -> (id, crMvForward speed cr) + MvTurnToward p -> (id, creatureTurnToward p (turnRad $ safeAngleVV (p -.- cpos) (unitVectorAtAngle cdir)) cr) +-- _ -> (id , cr) + where + mvType = _crMvType cr + speed = _mvSpeed mvType + turnRad = _mvTurnRad mvType + cpos = _crPos cr + cdir = _crDir cr + posFromID cid = _crPos $ _creatures w IM.! cid + rr a = fst $ randomR (-a,a) $ _randGen w + hitCr i = over (creatures . ix i . crState . crDamage) (addDam i) + . soundOnce hitSound + addDam i dams = Blunt 100 cpos (posFromID i) (posFromID i) : dams diff --git a/src/Dodge/Creature/Impulse/Flee.hs b/src/Dodge/Creature/Impulse/Flee.hs new file mode 100644 index 000000000..2161c916a --- /dev/null +++ b/src/Dodge/Creature/Impulse/Flee.hs @@ -0,0 +1,22 @@ +module Dodge.Creature.Impulse.Flee + where +import Dodge.Data +import Geometry +import FoldableHelp + +retreatPointForFrom + :: Float -> World -> Creature -> Point2 -> Maybe Point2 +retreatPointForFrom d _ cr p + = safeMinimumOn (dist cpos) + $ divideCircle 10 p d + where + cpos = _crPos cr +-- = head $ sortBy (compare `on` (\p -> dist p ypos < 300)) $ retreatP'' : retreatPs +-- where +-- retreatPs = sortBy (compare `on` dist cpos) $ map f $ nRaysRad 8 400 +-- where f p = fromMaybe (ypos +.+ p) $ fmap fst +-- $ reflectPointWalls ypos (ypos +.+ p) (wallsAlongLine ypos (ypos +.+ p) w) +-- retreatP' = cpos +.+ 300 *.* (cpos -.- ypos) +-- retreatP'' = fromMaybe retreatP' $ fmap fst +-- $ reflectPointWalls ypos retreatP' +-- $ wallsAlongLine ypos retreatP' w diff --git a/src/Dodge/Creature/Impulse/Movement.hs b/src/Dodge/Creature/Impulse/Movement.hs new file mode 100644 index 000000000..16c7770a4 --- /dev/null +++ b/src/Dodge/Creature/Impulse/Movement.hs @@ -0,0 +1,114 @@ +module Dodge.Creature.Impulse.Movement + where +import Dodge.Data +import Dodge.Creature.Stance.Data +import Dodge.Item.Data +import Geometry + +import Data.Maybe +import qualified Data.IntMap.Strict as IM +import Control.Lens +{- | Creature attempts to moves under its own steam. +The idea is that this may or may not work, depending on the status of the creature. +For now, though, this cannot fail. -} +crMvBy + :: Point2 -- ^ Movement translation vector, will be made relative to creature direction + -> Creature + -> Creature +crMvBy p' cr = advanceStepCounter (magV p) cr + & crPos %~ (+.+ p) + & crMvDir .~ argV p + where + p = (*.*) (equipFactor * aimingFactor) $ rotateV (_crDir cr) p' + equipFactor + | _posture (_crStance cr) == Aiming + = product $ map equipAimSpeed $ IM.elems $ _crInv cr + | otherwise = product $ map equipSpeed $ IM.elems $ _crInv cr + aimingFactor + | _posture (_crStance cr) == Aiming = fromMaybe 1 $ it ^? itAimingSpeed + | otherwise = 1 + it = _crInv cr IM.! _crInvSel cr + +crMvAbsolute + :: Point2 -- ^ Movement translation vector + -> Creature + -> Creature +crMvAbsolute p' cr = advanceStepCounter (magV p) cr + & crPos %~ (+.+ p) + & crMvDir .~ argV p + where + p = (*.*) (equipFactor * aimingFactor) p' + equipFactor + | _posture (_crStance cr) == Aiming + = product $ map equipAimSpeed $ IM.elems $ _crInv cr + | otherwise = product $ map equipSpeed $ IM.elems $ _crInv cr + aimingFactor + | _posture (_crStance cr) == Aiming = fromMaybe 1 $ it ^? itAimingSpeed + | otherwise = 1 + it = _crInv cr IM.! _crInvSel cr + +crMvForward + :: Float -- ^ Speed + -> Creature + -> Creature +crMvForward speed = crMvBy (V2 speed 0) + +advanceStepCounter + :: Float -- ^ Speed + -> Creature + -> Creature +advanceStepCounter speed cr = cr & crStance . carriage %~ f + where + --stnce = _crStance cr + f car = case car of + Standing -> f (Walking 0 RightForward) + Walking i ff -> Walking (i + ceiling speed) ff + _ -> car + +creatureTurn :: Float -> Creature -> Creature +creatureTurn a = crDir +~ a + +creatureTurnTo :: Point2 -> Creature -> Creature +creatureTurnTo p cr + | vToTarg == V2 0 0 = cr -- this should deal with the angleVV error + | otherwise = cr & crDir .~ dirToTarget + where + vToTarg = p -.- _crPos cr + dirToTarget = argV vToTarg + +creatureTurnTowardDir + :: Float -- ^ Angle + -> Float -- ^ Turn speed + -> Creature + -> Creature +creatureTurnTowardDir a turnSpeed cr + | vToTarg == V2 0 0 = cr -- this should deal with the angleVV error + | errorAngleVV 3 vToTarg (unitVectorAtAngle (_crDir cr)) <= turnSpeed + = cr & crDir .~ dirToTarget + | isLeftOfA (normalizeAngle dirToTarget) (normalizeAngle $ _crDir cr) = cr & crDir +~ turnSpeed + | otherwise = cr & crDir -~ turnSpeed + where + vToTarg = rotateV a (V2 1 0) + dirToTarget = argV vToTarg + +creatureTurnToward :: Point2 -> Float -> Creature -> Creature +creatureTurnToward p turnSpeed cr + | vToTarg == V2 0 0 = cr -- this should deal with the angleVV error + | errorAngleVV 3 vToTarg (unitVectorAtAngle (_crDir cr)) <= turnSpeed + = cr & crDir .~ dirToTarget + | isLeftOfA (normalizeAngle dirToTarget) (normalizeAngle $ _crDir cr) = cr & crDir +~ turnSpeed + | otherwise = cr & crDir -~ turnSpeed + where + vToTarg = p -.- _crPos cr + dirToTarget = argV vToTarg + +{- | Speed modifier of an item when not aiming. -} +equipSpeed :: Item -> Float +equipSpeed _ = 1 +{- | Speed modifier of an item when aiming. -} +equipAimSpeed :: Item -> Float +equipAimSpeed NoItem = 1 +equipAimSpeed it + | _itIdentity it == FrontArmour = 0.5 + | _itIdentity it == FlameShield = 0.5 + | otherwise = 1 diff --git a/src/Dodge/Creature/Impulse/UseItem.hs b/src/Dodge/Creature/Impulse/UseItem.hs new file mode 100644 index 000000000..61ad549da --- /dev/null +++ b/src/Dodge/Creature/Impulse/UseItem.hs @@ -0,0 +1,48 @@ +module Dodge.Creature.Impulse.UseItem + ( useItem + , tryUseItem + , useLeftItem + ) + where +import Dodge.Data +import Dodge.Inventory + +import qualified Data.IntMap.Strict as IM +import Control.Lens +import Data.Maybe + +useItem :: Int -> World -> World +useItem n w = itemEffect c it w + where + c = _creatures w IM.! n + it = _crInv c IM.! _crInvSel c + +tryUseItem + :: Creature + -> World + -> World +tryUseItem cr' w = case w ^? creatures . ix (_crID cr') of + Just cr -> itemEffect cr (_crInv cr IM.! _crInvSel cr) w + Nothing -> w + +itemEffect + :: Creature + -> Item + -> World + -> World +itemEffect cr Consumable{_cnEffect=eff } w = maybe w (rmSelectedInvItem (_crID cr)) (eff (_crID cr) w) +itemEffect cr it@Weapon{_itUse=eff} w = foldr ($) eff (_itUseModifiers it) it cr w +itemEffect cr it@Throwable{_itUse = eff} w = foldr ($) eff (_itUseModifiers it) it cr w +itemEffect _ _ w = w + +useLeftItem + :: Int + -> World + -> World +useLeftItem cid w = case luse of + Nothing -> w + Just (invid, f) -> f cr invid w + where + cr = _creatures w IM.! cid + luses = IM.mapMaybe (^? itLeftClickUse . _Just) (_crInv cr) + luse = listToMaybe $ IM.toList luses diff --git a/src/Dodge/Creature/Strategy.hs b/src/Dodge/Creature/Strategy.hs new file mode 100644 index 000000000..d59e03f42 --- /dev/null +++ b/src/Dodge/Creature/Strategy.hs @@ -0,0 +1,26 @@ +module Dodge.Creature.Strategy + ( goToPostStrat + ) + where +import Dodge.Data +import Dodge.Creature.Test +import Dodge.Creature.Volition + +import Data.List + +goToPostStrat :: World -> Creature -> Strategy +goToPostStrat w cr = case find sentinelGoal $ _crGoal $ _crActionPlan cr of + Just (SentinelAt p _) -> StrategyActions (GetTo p) + [DoActionThen (WaitThen 150 holsterIfAiming) + $ DoActionThen (PathTo p) + NoAction + -- $ DoImpulses [ChangeStrategy WatchAndWait] + ] + _ -> WatchAndWait + where + sentinelGoal (SentinelAt _ _) = True + sentinelGoal _ = False + holsterIfAiming + | crIsAiming (w,cr) = holsterWeapon + | otherwise = NoAction +