Add dependencies

2021-09-05 23:58:50 +01:00
parent 86311c5d41
commit 4d3c0ae38f
5 changed files with 295 additions and 0 deletions
@@ -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 
@@ -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
@@ -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
@@ -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
@@ -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
+